Coloring for usernames

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

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
+  printColor ThreadPost{id = post_id, name, date, message} = do
-    withSgr [SetColor Foreground Vivid Red] do
+    withSgr [ SetPaletteColor Foreground (textColor name)
-      putTextO $ 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>" message of
       Right block -> printColor block
       Left err -> withSgr [SetColor Foreground Vivid Red] do

app/Color/Print.hs

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

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

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

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]

flake.nix

@@ -49,6 +49,7 @@
                 base
                 commonmark
                 commonmark-extensions
+                cryptohash-sha512
                 http-api-data
                 http-client
                 optparse-applicative