65 lines
2.4 KiB
Haskell
65 lines
2.4 KiB
Haskell
module Polysemy.Commonmark where
|
|
|
|
import Relude
|
|
|
|
import Commonmark.Types (EnumeratorType(..), DelimiterType(..), ListType(..))
|
|
import Data.Text (pack)
|
|
import Polysemy (Members, Sem)
|
|
import Polysemy.Commonmark.AST
|
|
import Polysemy.Output (Output)
|
|
import Polysemy.Output.IO (putTextO, putTextLnO)
|
|
import Polysemy.Sgr (Sgr, SgrRegion, withSgr)
|
|
import System.Console.ANSI qualified as ANSI
|
|
|
|
printBlock :: Members [Output Text, Sgr, SgrRegion] r => Block -> Sem r ()
|
|
printBlock = printBlockP "" where
|
|
printBlockP prefix (Block b) = for_ b (printBlockOne prefix)
|
|
|
|
printBlockOne prefix (Paragraph i) = do
|
|
putTextO prefix
|
|
printInline i
|
|
putTextLnO ""
|
|
printBlockOne prefix (Plain i) = do
|
|
putTextO prefix
|
|
printInline i
|
|
printBlockOne prefix ThematicBreak = do
|
|
putTextO prefix
|
|
putTextLnO "---"
|
|
printBlockOne prefix (BlockQuote b) = printBlockP (prefix <> "> ") b
|
|
printBlockOne prefix (CodeBlock lang content) = do
|
|
putTextLnO $ prefix <> "```" <> lang
|
|
withSgr [ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black] do
|
|
for_ (lines content) $ putTextLnO . (prefix <>)
|
|
putTextLnO $ prefix <> "```"
|
|
printBlockOne prefix (Heading lvl i) = do
|
|
withSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] do
|
|
putTextO $ prefix <> pack (replicate lvl '#')
|
|
putTextO $ prefix <> " "
|
|
printInline i
|
|
printBlockOne prefix (List type_ spacing blocks) =
|
|
for_ (zip (listPrefixes type_) blocks) \(listPrefix, block) -> do
|
|
printBlockP (prefix <> listPrefix) block
|
|
printBlockOne prefix x = error $ "printBlockOne: " <> show x
|
|
|
|
listPrefixes :: ListType -> [Text]
|
|
listPrefixes (BulletList c) = repeat (pack [c, ' '])
|
|
listPrefixes (OrderedList start enumType delimType) =
|
|
[start..] <&> \i -> enumFor i <> delim <> " "
|
|
where
|
|
infAlph list = list ++ ((<>) <$> infAlph list <*> list)
|
|
enumFor i = case enumType of
|
|
UpperAlpha -> infAlph (pack . one <$> ['A'..'Z']) !!? i & fromMaybe (error "Impossible")
|
|
LowerAlpha -> infAlph (pack . one <$> ['a'..'z']) !!? i & fromMaybe (error "Impossible")
|
|
_ -> show i
|
|
delim = case delimType of
|
|
Period -> "."
|
|
OneParen -> ")"
|
|
TwoParens -> "))"
|
|
|
|
-- TODO: needs to be aware of prefix and line length
|
|
-- and perform line wrapping
|
|
printInline :: Members [Output Text, Sgr, SgrRegion] r => Inline -> Sem r ()
|
|
printInline (Inline i) = for_ i printInlinePiece where
|
|
printInlinePiece (Str t) = putTextO t
|
|
printInlinePiece (WithSgr es i) = withSgr es (printInline i)
|