Windows support in editor mode (#85)

* use System.Terminal for "editor" mode (WIP, does not work in POSIX)

* fix getKey - only return one event on control keys

* fix printing with System.Terminal

* different markdown escape for color, added black color

* fix color escapes

* make black invisible

* markdown fixes

* remove Key type, fix editor bug, refactor

* refactor: use getKey in getTermLine

* default mode is "editor", remove windows warning

* markdown: code snippet

* use ! for color markdown

* edit previous input

* clean up

* use getWindowSize from System.Terminal

ChatOptions.hs

@@ -8,7 +8,6 @@ import qualified Data.ByteString.Char8 as B
 import Options.Applicative
 import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
 import System.FilePath (combine)
-import System.Info (os)
 import Types
 
 data ChatOpts = ChatOpts
@@ -49,14 +48,11 @@ chatOpts appDir =
       ( long "term"
           <> short 't'
           <> metavar "TERM"
-          <> help ("terminal mode: editor or basic (" <> termModeName deafultTermMode <> ")")
-          <> value deafultTermMode
+          <> help ("terminal mode: editor or basic (" <> termModeName TermModeEditor <> ")")
+          <> value TermModeEditor
       )
   where
     defaultDbFilePath = combine appDir "smp-chat.db"
-    deafultTermMode
-      | os == "mingw32" = TermModeBasic
-      | otherwise = TermModeEditor
 
 parseSMPServer :: ReadM SMPServer
 parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack

ChatTerminal.hs

@@ -13,18 +13,17 @@ module ChatTerminal
   )
 where
 
-import ChatTerminal.Basic (getLn, putLn)
+import ChatTerminal.Basic
 import ChatTerminal.Core
-import ChatTerminal.POSIX
+import ChatTerminal.Editor
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
-import Control.Concurrent.STM
 import Control.Monad
-import Data.Maybe (fromMaybe)
 import Numeric.Natural
 import Styled
-import qualified System.Console.ANSI as C
+import System.Terminal
 import Types
+import UnliftIO.STM
 
 newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal
 newChatTerminal qSize user termMode = do
@@ -32,8 +31,8 @@ newChatTerminal qSize user termMode = do
   outputQ <- newTBQueueIO qSize
   activeContact <- newTVarIO Nothing
   username <- newTVarIO user
-  termSize <- fromMaybe (0, 0) <$> C.getTerminalSize
-  let lastRow = fst termSize - 1
+  termSize <- withTerminal . runTerminalT $ getWindowSize
+  let lastRow = height termSize - 1
   termState <- newTVarIO $ newTermState user
   termLock <- newTMVarIO ()
   nextMessageRow <- newTVarIO lastRow
@@ -45,16 +44,16 @@ newTermState user =
   TerminalState
     { inputString = "",
       inputPosition = 0,
-      inputPrompt = promptString user
+      inputPrompt = promptString user,
+      previousInput = ""
     }
 
 chatTerminal :: ChatTerminal -> IO ()
 chatTerminal ct
-  | termSize ct == (0, 0) || termMode ct == TermModeBasic =
+  | termSize ct == Size 0 0 || termMode ct == TermModeBasic =
     run basicReceiveFromTTY basicSendToTTY
   | otherwise = do
-    initTTY
-    updateInput ct
+    withTerminal . runTerminalT $ updateInput ct
     run receiveFromTTY sendToTTY
   where
     run receive send = race_ (receive ct) (send ct)
@@ -64,9 +63,9 @@ basicReceiveFromTTY ct =
   forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
 
 basicSendToTTY :: ChatTerminal -> IO ()
-basicSendToTTY ct = forever $ readOutputQ ct >>= putLn
+basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= putStyledLn
 
-withTermLock :: ChatTerminal -> IO () -> IO ()
+withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
 withTermLock ChatTerminal {termLock} action = do
   _ <- atomically $ takeTMVar termLock
   action
