From 3b38f1f2d3b1d0bfe2395106f8ee5c271f892e4b Mon Sep 17 00:00:00 2001 From: staticvoid Date: Sun, 26 Jun 2022 15:37:28 +0300 Subject: [PATCH] Move coloring to PrintColor instances Fix warnings --- 4r.cabal | 2 +- app/Api.hs | 2 +- app/Api/Spec.hs | 3 +- app/Api/Types.hs | 19 ++-- app/Cli.hs | 8 +- app/Main.hs | 12 ++- app/Polysemy/Commonmark.hs | 64 ------------- app/Polysemy/Commonmark/AST.hs | 158 ++++++++++++++++++++++++--------- app/Polysemy/Output/IO.hs | 7 +- app/Polysemy/Sgr.hs | 6 +- app/PrintColor.hs | 2 +- 11 files changed, 154 insertions(+), 129 deletions(-) delete mode 100644 app/Polysemy/Commonmark.hs diff --git a/4r.cabal b/4r.cabal index 7679663..8918751 100644 --- a/4r.cabal +++ b/4r.cabal @@ -50,8 +50,8 @@ executable 4r Api.Spec Api.Types Cli - Polysemy.Commonmark Polysemy.Commonmark.AST + Polysemy.Commonmark.AST.PrintColor Polysemy.Output.IO Polysemy.Sgr PrintColor diff --git a/app/Api.hs b/app/Api.hs index daa7bbf..60be5bc 100644 --- a/app/Api.hs +++ b/app/Api.hs @@ -1,4 +1,4 @@ -module Api where +module Api (getSections, getTopics, getTopic) where import Relude diff --git a/app/Api/Spec.hs b/app/Api/Spec.hs index 71d8dcf..37e0874 100644 --- a/app/Api/Spec.hs +++ b/app/Api/Spec.hs @@ -1,7 +1,6 @@ -module Api.Spec where +module Api.Spec (Api) where import Servant.API -import Servant.Client hiding (Request, Response) import Api.Types diff --git a/app/Api/Types.hs b/app/Api/Types.hs index 73d61e9..c52f159 100644 --- a/app/Api/Types.hs +++ b/app/Api/Types.hs @@ -1,14 +1,21 @@ {-# LANGUAGE Strict #-} -module Api.Types where +module Api.Types ( GetSections(GetSections) + , Section(..) + , GetTopics(GetTopics) + , TopicInfo(..) + , GetTopic(..) + , Topic(..) + , ThreadHead(..) + , ThreadPost(..) + ) where import Relude import Commonmark (commonmark) -import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), genericParseJSON, defaultOptions, withObject) +import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), withObject) import Data.HashMap.Strict qualified as M -import Polysemy.Commonmark (printBlock) +import Polysemy.Commonmark.AST (Block, Inline) import Polysemy.Output.IO import Polysemy.Sgr import PrintColor @@ -77,8 +84,8 @@ instance PrintColor ThreadPost where putTextO $ name <> " " withSgr [SetColor Foreground Dull White] do putTextLnO date - case commonmark "" message of - Right block -> printBlock block + case commonmark @Inline @Block "" message of + Right block -> printColor block Left err -> withSgr [SetColor Foreground Vivid Red] do putTextLnO $ "Error parsing commonmark: " <> show err putTextLnO message diff --git a/app/Cli.hs b/app/Cli.hs index bc83195..5fc80bb 100644 --- a/app/Cli.hs +++ b/app/Cli.hs @@ -1,6 +1,12 @@ {-# LANGUAGE Strict #-} -module Cli where +module Cli ( Options(..) + , Choice(..) + , optsParser + , choiceParser + , optsInfo + , getOpts + ) where import Relude import Prelude (foldl1) diff --git a/app/Main.hs b/app/Main.hs index 9d5dd7a..b4482d3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,15 +3,13 @@ module Main (main) where import Relude hiding (Proxy) import Api qualified as Api -import Api.Types qualified as Api import Cli -import Commonmark (commonmark) import Network.HTTP.Client -import Polysemy (Member, Members, Sem, runM) -import Polysemy.Embed (Embed, embed) +import Polysemy (Member, Members, Sem) +import Polysemy.Embed (Embed) import Polysemy.Error (Error, errorToIOFinal) -import Polysemy.Output (Output, output) -import Polysemy.Output.IO (runOutputToStdout, putTextO, putTextLnO) +import Polysemy.Output (Output) +import Polysemy.Output.IO (runOutputToStdout) import Polysemy.Sgr (Sgr, SgrRegion, ignoreSgrFull, runSgrFull, withSgr) import Polysemy.Final (Final, embedToFinal, runFinal) import PrintColor @@ -55,7 +53,7 @@ showTopic topic_id = do main :: IO () main = do - Options{offline, noAnsi, columns, choice} <- getOpts + Options{offline, noAnsi, choice} <- getOpts when offline do error "Offline mode is not yet implemented" manager' <- newManager $ diff --git a/app/Polysemy/Commonmark.hs b/app/Polysemy/Commonmark.hs deleted file mode 100644 index 63c2ee1..0000000 --- a/app/Polysemy/Commonmark.hs +++ /dev/null @@ -1,64 +0,0 @@ -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) diff --git a/app/Polysemy/Commonmark/AST.hs b/app/Polysemy/Commonmark/AST.hs index 8b9997c..35ad8f4 100644 --- a/app/Polysemy/Commonmark/AST.hs +++ b/app/Polysemy/Commonmark/AST.hs @@ -1,33 +1,39 @@ -module Polysemy.Commonmark.AST where +module Polysemy.Commonmark.AST (Inline, Block) where import Relude -import Prelude qualified as P import Commonmark.Types -import Data.Sequence ( Seq (Empty) +import Data.Sequence ( Seq ((:<|), Empty) , ViewL ((:<)), ViewR ((:>)) , viewl, viewr ) -import Data.Char qualified as C -import Data.Text (pack, unpack) -import Data.Text qualified as T -import Polysemy (Members, Sem) -import Polysemy.Output (Output) -import Polysemy.Sgr (Sgr) +import Polysemy.Output.IO (putTextO, putTextLnO) +import Polysemy.Sgr (withSgr) +import PrintColor import System.Console.ANSI qualified as ANSI --- TODO: should build proper AST and then color it +-- TODO: add strikethrough and spoilers data InlinePiece = Str Text - | WithSgr [ANSI.SGR] Inline + | Emph Inline + | Strong Inline + | Underline Inline + | Link { dest, title :: Text + , descr :: Inline + } + | Code Text deriving stock (Show) newtype Inline = Inline (Seq InlinePiece) - deriving newtype (Show) + deriving newtype (IsList, Show) instance Semigroup Inline where Inline as <> Inline bs = case (viewr as, viewl bs) of - (as' :> Str a, Str b :< bs') -> Inline as' <> str (a <> b) <> Inline bs' + (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 @@ -39,41 +45,42 @@ instance Rangeable Inline where instance HasAttributes Inline where addAttributes = const id -textToInline :: Text -> Inline -textToInline = Inline . one . Str - -mkStrikethrough s = do { c <- s; [c, chr 822] } +-- mkStrikethrough :: (IsString s, ToString s) => s -> s +-- mkStrikethrough s = fromString do { c <- toString s; [c, chr 822] } instance IsInline Inline where - str t = case t of - "" -> textToInline t - "@" -> textToInline 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 Inline $ fromList - [ Str beforeUsername - , WithSgr [ANSI.SetSwapForegroundBackground True] (textToInline $ "@" <> username) - , Str rest - ] - else textToInline t - where - isUsernameSym c = C.isAlphaNum c || elem c ['_', '-'] - lineBreak = textToInline "\n" - softBreak = textToInline " " - entity = textToInline - escapedChar c = textToInline $ "\\" <> one c - emph i = Inline $ one $ WithSgr [ANSI.SetItalicized True] i - strong i = Inline $ one $ WithSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] i - link dest _title (Inline descr) = Inline $ + str = Inline . one . Str + -- str t = case t of + -- "" -> textToInline t + -- "@" -> textToInline 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 Inline $ fromList + -- [ Str mempty + -- beforeUsername + -- , Str (one $ ANSI.SetSwapForegroundBackground True) + -- ("@" <> username) + -- , Str mempty + -- rest + -- ] + -- else textToInline t + -- where + -- isUsernameSym c = C.isAlphaNum c || elem c ['_', '-'] + lineBreak = str "\n" + softBreak = str " " + entity = str + escapedChar c = str $ "\\" <> one c + emph i = Inline . one $ Emph i + strong i = Inline . one $ Strong i + link dest _title descr = descr <> fromList [ Str " (" - , WithSgr [ANSI.SetUnderlining ANSI.SingleUnderline] (textToInline dest) + , Underline (str dest) , Str ")"] image = link - code c = Inline $ one $ WithSgr [ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black] - (textToInline $ "`" <> c <> "`") + code c = Inline . one $ Code $ "`" <> c <> "`" rawInline _ = code data BlockPiece = Paragraph Inline @@ -105,3 +112,68 @@ instance IsBlock Inline Block where 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) = putTextO t -- TODO: add @usernames highlighning + 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 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 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 + 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 (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 -> "))" diff --git a/app/Polysemy/Output/IO.hs b/app/Polysemy/Output/IO.hs index 919024c..6c0ef50 100644 --- a/app/Polysemy/Output/IO.hs +++ b/app/Polysemy/Output/IO.hs @@ -1,4 +1,7 @@ -module Polysemy.Output.IO where +module Polysemy.Output.IO ( runOutputToIO + , runOutputToStdout, runOutputToStderr + , putTextO, putTextLnO + ) where import Relude @@ -6,7 +9,7 @@ import Data.Text (unpack) import Polysemy (Member, Sem, interpret) import Polysemy.Embed (Embed, embed) import Polysemy.Output (Output(Output), output) -import System.IO (Handle, hPutStr, stdout, stderr) +import System.IO (hPutStr) runOutputToIO :: Member (Embed IO) r => Handle -> Sem (Output Text ': r) () -> Sem r () runOutputToIO h = interpret \(Output o) -> embed $ hPutStr h $ unpack o diff --git a/app/Polysemy/Sgr.hs b/app/Polysemy/Sgr.hs index 9096a86..f18a7a0 100644 --- a/app/Polysemy/Sgr.hs +++ b/app/Polysemy/Sgr.hs @@ -1,6 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -module Polysemy.Sgr where +module Polysemy.Sgr ( Sgr, sgr + , runSgrToOutput, ignoreSgr + , SgrRegion, withSgr + , SgrFull, runSgrFull, ignoreSgrFull + ) where import Relude hiding (Reader, ask, asks, local, runReader) diff --git a/app/PrintColor.hs b/app/PrintColor.hs index 242e365..8226cc5 100644 --- a/app/PrintColor.hs +++ b/app/PrintColor.hs @@ -1,4 +1,4 @@ -module PrintColor where +module PrintColor (PrintColor(..)) where import Relude