Data structure for formatted text

6 files changed, 153 insertions, 10 deletions

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 $ "<empty history>"
 
@@ -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 "<unnamed>" 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 "<unnamed>" 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)