{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Knit.Report.Output.Html
(
htmlWriterOptions
, toBlazeDocument
, pandocWriterToBlazeDocument
, mindocOptionsF
, markDownTextToBlazeFragment
, writeAllPandocResultsWithInfoAsHtml
, writePandocResultWithInfoAsHtml
)
where
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Map as M
import qualified Text.Blaze.Html as BH
import qualified Text.Pandoc as PA
import qualified Polysemy as P
import qualified Knit.Effect.Pandoc as PE
import qualified Knit.Effect.PandocMonad as PM
import Knit.Report.Input.MarkDown.PandocMarkDown
( markDownReaderOptions )
import Knit.Report.Output as KO
#if MIN_VERSION_pandoc (2,8,0)
import qualified Text.DocTemplates as DT
import qualified Control.Monad.Except as X
#endif
htmlWriterOptions :: PA.WriterOptions
htmlWriterOptions :: WriterOptions
htmlWriterOptions = WriterOptions
forall a. Default a => a
PA.def
{ writerExtensions :: Extensions
PA.writerExtensions = [Extension] -> Extensions
PA.extensionsFromList [Extension
PA.Ext_raw_html]
, writerHTMLMathMethod :: HTMLMathMethod
PA.writerHTMLMathMethod = Text -> HTMLMathMethod
PA.MathJax ""
}
#if MIN_VERSION_pandoc (2,8,0)
htmlFullDocWriterOptions
:: forall m. (PA.PandocMonad m, DT.TemplateMonad m)
=> Maybe FilePath
-> M.Map String String
-> m PA.WriterOptions
htmlFullDocWriterOptions :: Maybe FilePath -> Map FilePath FilePath -> m WriterOptions
htmlFullDocWriterOptions pathM :: Maybe FilePath
pathM tVars :: Map FilePath FilePath
tVars = do
let tContext :: Context Text
tContext = Map Text (Val Text) -> Context Text
forall a. Map Text (Val a) -> Context a
DT.Context (Map Text (Val Text) -> Context Text)
-> Map Text (Val Text) -> Context Text
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text)
-> Map FilePath (Val Text) -> Map Text (Val Text)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys FilePath -> Text
T.pack (Map FilePath (Val Text) -> Map Text (Val Text))
-> Map FilePath (Val Text) -> Map Text (Val Text)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Val Text)
-> Map FilePath FilePath -> Map FilePath (Val Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Val Text
forall a b. ToContext a b => b -> Val a
DT.toVal (Text -> Val Text) -> (FilePath -> Text) -> FilePath -> Val Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) Map FilePath FilePath
tVars
makeTemplateM :: FilePath -> m T.Text -> m (Maybe (DT.Template T.Text))
makeTemplateM :: FilePath -> m Text -> m (Maybe (Template Text))
makeTemplateM pfp :: FilePath
pfp getText :: m Text
getText = do
Text
txt <- m Text
getText
Either FilePath (Template FilePath)
compiled <- FilePath -> Text -> m (Either FilePath (Template FilePath))
forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
FilePath -> Text -> m (Either FilePath (Template a))
PA.compileTemplate FilePath
pfp Text
txt
case Either FilePath (Template FilePath)
compiled of
Left msg :: FilePath
msg -> PandocError -> m (Maybe (Template Text))
forall e (m :: * -> *) a. MonadError e m => e -> m a
X.throwError (PandocError -> m (Maybe (Template Text)))
-> PandocError -> m (Maybe (Template Text))
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PA.PandocTemplateError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
msg
Right tmplt :: Template FilePath
tmplt -> Maybe (Template Text) -> m (Maybe (Template Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Template Text) -> m (Maybe (Template Text)))
-> Maybe (Template Text) -> m (Maybe (Template Text))
forall a b. (a -> b) -> a -> b
$ Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just (Template Text -> Maybe (Template Text))
-> Template Text -> Maybe (Template Text)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text) -> Template FilePath -> Template Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack Template FilePath
tmplt
defaultTemplateM :: m (Maybe (Template Text))
defaultTemplateM = FilePath -> m Text -> m (Maybe (Template Text))
makeTemplateM "default.Html5" (Text -> m Text
forall (m :: * -> *). PandocMonad m => Text -> m Text
PA.getDefaultTemplate "Html5")
Maybe (Template Text)
templateM <- case Maybe FilePath
pathM of
Nothing -> m (Maybe (Template Text))
defaultTemplateM
Just fp :: FilePath
fp -> do
Bool
exists <- FilePath -> m Bool
forall (m :: * -> *). PandocMonad m => FilePath -> m Bool
PA.fileExists FilePath
fp
if Bool
exists
then FilePath -> m Text -> m (Maybe (Template Text))
makeTemplateM "" (m Text -> m (Maybe (Template Text)))
-> m Text -> m (Maybe (Template Text))
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text) -> m ByteString -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Text
T.pack (FilePath -> Text)
-> (ByteString -> FilePath) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS.unpack) (FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
PA.readFileStrict FilePath
fp)
else
LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
PA.logOutput
(Text -> LogMessage
PA.IgnoredIOError
(Text -> Text
PM.textToPandocText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "Couldn't find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp))
)
m () -> m (Maybe (Template Text)) -> m (Maybe (Template Text))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Maybe (Template Text))
defaultTemplateM
WriterOptions -> m WriterOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (WriterOptions -> m WriterOptions)
-> WriterOptions -> m WriterOptions
forall a b. (a -> b) -> a -> b
$ WriterOptions
htmlWriterOptions { writerTemplate :: Maybe (Template Text)
PA.writerTemplate = Maybe (Template Text)
templateM
, writerVariables :: Context Text
PA.writerVariables = Context Text
tContext
, writerSetextHeaders :: Bool
PA.writerSetextHeaders = Bool
True
}
toBlazeDocument
:: PM.PandocEffects effs
=> KO.PandocWriterConfig
-> PE.PandocWithRequirements
-> P.Sem effs BH.Html
toBlazeDocument :: PandocWriterConfig -> PandocWithRequirements -> Sem effs Html
toBlazeDocument writeConfig :: PandocWriterConfig
writeConfig pdocWR :: PandocWithRequirements
pdocWR = (TemplateMonad (Sem effs) => Sem effs Html) -> Sem effs Html
forall (r :: [(* -> *) -> * -> *]) a.
Member Template r =>
(TemplateMonad (Sem r) => Sem r a) -> Sem r a
PM.absorbTemplateMonad ((TemplateMonad (Sem effs) => Sem effs Html) -> Sem effs Html)
-> (TemplateMonad (Sem effs) => Sem effs Html) -> Sem effs Html
forall a b. (a -> b) -> a -> b
$ (PandocMonad (Sem effs) => Sem effs Html) -> Sem effs Html
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Error PandocError, Pandoc] r =>
(PandocMonad (Sem r) => Sem r a) -> Sem r a
PM.absorbPandocMonad ((PandocMonad (Sem effs) => Sem effs Html) -> Sem effs Html)
-> (PandocMonad (Sem effs) => Sem effs Html) -> Sem effs Html
forall a b. (a -> b) -> a -> b
$ do
WriterOptions
writerOptions <- Maybe FilePath -> Map FilePath FilePath -> Sem effs WriterOptions
forall (m :: * -> *).
(PandocMonad m, TemplateMonad m) =>
Maybe FilePath -> Map FilePath FilePath -> m WriterOptions
htmlFullDocWriterOptions (PandocWriterConfig -> Maybe FilePath
templateFP PandocWriterConfig
writeConfig)
(PandocWriterConfig -> Map FilePath FilePath
templateVars PandocWriterConfig
writeConfig)
PandocWriteFormat Html
-> WriterOptions -> PandocWithRequirements -> Sem effs Html
forall (m :: * -> *) a.
PandocMonad m =>
PandocWriteFormat a
-> WriterOptions -> PandocWithRequirements -> m a
PE.fromPandoc PandocWriteFormat Html
PE.WriteHtml5 (PandocWriterConfig -> WriterOptionsF
optionsF PandocWriterConfig
writeConfig WriterOptions
writerOptions) PandocWithRequirements
pdocWR
#else
htmlFullDocWriterOptions
:: PA.PandocMonad m
=> Maybe FilePath
-> M.Map String String
-> m PA.WriterOptions
htmlFullDocWriterOptions pathM tVars = do
template <- case pathM of
Nothing -> PA.getDefaultTemplate "Html5"
Just fp -> do
exists <- PA.fileExists fp
if exists
then fmap BS.unpack (PA.readFileStrict fp)
else
PA.logOutput
(PA.IgnoredIOError
(PM.textToPandocText $ "Couldn't find " <> (T.pack $ show fp))
)
>> PA.getDefaultTemplate "Html5"
return $ htmlWriterOptions { PA.writerTemplate = Just template
, PA.writerVariables = M.toList tVars
, PA.writerSetextHeaders = True
}
toBlazeDocument
:: PM.PandocEffects effs
=> KO.PandocWriterConfig
-> PE.PandocWithRequirements
-> P.Sem effs BH.Html
toBlazeDocument writeConfig pdocWR = PM.absorbPandocMonad $ do
writerOptions <- htmlFullDocWriterOptions (templateFP writeConfig)
(templateVars writeConfig)
PE.fromPandoc PE.WriteHtml5 (optionsF writeConfig writerOptions) pdocWR
#endif
markDownTextToBlazeFragment
:: PM.PandocEffects effs
=> T.Text
-> P.Sem effs BH.Html
markDownTextToBlazeFragment :: Text -> Sem effs Html
markDownTextToBlazeFragment =
PandocWriteFormat Html
-> WriterOptions -> Sem (ToPandoc : effs) () -> Sem effs Html
forall (effs :: [(* -> *) -> * -> *]) a.
PandocEffects effs =>
PandocWriteFormat a
-> WriterOptions -> Sem (ToPandoc : effs) () -> Sem effs a
PE.fromPandocE PandocWriteFormat Html
PE.WriteHtml5 WriterOptions
htmlWriterOptions
(Sem (ToPandoc : effs) () -> Sem effs Html)
-> (Text -> Sem (ToPandoc : effs) ()) -> Text -> Sem effs Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocReadFormat Text
-> ReaderOptions -> Text -> Sem (ToPandoc : effs) ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member ToPandoc effs =>
PandocReadFormat a -> ReaderOptions -> a -> Sem effs ()
PE.addFrom PandocReadFormat Text
PE.ReadMarkDown ReaderOptions
markDownReaderOptions
pandocWriterToBlazeDocument
:: PM.PandocEffects effs
=> KO.PandocWriterConfig
-> P.Sem (PE.ToPandoc ': effs) ()
-> P.Sem effs BH.Html
pandocWriterToBlazeDocument :: PandocWriterConfig -> Sem (ToPandoc : effs) () -> Sem effs Html
pandocWriterToBlazeDocument writeConfig :: PandocWriterConfig
writeConfig pw :: Sem (ToPandoc : effs) ()
pw =
Sem (ToPandoc : effs) () -> Sem effs PandocWithRequirements
forall (effs :: [(* -> *) -> * -> *]).
PandocEffects effs =>
Sem (ToPandoc : effs) () -> Sem effs PandocWithRequirements
PE.runPandocWriter Sem (ToPandoc : effs) ()
pw Sem effs PandocWithRequirements
-> (PandocWithRequirements -> Sem effs Html) -> Sem effs Html
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PandocWriterConfig -> PandocWithRequirements -> Sem effs Html
forall (effs :: [(* -> *) -> * -> *]).
PandocEffects effs =>
PandocWriterConfig -> PandocWithRequirements -> Sem effs Html
toBlazeDocument PandocWriterConfig
writeConfig
mindocOptionsF :: PA.WriterOptions -> PA.WriterOptions
mindocOptionsF :: WriterOptionsF
mindocOptionsF op :: WriterOptions
op = WriterOptions
op { writerSectionDivs :: Bool
PA.writerSectionDivs = Bool
True }
writeAllPandocResultsWithInfoAsHtml
:: T.Text -> [PE.DocWithInfo PE.PandocInfo TL.Text] -> IO ()
writeAllPandocResultsWithInfoAsHtml :: Text -> [DocWithInfo PandocInfo Text] -> IO ()
writeAllPandocResultsWithInfoAsHtml dir :: Text
dir =
Text -> Text -> [DocWithInfo PandocInfo Text] -> IO ()
KO.writeAllPandocResultsWithInfo Text
dir "html"
writePandocResultWithInfoAsHtml
:: T.Text -> PE.DocWithInfo PE.PandocInfo TL.Text -> IO ()
writePandocResultWithInfoAsHtml :: Text -> DocWithInfo PandocInfo Text -> IO ()
writePandocResultWithInfoAsHtml dir :: Text
dir dwi :: DocWithInfo PandocInfo Text
dwi =
Text -> Text -> DocWithInfo PandocInfo Text -> IO ()
KO.writePandocResultWithInfo Text
dir "html" DocWithInfo PandocInfo Text
dwi