mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-10 19:27:08 +00:00
refactor chat terminal (#83)
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
bac96b4433
commit
d0163ccd56
+14
-226
@@ -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]
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Terminal where
|
||||
module ChatTerminal.Basic where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Styled
|
||||
@@ -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]
|
||||
@@ -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)
|
||||
Reference in New Issue
Block a user