diff --git a/4r.cabal b/4r.cabal index 8918751..2af19fb 100644 --- a/4r.cabal +++ b/4r.cabal @@ -51,10 +51,10 @@ executable 4r Api.Types Cli Polysemy.Commonmark.AST - Polysemy.Commonmark.AST.PrintColor Polysemy.Output.IO Polysemy.Sgr - PrintColor + Color.Print + Color.Utils hs-source-dirs: app build-depends: , aeson @@ -62,6 +62,7 @@ executable 4r , base , commonmark , commonmark-extensions + , cryptohash-sha512 , deepseq , http-api-data , http-client diff --git a/app/Api/Types.hs b/app/Api/Types.hs index c52f159..d4649a9 100644 --- a/app/Api/Types.hs +++ b/app/Api/Types.hs @@ -18,9 +18,10 @@ import Data.HashMap.Strict qualified as M import Polysemy.Commonmark.AST (Block, Inline) import Polysemy.Output.IO import Polysemy.Sgr -import PrintColor +import Color.Print import System.Console.ANSI import Web.FormUrlEncoded (Form(Form), ToForm(toForm)) +import Color.Utils data GetSections = GetSections instance ToForm GetSections where @@ -79,11 +80,14 @@ instance NFData ThreadPost instance FromJSON ThreadPost instance PrintColor ThreadPost where - printColor ThreadPost{name, date, message} = do - withSgr [SetColor Foreground Vivid Red] do - putTextO $ name <> " " + printColor ThreadPost{id = post_id, name, date, message} = do + withSgr [ SetPaletteColor Foreground (textColor name) + , SetConsoleIntensity BoldIntensity + -- , SetSwapForegroundBackground True + ] do + putTextO name withSgr [SetColor Foreground Dull White] do - putTextLnO date + putTextLnO $ " " <> date <> " #" <> show post_id case commonmark @Inline @Block "" message of Right block -> printColor block Left err -> withSgr [SetColor Foreground Vivid Red] do diff --git a/app/PrintColor.hs b/app/Color/Print.hs similarity index 83% rename from app/PrintColor.hs rename to app/Color/Print.hs index 8226cc5..52b1a2d 100644 --- a/app/PrintColor.hs +++ b/app/Color/Print.hs @@ -1,4 +1,4 @@ -module PrintColor (PrintColor(..)) where +module Color.Print (PrintColor(..)) where import Relude diff --git a/app/Color/Utils.hs b/app/Color/Utils.hs new file mode 100644 index 0000000..5774c69 --- /dev/null +++ b/app/Color/Utils.hs @@ -0,0 +1,11 @@ +module Color.Utils (textColor) where + +import Relude + +import Crypto.Hash.SHA512 +import Data.ByteString qualified as B + +-- | Returns number < 216 +textColor :: Text -> Word8 +textColor t = let result = B.head . finalize . start $ encodeUtf8 t + in result `mod` 216 diff --git a/app/Main.hs b/app/Main.hs index b4482d3..18d338d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,7 +12,7 @@ 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 +import Color.Print import Servant.Client import Servant.Polysemy.Client (ServantClient, runServantClientWith) import System.Console.ANSI diff --git a/app/Polysemy/Commonmark/AST.hs b/app/Polysemy/Commonmark/AST.hs index 35ad8f4..671928b 100644 --- a/app/Polysemy/Commonmark/AST.hs +++ b/app/Polysemy/Commonmark/AST.hs @@ -1,16 +1,21 @@ +{-# LANGUAGE Strict #-} + module Polysemy.Commonmark.AST (Inline, Block) where import Relude 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 PrintColor +import Color.Print import System.Console.ANSI qualified as ANSI +import Color.Utils -- TODO: add strikethrough and spoilers data InlinePiece = Str Text @@ -50,25 +55,6 @@ instance HasAttributes Inline where instance IsInline Inline where 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 @@ -117,7 +103,25 @@ 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 (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 @@ -158,9 +162,11 @@ instance PrintColor Block where 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] diff --git a/flake.nix b/flake.nix index d4e12ab..5b57ef7 100644 --- a/flake.nix +++ b/flake.nix @@ -49,6 +49,7 @@ base commonmark commonmark-extensions + cryptohash-sha512 http-api-data http-client optparse-applicative