staticvoid
/
4r
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Move coloring to PrintColor instances 

Fix warnings
main
staticvoid 2022-06-26 15:37:28 +03:00
parent ac5f9e4989
commit 3b38f1f2d3
11 changed files with 154 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
4r.cabal
View File

@ -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

2
app/Api.hs
View File

@ -1,4 +1,4 @@
module Api where
module Api (getSections, getTopics, getTopic) where
import Relude

3
app/Api/Spec.hs
View File

@ -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

19
app/Api/Types.hs
View File

@ -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>" message of
Right block -> printBlock block
case commonmark @Inline @Block "<message>" message of
Right block -> printColor block
Left err -> withSgr [SetColor Foreground Vivid Red] do
putTextLnO $ "Error parsing commonmark: " <> show err
putTextLnO message

8
app/Cli.hs
View File

@ -1,6 +1,12 @@
{-# LANGUAGE Strict #-}
module Cli where
module Cli ( Options(..)
, Choice(..)
, optsParser
, choiceParser
, optsInfo
, getOpts
) where
import Relude
import Prelude (foldl1)

12
app/Main.hs
View File

@ -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 $

64
app/Polysemy/Commonmark.hs
View File

@ -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)

158
app/Polysemy/Commonmark/AST.hs
View File

@ -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 -> "))"

7
app/Polysemy/Output/IO.hs
View File

@ -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

6
app/Polysemy/Sgr.hs
View File

@ -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)

2
app/PrintColor.hs
View File

@ -1,4 +1,4 @@
module PrintColor where
module PrintColor (PrintColor(..)) where
import Relude