mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
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
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
d0163ccd56
commit
ee8814dd25
+15
-7
@@ -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
|
||||
|
||||
+42
-38
@@ -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
|
||||
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
Reference in New Issue
Block a user