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

Coloring for usernames

main
staticvoid 2022-06-26 16:46:59 +03:00
parent 3b38f1f2d3
commit baa5139e01
7 changed files with 53 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
4r.cabal
View File

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

14
app/Api/Types.hs
View File

@ -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>" message of
Right block -> printColor block
Left err -> withSgr [SetColor Foreground Vivid Red] do

2
app/PrintColor.hs → app/Color/Print.hs
View File

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

11
app/Color/Utils.hs 100644
View File

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

2
app/Main.hs
View File

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

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

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

1
flake.nix
View File

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