{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Readme.Lhs
( para,
plain,
inline,
table,
table',
code,
link,
linkTooltip,
badge,
image,
Flavour (..),
readPandoc,
renderMarkdown,
renderHtml,
Output (..),
OutputMap,
output,
insertOutput,
runOutput,
tweakHaskellCodeBlock,
Block (..),
module Text.Pandoc.Definition,
Alignment (..),
)
where
import Control.Monad.IO.Class
import qualified Data.Map as Map
import Data.Text as Text
import qualified Data.Text.IO as Text
import Text.Pandoc
import Text.Pandoc.Definition
import Protolude hiding (link)
import qualified Text.Blaze.Html.Renderer.Text as Blaze
data Output = Native [Block] | Replace Text | Fence Text
type OutputMap = Map Text Output
para :: Text -> Block
para = Para . fmap (Str) . Text.lines
plain :: Text -> Block
plain = Plain . fmap (Str) . Text.lines
inline :: Text -> [Inline]
inline = fmap (Str) . Text.lines
link :: Text -> Text -> Inline
link name url = Link ("", [], []) [Str (name)] (url, "")
linkTooltip :: Text -> Text -> Text -> Inline
linkTooltip name url tooltip = Link ("", [], []) [Str (name)] (url, tooltip)
image :: Text -> Text -> Inline
image name url = Image ("", [], []) [Str (name)] (url, "")
badge :: Text -> Text -> Text -> Inline
badge label badge' url = Link ("", [], []) [Image ("", [], []) [Str (label)] (badge', "")] (url, "")
table :: Text -> [Text] -> [Alignment] -> [Int] -> [[Text]] -> Block
table caption hs as ws rs =
Table
(inline caption)
as
(fromIntegral <$> ws)
((: []) . para <$> hs)
(fmap ((: []) . para) <$> rs)
table' :: Text -> [Inline] -> [Alignment] -> [Int] -> [[Inline]] -> Block
table' caption hs as ws rs =
Table
(inline caption)
as
(fromIntegral <$> ws)
((: []) . Para . (: []) <$> hs)
(fmap ((: []) . Para . (: [])) <$> rs)
code :: Text -> [Text] -> Text -> Block
code name classes =
CodeBlock (name, classes, [])
data Flavour = GitHubMarkdown | LHS | Html
exts :: Flavour -> Extensions
exts LHS = enableExtension Ext_literate_haskell $ getDefaultExtensions "markdown"
exts GitHubMarkdown =
enableExtension
Ext_fenced_code_attributes
githubMarkdownExtensions
exts Html = getDefaultExtensions "html"
tweakHaskellCodeBlock :: Block -> Block
tweakHaskellCodeBlock (CodeBlock (id', cs, kv) b) =
CodeBlock (id', bool cs ["haskell"] ("haskell" `elem` cs), kv) b
tweakHaskellCodeBlock x = x
readPandoc :: FilePath -> Flavour -> IO (Either PandocError Pandoc)
readPandoc fp f = do
t <- liftIO $ readFile fp
runIO $ readMarkdown (def :: ReaderOptions) {readerExtensions = exts f} t
renderMarkdown :: Flavour -> Pandoc -> Either PandocError Text
renderMarkdown f (Pandoc meta bs) =
runPure $
writeMarkdown
(def :: WriterOptions) {writerExtensions = exts f}
(Pandoc meta (tweakHaskellCodeBlock <$> bs))
renderHtml :: Flavour -> Pandoc -> Either PandocError Text
renderHtml f (Pandoc meta bs) =
runPure $ do
h <- writeHtml5
(def :: WriterOptions) {writerExtensions = exts f}
(Pandoc meta (tweakHaskellCodeBlock <$> bs))
pure $ toStrict $ Blaze.renderHtml h
insertOutput :: OutputMap -> Block -> [Block]
insertOutput m b = case b of
b'@(CodeBlock (id', classes, kv) _) ->
bool
[b']
( maybe
[CodeBlock (id', classes, kv) mempty]
( \x ->
maybe
[CodeBlock (id', classes, kv) mempty]
( \case
Fence t -> [CodeBlock (id', classes, kv) t]
Replace t -> [plain t]
Native bs -> bs
)
(Map.lookup x m)
)
(headMay . Protolude.filter ((`elem` classes)) . Map.keys $ m)
)
("output" `elem` classes)
b' -> [b']
insertOutputs :: OutputMap -> Pandoc -> Pandoc
insertOutputs out (Pandoc meta bs) =
Pandoc meta (mconcat $ insertOutput out <$> bs)
output :: (Monad m) => Text -> Output -> StateT OutputMap m ()
output k v = modify (Map.insert k v)
runOutput ::
(FilePath, Flavour) ->
(FilePath, Flavour) ->
StateT OutputMap IO () ->
IO (Either PandocError ())
runOutput (fi, flavi) (fo, flavo) out = do
m <- execStateT out Map.empty
p <- readPandoc fi flavi
let w = do
p' <- insertOutputs m <$> p
case flavo of
Html -> renderHtml flavo p'
_ -> renderMarkdown flavo p'
either (pure . Left) (\t -> Text.writeFile fo t >> pure (Right ())) w