@@ -74,32 +73,32 @@ withTermLock ChatTerminal {termLock} action = do
 
 receiveFromTTY :: ChatTerminal -> IO ()
 receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
-  forever $
+  withTerminal . runTerminalT . forever $
     getKey >>= processKey >> withTermLock ct (updateInput ct)
   where
-    processKey :: Key -> IO ()
+    processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
     processKey = \case
-      KeyEnter -> submitInput
+      (EnterKey, _) -> submitInput
       key -> atomically $ do
         ac <- readTVar activeContact
-        modifyTVar termState $ updateTermState ac (snd termSize) key
+        modifyTVar termState $ updateTermState ac (width termSize) key
 
-    submitInput :: IO ()
+    submitInput :: MonadTerminal m => m ()
     submitInput = do
       msg <- atomically $ do
         ts <- readTVar termState
-        writeTVar termState $ ts {inputString = "", inputPosition = 0}
         let s = inputString ts
+        writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
         writeTBQueue inputQ s
         return s
       withTermLock ct . printMessage ct $ styleMessage msg
 
 sendToTTY :: ChatTerminal -> IO ()
-sendToTTY ct = forever $ do
-  msg <- readOutputQ ct
+sendToTTY ct = withTerminal . runTerminalT . forever $ do
+  msg <- atomically $ readOutputQ ct
   withTermLock ct $ do
     printMessage ct msg
     updateInput ct
 
-readOutputQ :: ChatTerminal -> IO StyledString
-readOutputQ = atomically . readTBQueue . outputQ
+readOutputQ :: ChatTerminal -> STM StyledString
+readOutputQ = readTBQueue . outputQ

ChatTerminal/Basic.hs

@@ -11,11 +11,15 @@ import System.Terminal as C
 getLn :: IO String
 getLn = withTerminal $ runTerminalT getTermLine
 
-putLn :: StyledString -> IO ()
-putLn s =
+putStyledLn :: StyledString -> IO ()
+putStyledLn s =
   withTerminal . runTerminalT $
     putStyled s >> C.putLn >> flush
 
+-- Currently it is assumed that the message does not have internal line breaks.
+-- Previous implementation "kind of" supported them,
+-- but it was not determining the number of printed lines correctly
+-- because of accounting for control sequences in length
 putStyled :: MonadTerminal m => StyledString -> m ()
 putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
 putStyled (Styled [] s) = putString s
@@ -55,12 +59,18 @@ setSGR = mapM_ $ \case
       Cyan -> cyan
       White -> white
 
+getKey :: MonadTerminal m => m (Key, Modifiers)
+getKey =
+  awaitEvent >>= \case
+    Left Interrupt -> liftIO exitSuccess
+    Right (KeyEvent key ms) -> pure (key, ms)
+    _ -> getKey
+
 getTermLine :: MonadTerminal m => m String
 getTermLine = getChars ""
   where
-    getChars s = awaitEvent >>= processKey s
-    processKey s = \case
-      Right (KeyEvent key ms) -> case key of
+    getChars s =
+      getKey >>= \(key, ms) -> case key of
         CharKey c
           | ms == mempty || ms == shiftKey -> do
             C.putChar c
@@ -77,5 +87,3 @@ getTermLine = getChars ""
           flush
           getChars $ if null s then s else tail s
         _ -> getChars s
-      Left Interrupt -> liftIO exitSuccess
-      _ -> getChars s

ChatTerminal/Core.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ChatTerminal.Core where
@@ -7,9 +8,10 @@ import Control.Concurrent.STM
 import qualified Data.ByteString.Char8 as B
 import Data.List (dropWhileEnd)
 import qualified Data.Text as T
-import SimplexMarkdown
+import Simplex.Markdown
 import Styled
 import System.Console.ANSI.Types
+import System.Terminal hiding (insertChars)
 import Types
 
 data ChatTerminal = ChatTerminal
@@ -19,7 +21,7 @@ data ChatTerminal = ChatTerminal
     username :: TVar (Maybe Contact),
     termMode :: TermMode,
     termState :: TVar TerminalState,
-    termSize :: (Int, Int),
+    termSize :: Size,
     nextMessageRow :: TVar Int,
     termLock :: TMVar ()
   }
@@ -27,46 +29,48 @@ data ChatTerminal = ChatTerminal
 data TerminalState = TerminalState
   { inputPrompt :: String,
     inputString :: String,
-    inputPosition :: Int
+    inputPosition :: Int,
+    previousInput :: String
   }
 
-data Key
-  = KeyLeft
-  | KeyRight
-  | KeyUp
-  | KeyDown
-  | KeyAltLeft
-  | KeyAltRight
-  | KeyCtrlLeft
-  | KeyCtrlRight
-  | KeyShiftLeft
-  | KeyShiftRight
-  | KeyEnter
-  | KeyBack
-  | KeyTab
-  | KeyEsc
-  | KeyChars String
-  | KeyUnsupported
-  deriving (Eq)
-
 inputHeight :: TerminalState -> ChatTerminal -> Int
-inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1
+inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1
 
-updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState
-updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of
-  KeyChars cs -> insertCharsWithContact cs
-  KeyTab -> insertChars "    "
-  KeyBack -> backDeleteChar
-  KeyLeft -> setPosition $ max 0 (p - 1)
-  KeyRight -> setPosition $ min (length s) (p + 1)
-  KeyUp -> setPosition $ let p' = p - tw in if p' > 0 then p' else p
-  KeyDown -> setPosition $ let p' = p + tw in if p' <= length s then p' else p
-  KeyAltLeft -> setPosition prevWordPos
-  KeyAltRight -> setPosition nextWordPos
-  KeyCtrlLeft -> setPosition prevWordPos
-  KeyCtrlRight -> setPosition nextWordPos
-  KeyShiftLeft -> setPosition 0
-  KeyShiftRight -> setPosition $ length s
+positionRowColumn :: Int -> Int -> Position
+positionRowColumn wid pos =
+  let row = pos `div` wid
+      col = pos - row * wid
+   in Position {row, col}
+
+updateTermState :: Maybe Contact -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
+updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of
+  CharKey c
+    | ms == mempty || ms == shiftKey -> insertCharsWithContact [c]
+    | ms == altKey && c == 'b' -> setPosition prevWordPos
+    | ms == altKey && c == 'f' -> setPosition nextWordPos
+    | otherwise -> ts
+  TabKey -> insertCharsWithContact "    "
+  BackspaceKey -> backDeleteChar
+  ArrowKey d -> case d of
+    Leftwards
+      | ms == mempty -> setPosition $ max 0 (p - 1)
+      | ms == shiftKey -> setPosition 0
+      | ms == ctrlKey -> setPosition prevWordPos
+      | ms == altKey -> setPosition prevWordPos
+      | otherwise -> setPosition p
+    Rightwards
+      | ms == mempty -> setPosition $ min (length s) (p + 1)
+      | ms == shiftKey -> setPosition $ length s
+      | ms == ctrlKey -> setPosition nextWordPos
+      | ms == altKey -> setPosition nextWordPos
+      | otherwise -> setPosition p
+    Upwards
+      | ms == mempty && null s -> let s' = previousInput ts in ts' (s', length s')
+      | ms == mempty -> let p' = p - tw in setPosition $ if p' > 0 then p' else p
+      | otherwise -> setPosition p
+    Downwards
+      | ms == mempty -> let p' = p + tw in setPosition $ if p' <= length s then p' else p
+      | otherwise -> setPosition p
   _ -> ts
   where
     insertCharsWithContact cs

ChatTerminal/Editor.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module ChatTerminal.Editor where
+
+import ChatTerminal.Basic
+import ChatTerminal.Core
+import Styled
+import System.Terminal
+import UnliftIO.STM
+
+-- debug :: MonadTerminal m => String -> m ()
+-- debug s = do
+--   saveCursor
+--   setCursorPosition $ Position 0 0
+--   putString s
+--   restoreCursor
+
+updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
+updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
+  hideCursor
+  ts <- readTVarIO termState
+  nmr <- readTVarIO nextMessageRow
+  let ih = inputHeight ts ct
+      iStart = height - ih
+      prompt = inputPrompt ts
+      Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
+  if nmr >= iStart
+    then atomically $ writeTVar nextMessageRow iStart
+    else clearLines nmr iStart
+  setCursorPosition $ Position {row = max nmr iStart, col = 0}
+  putString $ prompt <> inputString ts <> " "
+  eraseInLine EraseForward
+  setCursorPosition $ Position {row = iStart + row, col}
+  showCursor
+  flush
+  where
+    clearLines :: Int -> Int -> m ()
+    clearLines from till
+      | from >= till = return ()
+      | otherwise = do
+        setCursorPosition $ Position {row = from, col = 0}
+        eraseInLine EraseForward
+        clearLines (from + 1) till
+
+printMessage :: MonadTerminal m => ChatTerminal -> StyledString -> m ()
+printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
+  nmr <- readTVarIO nextMessageRow
+  setCursorPosition $ Position {row = nmr, col = 0}
+  let lc = sLength msg `div` width + 1
+  putStyled msg
+  eraseInLine EraseForward
+  putLn
+  flush
+  atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)

ChatTerminal/POSIX.hs

@@ -1,102 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module ChatTerminal.POSIX where
-
-import ChatTerminal.Core
-import Control.Concurrent.STM
-import Styled
-import qualified System.Console.ANSI as C
-import System.IO
-
-initTTY :: IO ()
-initTTY = do
-  hSetEcho stdin False
-  hSetBuffering stdin NoBuffering
-  hSetBuffering stdout NoBuffering
-
-updateInput :: ChatTerminal -> IO ()
-updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do
-  C.hideCursor
-  ts <- readTVarIO termState
-  nmr <- readTVarIO nextMessageRow
-  let (th, tw) = termSize
-      ih = inputHeight ts ct
-      iStart = th - ih
-      prompt = inputPrompt ts
-      (cRow, cCol) = relativeCursorPosition tw $ length prompt + inputPosition ts
-  if nmr >= iStart
-    then atomically $ writeTVar nextMessageRow iStart
-    else clearLines nmr iStart
-  C.setCursorPosition (max nmr iStart) 0
-  putStr $ prompt <> inputString ts <> " "
-  C.clearFromCursorToLineEnd
-  C.setCursorPosition (iStart + cRow) cCol
-  C.showCursor
-  where
-    clearLines :: Int -> Int -> IO ()
-    clearLines from till
-      | from >= till = return ()
-      | otherwise = do
-        C.setCursorPosition from 0
-        C.clearFromCursorToLineEnd
-        clearLines (from + 1) till
-
-    relativeCursorPosition :: Int -> Int -> (Int, Int)
-    relativeCursorPosition width pos =
-      let row = pos `div` width
-          col = pos - row * width
-       in (row, col)
-
-printMessage :: ChatTerminal -> StyledString -> IO ()
-printMessage ChatTerminal {termSize, nextMessageRow} msg = do
-  nmr <- readTVarIO nextMessageRow
-  C.setCursorPosition nmr 0
-  let (th, tw) = termSize
-  lc <- printLines tw msg
-  atomically . writeTVar nextMessageRow $ min (th - 1) (nmr + lc)
-  where
-    printLines :: Int -> StyledString -> IO Int
-    printLines tw ss = do
-      let s = styledToANSITerm ss
-          ls
-            | null s = [""]
-            | otherwise = lines s <> ["" | last s == '\n']
-      print_ ls
-      return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls
-
-    print_ :: [String] -> IO ()
-    print_ [] = return ()
-    print_ (l : ls) = do
-      putStr l
-      C.clearFromCursorToLineEnd
-      putStr "\n"
-      print_ ls
-
-getKey :: IO Key
-getKey = charsToKey . reverse <$> keyChars ""
-  where
-    charsToKey = \case
-      "\ESC" -> KeyEsc
-      "\ESC[A" -> KeyUp
-      "\ESC[B" -> KeyDown
-      "\ESC[D" -> KeyLeft
-      "\ESC[C" -> KeyRight
-      "\ESCb" -> KeyAltLeft
-      "\ESCf" -> KeyAltRight
-      "\ESC[1;5D" -> KeyCtrlLeft
-      "\ESC[1;5C" -> KeyCtrlRight
-      "\ESC[1;2D" -> KeyShiftLeft
-      "\ESC[1;2C" -> KeyShiftRight
-      "\n" -> KeyEnter
-      "\DEL" -> KeyBack
-      "\t" -> KeyTab
-      '\ESC' : _ -> KeyUnsupported
-      cs -> KeyChars cs
-
-    keyChars cs = do
-      c <- getChar
-      more <- hReady stdin
-      -- for debugging - uncomment this, comment line after:
-      -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs)
-      (if more then keyChars else return) (c : cs)

Main.hs

@@ -23,17 +23,15 @@ import Data.Functor (($>))
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Numeric.Natural
+import Simplex.Markdown
 import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
 import Simplex.Messaging.Agent.Client (AgentClient (..))
 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)
-import System.Info (os)
 import Types
 
 cfg :: AgentConfig
@@ -137,22 +135,12 @@ main = do
 welcomeGetOpts :: IO ChatOpts
 welcomeGetOpts = do
   appDir <- getAppUserDataDirectory "simplex"
-  opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir
+  opts@ChatOpts {dbFileName} <- getChatOpts appDir
   putStrLn "simpleX chat prototype"
   putStrLn $ "db: " <> dbFileName
-  when (os == "mingw32") $ windowsWarning termMode
   putStrLn "type \"/help\" for usage information"
   pure opts
 
-windowsWarning :: TermMode -> IO ()
-windowsWarning = \case
-  m@TermModeBasic -> do
-    putStrLn $ "running in Windows (terminal mode is " <> termModeName m <> ", no utf8 support)"
-    putStrLn "it is recommended to use Windows Subsystem for Linux (WSL)"
-  m -> do
-    putStrLn $ "running in Windows, terminal mode " <> termModeName m <> " is not supported"
-    exitFailure
-
 dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO ()
 dogFoodChat t ct env = do
   c <- runReaderT getSMPAgentClient env

SimplexMarkdown.hs

@@ -1,122 +0,0 @@
-{-# 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

Styled.hs

@@ -1,9 +1,12 @@
-module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where
+module Styled where
 
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.String
-import System.Console.ANSI (SGR (..), setSGRCode)
+import qualified Data.Text as T
+import Simplex.Markdown
+import System.Console.ANSI (setSGRCode)
+import System.Console.ANSI.Types
 
 data StyledString = Styled [SGR] String | StyledString :<>: StyledString
 
@@ -19,6 +22,21 @@ plain = Styled []
 bPlain :: ByteString -> StyledString
 bPlain = Styled [] . B.unpack
 
+styleMarkdown :: Markdown -> StyledString
+styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
+styleMarkdown (Markdown Snippet s) = plain . T.unpack $ '`' `T.cons` s `T.snoc` '`'
+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 Black -> [SetColor Foreground Dull Black]
+      Colored c -> [SetColor Foreground Vivid c]
+      Snippet -> []
+      NoFormat -> []
+
 styledToANSITerm :: StyledString -> String
 styledToANSITerm (Styled [] s) = s
 styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset]
@@ -27,3 +45,7 @@ styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2
 styledToPlain :: StyledString -> String
 styledToPlain (Styled _ s) = s
 styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2
+
+sLength :: StyledString -> Int
+sLength (Styled _ s) = length s
+sLength (s1 :<>: s2) = sLength s1 + sLength s2