From ef0e3a97b51db987938728550d5158b1cbd4ee09 Mon Sep 17 00:00:00 2001 From: staticvoid Date: Sun, 26 Jun 2022 23:46:17 +0300 Subject: [PATCH] Print thread heads Implement strikethrough text --- app/Api/Types.hs | 17 ++++++++++---- app/Polysemy/Commonmark/AST.hs | 42 ++++++++++++++++++++++++++-------- 2 files changed, 45 insertions(+), 14 deletions(-) diff --git a/app/Api/Types.hs b/app/Api/Types.hs index d4649a9..1be76e9 100644 --- a/app/Api/Types.hs +++ b/app/Api/Types.hs @@ -12,10 +12,9 @@ module Api.Types ( GetSections(GetSections) import Relude -import Commonmark (commonmark) import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), withObject) import Data.HashMap.Strict qualified as M -import Polysemy.Commonmark.AST (Block, Inline) +import Polysemy.Commonmark.AST (commonmark) import Polysemy.Output.IO import Polysemy.Sgr import Color.Print @@ -60,8 +59,8 @@ instance NFData Topic instance FromJSON Topic instance PrintColor Topic where - -- TODO: print thread head! - printColor Topic{post} = sequenceA_ $ intersperse (putTextLnO "") (printColor <$> post) + printColor Topic{thread, post} = + sequenceA_ $ intersperse (putTextLnO "") (printColor <$> threadHeadToPost thread : post) data ThreadHead = ThreadHead { info :: TopicInfo , message :: Text @@ -72,6 +71,14 @@ instance FromJSON ThreadHead where parseJSON = withObject "ThreadHead" \o -> ThreadHead <$> parseJSON (Object o) <*> o .: "message" +threadHeadToPost :: ThreadHead -> ThreadPost +threadHeadToPost ThreadHead{info, message} = ThreadPost { id = info.id + , topic_id = info.id + , name = info.name + , date = info.date + , message + } + data ThreadPost = ThreadPost { id, topic_id :: Integer , name, date, message :: Text } @@ -88,7 +95,7 @@ instance PrintColor ThreadPost where putTextO name withSgr [SetColor Foreground Dull White] do putTextLnO $ " " <> date <> " #" <> show post_id - case commonmark @Inline @Block "" message of + case commonmark "" message of Right block -> printColor block Left err -> withSgr [SetColor Foreground Vivid Red] do putTextLnO $ "Error parsing commonmark: " <> show err diff --git a/app/Polysemy/Commonmark/AST.hs b/app/Polysemy/Commonmark/AST.hs index 671928b..fb314a8 100644 --- a/app/Polysemy/Commonmark/AST.hs +++ b/app/Polysemy/Commonmark/AST.hs @@ -1,9 +1,13 @@ {-# LANGUAGE Strict #-} -module Polysemy.Commonmark.AST (Inline, Block) where +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) @@ -17,11 +21,19 @@ import Color.Print import System.Console.ANSI qualified as ANSI import Color.Utils --- TODO: add strikethrough and spoilers +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 } @@ -31,6 +43,16 @@ data InlinePiece = Str Text 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 @@ -50,17 +72,14 @@ instance Rangeable Inline where instance HasAttributes Inline where addAttributes = const id --- mkStrikethrough :: (IsString s, ToString s) => s -> s --- mkStrikethrough s = fromString do { c <- toString s; [c, chr 822] } - instance IsInline Inline where str = Inline . one . Str lineBreak = str "\n" softBreak = str " " entity = str escapedChar c = str $ "\\" <> one c - emph i = Inline . one $ Emph i - strong i = Inline . one $ Strong i + emph = Inline . one . Emph + strong = Inline . one . Strong link dest _title descr = descr <> fromList [ Str " (" , Underline (str dest) @@ -125,8 +144,10 @@ instance PrintColor Inline where 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 Link{dest, descr = Inline (Str descr :<| Empty)} | dest == descr = - withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] $ putTextO dest + 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 @@ -137,6 +158,9 @@ instance PrintColor Inline where ] 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)