diff --git a/ChatTerminal.hs b/ChatTerminal.hs index e392a0ae2b..f2dd2e2c4a 100644 --- a/ChatTerminal.hs +++ b/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 diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 513b62a1ae..92e16decdd 100644 --- a/ChatTerminal/Core.hs +++ b/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] diff --git a/ChatTerminal/Editor.hs b/ChatTerminal/Editor.hs index ec1ae19ba1..d4e6a9843a 100644 --- a/ChatTerminal/Editor.hs +++ b/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 diff --git a/Main.hs b/Main.hs index 28407c86bb..7ef8218ee2 100644 --- a/Main.hs +++ b/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 = "" 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 - create invitation to send out-of-band\n\ - \ to your contact \n\ - \ (any unique string without spaces)\n\ - \/accept - accept \n\ - \ (a string that starts from \"smp::\")\n\ - \ from your contact \n\ - \/name - set to use in invitations\n\ - \@ - send (any string) to contact \n\ - \ @ can be omitted to send to previous" + map + styleMarkdown + [ "Using chat:", + highlight "/add " <> " - create invitation to send out-of-band", + " to your contact ", + " (any unique string without spaces)", + highlight "/accept " <> " - accept ", + " (a string that starts from \"smp::\")", + " from your contact ", + highlight "/name " <> " - set to use in invitations", + highlight "@ " <> " - send (any string) to contact ", + " @ can be omitted to send to previous" + ] + where + highlight = Markdown (Colored Cyan) main :: IO () main = do diff --git a/Styled.hs b/Styled.hs index e3f8f23eaa..63f4ccecbe 100644 --- a/Styled.hs +++ b/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` '`'