Markdown (#81)

* Markdown type

* Markdown parser (WIP)

* fix markdown parser

* style markdown in messages

* one-letter color abbreviations in markdown

ChatTerminal.hs

@@ -20,7 +20,9 @@ import Control.Monad
 import qualified Data.ByteString.Char8 as B
 import Data.List (dropWhileEnd)
 import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
 import Numeric.Natural
+import SimplexMarkdown
 import Styled
 import qualified System.Console.ANSI as C
 import System.IO
@@ -131,7 +133,7 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
         let s = inputString ts
         writeTBQueue inputQ s
         return s
-      withTermLock ct . printMessage ct $ highlightContact msg
+      withTermLock ct . printMessage ct $ styleMessage msg
 
     updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState
     updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of
@@ -181,11 +183,14 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
              in min (length s) $ p + length after - length afterWord
         ts' (s', p') = ts {inputString = s', inputPosition = p'}
 
-highlightContact :: String -> StyledString
-highlightContact = \case
+styleMessage :: String -> StyledString
+styleMessage = \case
   "" -> ""
-  s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> plain rest
-  s -> plain s
+  s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest
+  s -> markdown s
+  where
+    markdown :: String -> StyledString
+    markdown = styleMarkdown . parseMarkdown . T.pack
 
 updateInput :: ChatTerminal -> IO ()
 updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do

Main.hs

@@ -29,6 +29,7 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client (smpDefaultConfig)
 import Simplex.Messaging.Util (raceAny_)
+import SimplexMarkdown
 import Styled
 import System.Directory (getAppUserDataDirectory)
 import System.Exit (exitFailure)
@@ -106,7 +107,7 @@ serializeChatResponse name = \case
   where
     showName Nothing = "<your name>"
     showName (Just (Contact a)) = bPlain a
-    msgPlain = plain . T.unpack . decodeUtf8With onError
+    msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError
     onError _ _ = Just '?'
 
 chatHelpInfo :: StyledString

SimplexMarkdown.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SimplexMarkdown where
+
+import Control.Applicative ((<|>))
+import Data.Attoparsec.Text (Parser)
+import qualified Data.Attoparsec.Text as A
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Styled
+import System.Console.ANSI.Types
+
+data Markdown = Markdown Format Text | Markdown :|: Markdown
+  deriving (Show)
+
+data Format
+  = Bold
+  | Italic
+  | Underline
+  | StrikeThrough
+  | Colored Color
+  | NoFormat
+  deriving (Show)
+
+instance Semigroup Markdown where (<>) = (:|:)
+
+instance Monoid Markdown where mempty = unmarked ""
+
+instance IsString Markdown where fromString = unmarked . T.pack
+
+unmarked :: Text -> Markdown
+unmarked = Markdown NoFormat
+
+styleMarkdown :: Markdown -> StyledString
+styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
+styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s
+  where
+    sgr = case f of
+      Bold -> [SetConsoleIntensity BoldIntensity]
+      Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
+      Underline -> [SetUnderlining SingleUnderline]
+      StrikeThrough -> [SetSwapForegroundBackground True]
+      Colored c -> [SetColor Foreground Vivid c]
+      NoFormat -> []
+
+formats :: Map Char Format
+formats =
+  M.fromList
+    [ ('*', Bold),
+      ('_', Italic),
+      ('+', Underline),
+      ('~', StrikeThrough),
+      ('^', Colored White)
+    ]
+
+colors :: Map Text Color
+colors =
+  M.fromList
+    [ ("red", Red),
+      ("green", Green),
+      ("blue", Blue),
+      ("yellow", Yellow),
+      ("cyan", Cyan),
+      ("magenta", Magenta),
+      ("r", Red),
+      ("g", Green),
+      ("b", Blue),
+      ("y", Yellow),
+      ("c", Cyan),
+      ("m", Magenta)
+    ]
+
+parseMarkdown :: Text -> Markdown
+parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
+
+markdownP :: Parser Markdown
+markdownP = merge <$> A.many' fragmentP
+  where
+    merge :: [Markdown] -> Markdown
+    merge [] = ""
+    merge [f] = f
+    merge (f : fs) = foldl (:|:) f fs
+    fragmentP :: Parser Markdown
+    fragmentP =
+      A.anyChar >>= \case
+        ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ')
+        c -> case M.lookup c formats of
+          Just (Colored White) -> coloredP
+          Just f -> formattedP c "" f
+          Nothing -> unformattedP c
+    formattedP :: Char -> Text -> Format -> Parser Markdown
+    formattedP c p f = do
+      s <- A.takeTill (== c)
+      (A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s)
+    coloredP :: Parser Markdown
+    coloredP = do
+      color <- A.takeWhile (\c -> c /= ' ' && c /= '^')
+      case M.lookup color colors of
+        Just c ->
+          let f = Colored c
+           in (A.char ' ' *> formattedP '^' (color <> " ") f)
+                <|> (A.char '^' $> Markdown f color)
+                <|> noFormat ("^" <> color)
+        _ -> noFormat ("^" <> color)
+    unformattedP :: Char -> Parser Markdown
+    unformattedP c = unmarked . (T.singleton c <>) <$> wordsP
+    wordsP :: Parser Text
+    wordsP = do
+      s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ')
+      A.peekChar >>= \case
+        Nothing -> pure s
+        Just c -> case M.lookup c formats of
+          Just _ -> pure s
+          Nothing -> (s <>) <$> wordsP
+    noFormat :: Text -> Parser Markdown
+    noFormat = pure . unmarked