From d0163ccd56da85384bc08534e32b74ad9a182d33 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 8 Apr 2021 20:20:06 +0100 Subject: [PATCH] refactor chat terminal (#83) --- ChatTerminal.hs | 240 ++------------------------- Terminal.hs => ChatTerminal/Basic.hs | 2 +- ChatTerminal/Core.hs | 130 +++++++++++++++ ChatTerminal/POSIX.hs | 102 ++++++++++++ 4 files changed, 247 insertions(+), 227 deletions(-) rename Terminal.hs => ChatTerminal/Basic.hs (98%) create mode 100644 ChatTerminal/Core.hs create mode 100644 ChatTerminal/POSIX.hs diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 643955ad76..3f80dde16c 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -13,62 +13,19 @@ module ChatTerminal ) where +import ChatTerminal.Basic (getLn, putLn) +import ChatTerminal.Core +import ChatTerminal.POSIX import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Concurrent.STM 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 -import Terminal (getLn, putLn) import Types -data ChatTerminal = ChatTerminal - { inputQ :: TBQueue String, - outputQ :: TBQueue StyledString, - activeContact :: TVar (Maybe Contact), - username :: TVar (Maybe Contact), - termMode :: TermMode, - termState :: TVar TerminalState, - termSize :: (Int, Int), - nextMessageRow :: TVar Int, - termLock :: TMVar () - } - -data TerminalState = TerminalState - { inputPrompt :: String, - inputString :: String, - inputPosition :: Int - } - -inputHeight :: TerminalState -> ChatTerminal -> Int -inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1 - -data Key - = KeyLeft - | KeyRight - | KeyUp - | KeyDown - | KeyAltLeft - | KeyAltRight - | KeyCtrlLeft - | KeyCtrlRight - | KeyShiftLeft - | KeyShiftRight - | KeyEnter - | KeyBack - | KeyTab - | KeyEsc - | KeyChars String - | KeyUnsupported - deriving (Eq) - newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal newChatTerminal qSize user termMode = do inputQ <- newTBQueueIO qSize @@ -94,27 +51,29 @@ newTermState user = chatTerminal :: ChatTerminal -> IO () chatTerminal ct | termSize ct == (0, 0) || termMode ct == TermModeBasic = - run receiveFromTTY sendToTTY + run basicReceiveFromTTY basicSendToTTY | otherwise = do - setTTY NoBuffering - hSetEcho stdin False + initTTY updateInput ct - run receiveFromTTY' sendToTTY' + run receiveFromTTY sendToTTY where run receive send = race_ (receive ct) (send ct) -receiveFromTTY :: ChatTerminal -> IO () -receiveFromTTY ct = +basicReceiveFromTTY :: ChatTerminal -> IO () +basicReceiveFromTTY ct = forever $ getLn >>= atomically . writeTBQueue (inputQ ct) +basicSendToTTY :: ChatTerminal -> IO () +basicSendToTTY ct = forever $ readOutputQ ct >>= putLn + withTermLock :: ChatTerminal -> IO () -> IO () withTermLock ChatTerminal {termLock} action = do _ <- atomically $ takeTMVar termLock action atomically $ putTMVar termLock () -receiveFromTTY' :: ChatTerminal -> IO () -receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = +receiveFromTTY :: ChatTerminal -> IO () +receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) where @@ -135,109 +94,8 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = return s 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 - 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 - _ -> ts - where - insertCharsWithContact cs - | null s && cs /= "@" && cs /= "/" = - insertChars $ contactPrefix <> cs - | otherwise = insertChars cs - insertChars = ts' . if p >= length s then append else insert - append cs = let s' = s <> cs in (s', length s') - insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs) - contactPrefix = case ac of - Just (Contact c) -> "@" <> B.unpack c <> " " - Nothing -> "" - backDeleteChar - | p == 0 || null s = ts - | p >= length s = ts' backDeleteLast - | otherwise = ts' backDelete - backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s') - backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1) - setPosition p' = ts' (s, p') - prevWordPos - | p == 0 || null s = p - | otherwise = - let before = take p s - beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before - in max 0 $ p - length before + length beforeWord - nextWordPos - | p >= length s || null s = p - | otherwise = - let after = drop p s - afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after - in min (length s) $ p + length after - length afterWord - ts' (s', p') = ts {inputString = s', inputPosition = p'} - -styleMessage :: String -> StyledString -styleMessage = \case - "" -> "" - 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 - 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) - -updateUsername :: ChatTerminal -> Maybe Contact -> STM () -updateUsername ct a = do - writeTVar (username ct) a - modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a} - -promptString :: Maybe Contact -> String -promptString a = maybe "" (B.unpack . toBs) a <> "> " - sendToTTY :: ChatTerminal -> IO () -sendToTTY ct = forever $ readOutputQ ct >>= putLn - -sendToTTY' :: ChatTerminal -> IO () -sendToTTY' ct = forever $ do +sendToTTY ct = forever $ do msg <- readOutputQ ct withTermLock ct $ do printMessage ct msg @@ -245,73 +103,3 @@ sendToTTY' ct = forever $ do readOutputQ :: ChatTerminal -> IO StyledString readOutputQ = atomically . readTBQueue . outputQ - -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) - -setTTY :: BufferMode -> IO () -setTTY mode = do - hSetBuffering stdin mode - hSetBuffering stdout mode - -ttyContact :: Contact -> StyledString -ttyContact (Contact a) = Styled contactSGR $ B.unpack a - -ttyFromContact :: Contact -> StyledString -ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">" - -contactSGR :: [C.SGR] -contactSGR = [C.SetColor C.Foreground C.Vivid C.Yellow] - -selfSGR :: [C.SGR] -selfSGR = [C.SetColor C.Foreground C.Vivid C.Cyan] diff --git a/Terminal.hs b/ChatTerminal/Basic.hs similarity index 98% rename from Terminal.hs rename to ChatTerminal/Basic.hs index 916eb06d17..95e4cd43eb 100644 --- a/Terminal.hs +++ b/ChatTerminal/Basic.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module Terminal where +module ChatTerminal.Basic where import Control.Monad.IO.Class (liftIO) import Styled diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs new file mode 100644 index 0000000000..72ab58f446 --- /dev/null +++ b/ChatTerminal/Core.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module ChatTerminal.Core where + +import Control.Concurrent.STM +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import qualified Data.Text as T +import SimplexMarkdown +import Styled +import System.Console.ANSI.Types +import Types + +data ChatTerminal = ChatTerminal + { inputQ :: TBQueue String, + outputQ :: TBQueue StyledString, + activeContact :: TVar (Maybe Contact), + username :: TVar (Maybe Contact), + termMode :: TermMode, + termState :: TVar TerminalState, + termSize :: (Int, Int), + nextMessageRow :: TVar Int, + termLock :: TMVar () + } + +data TerminalState = TerminalState + { inputPrompt :: String, + inputString :: String, + inputPosition :: Int + } + +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 + +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 + _ -> ts + where + insertCharsWithContact cs + | null s && cs /= "@" && cs /= "/" = + insertChars $ contactPrefix <> cs + | otherwise = insertChars cs + insertChars = ts' . if p >= length s then append else insert + append cs = let s' = s <> cs in (s', length s') + insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs) + contactPrefix = case ac of + Just (Contact c) -> "@" <> B.unpack c <> " " + Nothing -> "" + backDeleteChar + | p == 0 || null s = ts + | p >= length s = ts' backDeleteLast + | otherwise = ts' backDelete + backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s') + backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1) + setPosition p' = ts' (s, p') + prevWordPos + | p == 0 || null s = p + | otherwise = + let before = take p s + beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before + in max 0 $ p - length before + length beforeWord + nextWordPos + | p >= length s || null s = p + | otherwise = + let after = drop p s + afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after + in min (length s) $ p + length after - length afterWord + ts' (s', p') = ts {inputString = s', inputPosition = p'} + +styleMessage :: String -> StyledString +styleMessage = \case + "" -> "" + s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest + s -> markdown s + where + markdown :: String -> StyledString + markdown = styleMarkdown . parseMarkdown . T.pack + +updateUsername :: ChatTerminal -> Maybe Contact -> STM () +updateUsername ct a = do + writeTVar (username ct) a + modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a} + +promptString :: Maybe Contact -> String +promptString a = maybe "" (B.unpack . toBs) a <> "> " + +ttyContact :: Contact -> StyledString +ttyContact (Contact a) = Styled contactSGR $ B.unpack a + +ttyFromContact :: Contact -> StyledString +ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">" + +contactSGR :: [SGR] +contactSGR = [SetColor Foreground Vivid Yellow] + +selfSGR :: [SGR] +selfSGR = [SetColor Foreground Vivid Cyan] diff --git a/ChatTerminal/POSIX.hs b/ChatTerminal/POSIX.hs new file mode 100644 index 0000000000..c4dcb95fa9 --- /dev/null +++ b/ChatTerminal/POSIX.hs @@ -0,0 +1,102 @@ +{-# 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)