parent
baa5139e01
commit
ef0e3a97b5
|
|
@ -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>" message of
|
||||
case commonmark "<message>" message of
|
||||
Right block -> printColor block
|
||||
Left err -> withSgr [SetColor Foreground Vivid Red] do
|
||||
putTextLnO $ "Error parsing commonmark: " <> show err
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue