fix multiline output (messages and help) (#90)

ChatTerminal.hs

@@ -63,7 +63,7 @@ basicReceiveFromTTY ct =
   forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
 
 basicSendToTTY :: ChatTerminal -> IO ()
-basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= putStyledLn
+basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= mapM_ putStyledLn
 
 withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
 withTermLock ChatTerminal {termLock} action = do
@@ -91,7 +91,7 @@ receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
         writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
         writeTBQueue inputQ s
         return s
-      withTermLock ct . printMessage ct $ styleMessage msg
+      withTermLock ct $ printMessage ct [styleMessage msg]
 
 sendToTTY :: ChatTerminal -> IO ()
 sendToTTY ct = withTerminal . runTerminalT . forever $ do
@@ -100,5 +100,5 @@ sendToTTY ct = withTerminal . runTerminalT . forever $ do
     printMessage ct msg
     updateInput ct
 
-readOutputQ :: ChatTerminal -> STM StyledString
+readOutputQ :: ChatTerminal -> STM [StyledString]
 readOutputQ = readTBQueue . outputQ

ChatTerminal/Core.hs

@@ -5,10 +5,12 @@
 module ChatTerminal.Core where
 
 import Control.Concurrent.STM
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.List (dropWhileEnd)
+import Data.Text (Text)
 import qualified Data.Text as T
-import Simplex.Markdown
+import Data.Text.Encoding
 import Styled
 import System.Console.ANSI.Types
 import System.Terminal hiding (insertChars)
@@ -16,7 +18,7 @@ import Types
 
 data ChatTerminal = ChatTerminal
   { inputQ :: TBQueue String,
-    outputQ :: TBQueue StyledString,
+    outputQ :: TBQueue [StyledString],
     activeContact :: TVar (Maybe Contact),
     username :: TVar (Maybe Contact),
     termMode :: TermMode,
@@ -118,7 +120,12 @@ styleMessage = \case
   s -> markdown s
   where
     markdown :: String -> StyledString
-    markdown = styleMarkdown . parseMarkdown . T.pack
+    markdown = styleMarkdownText . T.pack
+
+safeDecodeUtf8 :: ByteString -> Text
+safeDecodeUtf8 = decodeUtf8With onError
+  where
+    onError _ _ = Just '?'
 
 updateUsername :: ChatTerminal -> Maybe Contact -> STM ()
 updateUsername ct a = do
@@ -132,7 +139,7 @@ ttyContact :: Contact -> StyledString
 ttyContact (Contact a) = Styled contactSGR $ B.unpack a
 
 ttyFromContact :: Contact -> StyledString
-ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">"
+ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> "> "
 
 contactSGR :: [SGR]
 contactSGR = [SetColor Foreground Vivid Yellow]

ChatTerminal/Editor.hs

@@ -43,13 +43,19 @@ updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMes
         eraseInLine EraseForward
         clearLines (from + 1) till
 
-printMessage :: MonadTerminal m => ChatTerminal -> StyledString -> m ()
+printMessage :: forall m. 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
+  mapM_ printStyled msg
   flush
+  let lc = sum $ map lineCount msg
   atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
+  where
+    lineCount :: StyledString -> Int
+    lineCount s = sLength s `div` width + 1
+    printStyled :: StyledString -> m ()
+    printStyled s = do
+      putStyled s
+      eraseInLine EraseForward
+      putLn

Main.hs

@@ -11,6 +11,7 @@ module Main where
 
 import ChatOptions
 import ChatTerminal
+import ChatTerminal.Core
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM
 import Control.Logger.Simple
@@ -31,6 +32,7 @@ import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client (smpDefaultConfig)
 import Simplex.Messaging.Util (raceAny_)
 import Styled
+import System.Console.ANSI.Types
 import System.Directory (getAppUserDataDirectory)
 import Types
 
@@ -91,35 +93,43 @@ data ChatResponse
   | ChatError AgentErrorType
   | NoChatResponse
 
-serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString
+serializeChatResponse :: Maybe Contact -> ChatResponse -> [StyledString]
 serializeChatResponse name = \case
   ChatHelpInfo -> chatHelpInfo
-  Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo
-  Connected c -> ttyContact c <> " connected"
-  ReceivedMessage c t -> ttyFromContact c <> " " <> msgPlain t
-  Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""
-  YesYes -> "you got it!"
-  ErrorInput t -> "invalid input: " <> bPlain t
-  ChatError e -> "chat error: " <> plain (show e)
-  NoChatResponse -> ""
+  Invitation qInfo -> ["ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo]
+  Connected c -> [ttyContact c <> " connected"]
+  ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t
+  Disconnected c -> ["disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""]
+  YesYes -> ["you got it!"]
+  ErrorInput t -> ["invalid input: " <> bPlain t]
+  ChatError e -> ["chat error: " <> plain (show e)]
+  NoChatResponse -> [""]
   where
     showName Nothing = "<your name>"
     showName (Just (Contact a)) = bPlain a
-    msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError
-    onError _ _ = Just '?'
+    prependFirst :: StyledString -> [StyledString] -> [StyledString]
+    prependFirst s [] = [s]
+    prependFirst s (s' : ss) = (s <> s') : ss
+    msgPlain :: ByteString -> [StyledString]
+    msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
 
-chatHelpInfo :: StyledString
+chatHelpInfo :: [StyledString]
 chatHelpInfo =
-  "Using chat:\n\
-  \/add <name>       - create invitation to send out-of-band\n\
-  \                    to your contact <name>\n\
-  \                    (any unique string without spaces)\n\
-  \/accept <name> <invitation> - accept <invitation>\n\
-  \                    (a string that starts from \"smp::\")\n\
-  \                    from your contact <name>\n\
-  \/name <name>      - set <name> to use in invitations\n\
-  \@<name> <message> - send <message> (any string) to contact <name>\n\
-  \                    @<name> can be omitted to send to previous"
+  map
+    styleMarkdown
+    [ "Using chat:",
+      highlight "/add <name>" <> "       - create invitation to send out-of-band",
+      "                    to your contact <name>",
+      "                    (any unique string without spaces)",
+      highlight "/accept <name> <invitation>" <> " - accept <invitation>",
+      "                    (a string that starts from \"smp::\")",
+      "                    from your contact <name>",
+      highlight "/name <name>" <> "      - set <name> to use in invitations",
+      highlight "@<name> <message>" <> " - send <message> (any string) to contact <name>",
+      "                    @<name> can be omitted to send to previous"
+    ]
+  where
+    highlight = Markdown (Colored Cyan)
 
 main :: IO ()
 main = do

Styled.hs

@@ -3,6 +3,7 @@ module Styled where
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.String
+import Data.Text (Text)
 import qualified Data.Text as T
 import Simplex.Markdown
 import System.Console.ANSI (setSGRCode)
@@ -22,6 +23,9 @@ plain = Styled []
 bPlain :: ByteString -> StyledString
 bPlain = Styled [] . B.unpack
 
+styleMarkdownText :: Text -> StyledString
+styleMarkdownText = styleMarkdown . parseMarkdown
+
 styleMarkdown :: Markdown -> StyledString
 styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
 styleMarkdown (Markdown Snippet s) = plain . T.unpack $ '`' `T.cons` s `T.snoc` '`'