From 0c36f490719f613dc23b6632a4098bd17fb0ab7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 31 Jan 2026 17:48:55 +0100 Subject: Data structure for formatted text --- erebos.cabal | 3 +++ main/Main.hs | 7 ++--- src/Erebos/Conversation.hs | 21 ++++++++++----- src/Erebos/TextFormat.hs | 16 ++++++++++++ src/Erebos/TextFormat/Ansi.hs | 59 ++++++++++++++++++++++++++++++++++++++++++ src/Erebos/TextFormat/Types.hs | 57 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 153 insertions(+), 10 deletions(-) create mode 100644 src/Erebos/TextFormat.hs create mode 100644 src/Erebos/TextFormat/Ansi.hs create mode 100644 src/Erebos/TextFormat/Types.hs diff --git a/erebos.cabal b/erebos.cabal index 9229768..f384598 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -124,6 +124,8 @@ library Erebos.Storage.Key Erebos.Storage.Merge Erebos.Sync + Erebos.TextFormat + Erebos.TextFormat.Ansi other-modules: Erebos.Conversation.Class @@ -136,6 +138,7 @@ library Erebos.Storage.Internal Erebos.Storage.Memory Erebos.Storage.Platform + Erebos.TextFormat.Types Erebos.UUID Erebos.Util diff --git a/main/Main.hs b/main/Main.hs index 0493e58..2d11dba 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -54,6 +54,7 @@ import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import Erebos.TextFormat.Ansi import State import Terminal @@ -746,7 +747,7 @@ cmdSelectContext = do flip catchError (\_ -> return ()) $ do conv <- getConversationFromContext ctx tzone <- liftIO $ getCurrentTimeZone - mapM_ (cmdPutStrLn . formatMessage tzone) $ takeWhile messageUnread $ conversationHistory conv + mapM_ (cmdPutStrLn . T.unpack . fromAnsiText . renderAnsiText . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv cmdSend :: Command cmdSend = void $ do @@ -765,7 +766,7 @@ cmdHistory = void $ do case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . T.unpack . fromAnsiText . renderAnsiText . formatMessageFT tzone) $ reverse $ take 50 thread [] -> do cmdPutStrLn $ "" @@ -1010,7 +1011,7 @@ cmdNew = do set WatchConversations $ map (SelectedConversation . fst) conversations tzone <- liftIO $ getCurrentTimeZone forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do - cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) ++ " " ++ formatMessage tzone msg + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) ++ " " ++ T.unpack (fromAnsiText $ renderAnsiText $ formatMessageFT tzone msg) where checkNew conv | (msg : _) <- conversationHistory conv diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 2c6f967..a48daf7 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Erebos.Conversation ( Message, messageFrom, @@ -5,6 +7,7 @@ module Erebos.Conversation ( messageText, messageUnread, formatMessage, + formatMessageFT, Conversation, isSameConversation, @@ -38,6 +41,8 @@ import Erebos.DirectMessage import Erebos.Identity import Erebos.State import Erebos.Storable +import Erebos.TextFormat +import Erebos.TextFormat.Types data Message = forall conv msg. ConversationType conv msg => Message msg Bool @@ -58,13 +63,15 @@ messageUnread :: Message -> Bool messageUnread (Message _ unread) = unread formatMessage :: TimeZone -> Message -> String -formatMessage tzone msg = concat - [ if messageUnread msg then "\ESC[93m" else "" - , formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg - , maybe "" T.unpack $ idName $ messageFrom msg - , maybe "" ((": "<>) . T.unpack) $ messageText msg - , if messageUnread msg then "\ESC[0m" else "" - ] +formatMessage tzone = T.unpack . renderPlainText . formatMessageFT tzone + +formatMessageFT :: TimeZone -> Message -> FormattedText +formatMessageFT tzone msg = + (if messageUnread msg then FormattedText (CustomTextColor (Just BrightYellow) Nothing) else id) $ mconcat + [ PlainText $ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg + , maybe "" PlainText $ idName $ messageFrom msg + , maybe "" ((": " <>) . PlainText) $ messageText msg + ] data Conversation diff --git a/src/Erebos/TextFormat.hs b/src/Erebos/TextFormat.hs new file mode 100644 index 0000000..0bfad75 --- /dev/null +++ b/src/Erebos/TextFormat.hs @@ -0,0 +1,16 @@ +module Erebos.TextFormat ( + FormattedText, + + renderPlainText, +) where + +import Data.Text (Text) + +import Erebos.TextFormat.Types + + +renderPlainText :: FormattedText -> Text +renderPlainText = \case + PlainText text -> text + ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts + FormattedText _ ftext -> renderPlainText ftext diff --git a/src/Erebos/TextFormat/Ansi.hs b/src/Erebos/TextFormat/Ansi.hs new file mode 100644 index 0000000..504e098 --- /dev/null +++ b/src/Erebos/TextFormat/Ansi.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Erebos.TextFormat.Ansi ( + FormattedText, + + AnsiText(..), + renderAnsiText, +) where + +import Control.Applicative + +import Data.Text (Text) +import Data.Text qualified as T + +import Erebos.TextFormat.Types + + +newtype AnsiText = AnsiText { fromAnsiText :: Text } + +renderAnsiText :: FormattedText -> AnsiText +renderAnsiText = AnsiText . go ( Nothing, Nothing ) + where + go cur@( cfg, cbg ) = \case + PlainText text -> text + ConcatenatedText ftexts -> mconcat $ map (go cur) ftexts + FormattedText (CustomTextColor fg bg) ftext -> mconcat + [ ansiColor fg bg + , go ( fg <|> cfg, bg <|> cbg ) ftext + , ansiColor + (if fg /= cfg then cfg <|> Just DefaultColor else Nothing) + (if bg /= cbg then cbg <|> Just DefaultColor else Nothing) + ] + + +ansiColor :: Maybe Color -> Maybe Color -> Text +ansiColor Nothing Nothing = "" +ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m" +ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m" +ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m" + +colorNum :: Color -> Int +colorNum = \case + DefaultColor -> 39 + Black -> 30 + Red -> 31 + Green -> 32 + Yellow -> 33 + Blue -> 34 + Magenta -> 35 + Cyan -> 36 + White -> 37 + BrightBlack -> 90 + BrightRed -> 91 + BrightGreen -> 92 + BrightYellow -> 93 + BrightBlue -> 94 + BrightMagenta -> 95 + BrightCyan -> 96 + BrightWhite -> 97 diff --git a/src/Erebos/TextFormat/Types.hs b/src/Erebos/TextFormat/Types.hs new file mode 100644 index 0000000..a03bc71 --- /dev/null +++ b/src/Erebos/TextFormat/Types.hs @@ -0,0 +1,57 @@ +module Erebos.TextFormat.Types ( + FormattedText(..), + TextStyle(..), + Color(..), +) where + +import Data.String +import Data.Text (Text) + + +data FormattedText + = PlainText Text + | ConcatenatedText [ FormattedText ] + | FormattedText TextStyle FormattedText + +instance IsString FormattedText where + fromString = PlainText . fromString + +instance Semigroup FormattedText where + ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys) + x <> ConcatenatedText ys = ConcatenatedText (x : ys) + ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ]) + x <> y = ConcatenatedText [ x, y ] + +instance Monoid FormattedText where + mempty = ConcatenatedText [] + mconcat [] = ConcatenatedText [] + mconcat [ x ] = x + mconcat xs = ConcatenatedText $ concatMap flatten xs + where + flatten (ConcatenatedText ys) = ys + flatten y = [ y ] + + +data TextStyle + = CustomTextColor (Maybe Color) (Maybe Color) + + +data Color + = DefaultColor + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + deriving (Eq) -- cgit v1.2.3