210 lines
7.9 KiB
Haskell
210 lines
7.9 KiB
Haskell
{-# LANGUAGE Strict #-}
|
|
|
|
module Polysemy.Commonmark.AST (Inline, Block, commonmark) where
|
|
|
|
import Relude
|
|
|
|
import Commonmark (commonmarkWith)
|
|
import Commonmark.Extensions.Strikethrough
|
|
import Commonmark.Parser (ParseError)
|
|
import Commonmark.Syntax (defaultSyntaxSpec)
|
|
import Commonmark.Types
|
|
import Data.Char qualified as C
|
|
import Data.Sequence ( Seq ((:<|), Empty)
|
|
, ViewL ((:<)), ViewR ((:>))
|
|
, viewl, viewr
|
|
)
|
|
import Data.Text qualified as T
|
|
import Polysemy.Output.IO (putTextO, putTextLnO)
|
|
import Polysemy.Sgr (withSgr)
|
|
import Color.Print
|
|
import System.Console.ANSI qualified as ANSI
|
|
import Color.Utils
|
|
|
|
commonmark :: String -> Text -> Either ParseError Block
|
|
commonmark filename source =
|
|
runIdentity $ commonmarkWith @Identity @Inline @Block (defaultSyntaxSpec <> strikethroughSpec)
|
|
filename
|
|
source
|
|
|
|
-- TODO: add spoilers
|
|
data InlinePiece = Str Text
|
|
| Emph Inline
|
|
| Strong Inline
|
|
| Underline Inline
|
|
| Strikethrough Inline
|
|
-- | Autolink { dest :: Text }
|
|
| Link { dest, title :: Text
|
|
, descr :: Inline
|
|
}
|
|
| Code Text
|
|
deriving stock (Show)
|
|
|
|
newtype Inline = Inline (Seq InlinePiece)
|
|
deriving newtype (IsList, Show)
|
|
|
|
mapText :: (Text -> Text) -> Inline -> Inline
|
|
mapText f (Inline pieces) = Inline (mapText' <$> pieces) where
|
|
mapText' (Str t) = Str (f t)
|
|
mapText' (Emph i) = Emph (mapText f i)
|
|
mapText' (Strong i) = Strong (mapText f i)
|
|
mapText' (Underline i) = Underline (mapText f i)
|
|
mapText' (Strikethrough i) = Strikethrough (mapText f i)
|
|
mapText' Link{dest, title, descr} = Link { dest, title, descr = mapText f descr }
|
|
mapText' (Code t) = Code t
|
|
|
|
instance Semigroup Inline where
|
|
Inline as <> Inline bs =
|
|
case (viewr as, viewl bs) of
|
|
(as' :> Str a, Str b :< bs') -> Inline as' <> Inline (Str (a <> b) :<| bs')
|
|
(as' :> Emph a, Emph b :< bs') -> Inline as' <> Inline (Emph (a <> b) :<| bs')
|
|
(as' :> Strong a, Strong b :< bs') -> Inline as' <> Inline (Strong (a <> b) :<| bs')
|
|
(as' :> Underline a, Underline b :< bs') -> Inline as' <> Inline (Underline (a <> b) :<| bs')
|
|
(as' :> Code a, Code b :< bs') -> Inline as' <> Inline (Code (a <> b) :<| bs')
|
|
_ -> Inline (as <> bs)
|
|
|
|
instance Monoid Inline where
|
|
mempty = Inline Empty
|
|
|
|
instance Rangeable Inline where
|
|
ranged = const id
|
|
|
|
instance HasAttributes Inline where
|
|
addAttributes = const id
|
|
|
|
instance IsInline Inline where
|
|
str = Inline . one . Str
|
|
lineBreak = str "\n"
|
|
softBreak = str " "
|
|
entity = str
|
|
escapedChar c = str $ "\\" <> one c
|
|
emph = Inline . one . Emph
|
|
strong = Inline . one . Strong
|
|
link dest _title descr =
|
|
descr <> fromList [ Str " ("
|
|
, Underline (str dest)
|
|
, Str ")"]
|
|
image = link
|
|
code c = Inline . one $ Code $ "`" <> c <> "`"
|
|
rawInline _ = code
|
|
|
|
data BlockPiece = Paragraph Inline
|
|
| Plain Inline
|
|
| ThematicBreak
|
|
| BlockQuote Block
|
|
| CodeBlock Text Text
|
|
| Heading Int Inline
|
|
| ReferenceLinkDefinition { label :: Text, dest :: Text, title :: Text }
|
|
| List ListType ListSpacing [Block]
|
|
deriving stock (Show)
|
|
|
|
newtype Block = Block [BlockPiece]
|
|
deriving newtype (Show, Semigroup, Monoid)
|
|
|
|
instance Rangeable Block where
|
|
ranged = const id
|
|
|
|
instance HasAttributes Block where
|
|
addAttributes = const id
|
|
|
|
instance IsBlock Inline Block where
|
|
paragraph = Block . one . Paragraph
|
|
plain = Block . one . Plain
|
|
thematicBreak = Block [ThematicBreak]
|
|
blockQuote = Block . one . BlockQuote
|
|
codeBlock lang = Block . one . CodeBlock lang
|
|
heading lvl = Block . one . Heading lvl
|
|
rawBlock (Format t) = codeBlock t
|
|
referenceLinkDefinition label (dest, title) = Block [ReferenceLinkDefinition label dest title]
|
|
list type_ spacing = Block . one . List type_ spacing
|
|
|
|
instance PrintColor Inline where
|
|
-- TODO: needs to be aware of prefix and line length
|
|
-- and perform line wrapping
|
|
printColor (Inline pieces) = for_ pieces printPiece where
|
|
printPiece (Str t) = case t of
|
|
"" -> pass
|
|
"@" -> putTextO t
|
|
_ ->
|
|
let (beforeUsername, withUsername) = (/= '@') `T.span` t
|
|
~isNotPartOfWord = T.null beforeUsername || C.isSpace (T.last beforeUsername)
|
|
~(username, rest) = T.span isUsernameSym (T.tail withUsername)
|
|
in if not (T.null withUsername) && isNotPartOfWord
|
|
then do
|
|
putTextO beforeUsername
|
|
withSgr [ ANSI.SetPaletteColor ANSI.Foreground (textColor username)
|
|
-- , ANSI.SetSwapForegroundBackground True
|
|
, ANSI.SetConsoleIntensity ANSI.BoldIntensity
|
|
] do
|
|
putTextO $ "@" <> username
|
|
printPiece (Str rest)
|
|
else putTextO t
|
|
where
|
|
isUsernameSym c = C.isAlphaNum c || elem c ['_', '-']
|
|
printPiece (Emph i) = withSgr [ANSI.SetItalicized True] $ printColor i
|
|
printPiece (Strong i) = withSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] $ printColor i
|
|
printPiece (Underline i) = withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] $ printColor i
|
|
printPiece (Strikethrough i) = printColor (mapText mkStrikethrough i)
|
|
where
|
|
mkStrikethrough :: (IsString s, ToString s) => s -> s
|
|
mkStrikethrough s = fromString do { c <- toString s; [c, chr 822] }
|
|
printPiece Link{dest, descr} = do
|
|
printColor descr
|
|
withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] do
|
|
putTextO $ " (" <> dest <> ")"
|
|
printPiece (Code t) =
|
|
withSgr [ ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black
|
|
, ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White
|
|
] do
|
|
putTextO t
|
|
|
|
instance HasStrikethrough Inline where
|
|
strikethrough = Inline . one . Strikethrough
|
|
|
|
instance PrintColor Block where
|
|
printColor = printBlockP "" where
|
|
printBlockP prefix (Block b) = for_ b (printBlockOne prefix)
|
|
|
|
printBlockOne prefix (Paragraph i) = do
|
|
putTextO prefix
|
|
printColor i
|
|
putTextLnO ""
|
|
printBlockOne prefix (Plain i) = do
|
|
putTextO prefix
|
|
printColor 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 <> fromString (replicate lvl '#')
|
|
putTextO $ prefix <> " "
|
|
printColor i
|
|
putTextLnO ""
|
|
printBlockOne prefix (List type_ _spacing blocks) =
|
|
for_ (zip (listPrefixes type_) blocks) \(listPrefix, block) -> do
|
|
printBlockP (prefix <> listPrefix) block
|
|
putTextLnO ""
|
|
printBlockOne _prefix x = error $ "printBlockOne: " <> show x
|
|
|
|
listPrefixes :: ListType -> [Text]
|
|
listPrefixes (BulletList c) = repeat (fromString [c, ' '])
|
|
listPrefixes (OrderedList start enumType delimType) =
|
|
[start..] <&> \i -> enumFor i <> delim <> " "
|
|
where
|
|
infAlph xs = xs ++ ((<>) <$> infAlph xs <*> xs)
|
|
enumFor i = case enumType of
|
|
UpperAlpha -> infAlph (fromString . one <$> ['A'..'Z']) !!? i & fromMaybe (error "Impossible")
|
|
LowerAlpha -> infAlph (fromString . one <$> ['a'..'z']) !!? i & fromMaybe (error "Impossible")
|
|
_ -> show i
|
|
delim = case delimType of
|
|
Period -> "."
|
|
OneParen -> ")"
|
|
TwoParens -> "))"
|