diff options
Diffstat (limited to 'main/Terminal.hs')
| -rw-r--r-- | main/Terminal.hs | 120 |
1 files changed, 97 insertions, 23 deletions
diff --git a/main/Terminal.hs b/main/Terminal.hs index 150bd8c..b8b953f 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -44,14 +44,20 @@ data Terminal = Terminal , termShowPrompt :: TVar Bool , termInput :: TVar ( String, String ) , termBottomLines :: TVar [ String ] + , termHistory :: TVar [ String ] + , termHistoryPos :: TVar Int + , termHistoryStash :: TVar ( String, String ) } data TerminalLine = TerminalLine { tlTerminal :: Terminal + , tlLineCount :: Int } data Input = InputChar Char + | InputMoveUp + | InputMoveDown | InputMoveRight | InputMoveLeft | InputMoveEnd @@ -84,6 +90,9 @@ initTerminal termCompletionFunc = do termShowPrompt <- newTVarIO False termInput <- newTVarIO ( "", "" ) termBottomLines <- newTVarIO [] + termHistory <- newTVarIO [] + termHistoryPos <- newTVarIO 0 + termHistoryStash <- newTVarIO ( "", "" ) return Terminal {..} bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c @@ -112,6 +121,8 @@ getInput = do '\ESC' -> do esc <- readEsc case parseEsc esc of + Just ( 'A' , [] ) -> return InputMoveUp + Just ( 'B' , [] ) -> return InputMoveDown Just ( 'C' , [] ) -> return InputMoveRight Just ( 'D' , [] ) -> return InputMoveLeft _ -> return (InputEscape esc) @@ -119,6 +130,8 @@ getInput = do '\DEL' -> return InputBackspace '\NAK' -> return InputClear '\ETB' -> return InputBackWord + '\DLE' -> return InputMoveUp + '\SO' -> return InputMoveDown '\SOH' -> return InputMoveStart '\ENQ' -> return InputMoveEnd '\EOT' -> return InputEnd @@ -136,19 +149,33 @@ getInput = do getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a getInputLine term@Terminal {..} handleResult = do - withMVar termLock $ \_ -> do - prompt <- atomically $ do - writeTVar termShowPrompt True - readTVar termPrompt - putStr $ prompt <> "\ESC[K" - drawBottomLines term - hFlush stdout - (handleResult <$> go) >>= \case + when termAnsi $ do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout + + mbLine <- go + forM_ mbLine $ \line -> do + let addLine xs + | null line = xs + | (x : _) <- xs, x == line = xs + | otherwise = line : xs + atomically $ do + writeTVar termHistory . addLine =<< readTVar termHistory + writeTVar termHistoryPos 0 + + case handleResult mbLine of KeepPrompt x -> do - termPutStr term "\n\ESC[J" + when termAnsi $ do + termPutStr term "\n\ESC[J" return x ErasePrompt x -> do - termPutStr term "\r\ESC[J" + when termAnsi $ do + termPutStr term "\r\ESC[J" return x where go = getInput >>= \case @@ -156,11 +183,12 @@ getInputLine term@Terminal {..} handleResult = do atomically $ do ( pre, post ) <- readTVar termInput writeTVar termInput ( "", "" ) - writeTVar termShowPrompt False - writeTVar termBottomLines [] + when termAnsi $ do + writeTVar termShowPrompt False + writeTVar termBottomLines [] return $ Just $ pre ++ post - InputChar '\t' -> do + InputChar '\t' | termAnsi -> do options <- withMVar termLock $ const $ do ( pre, post ) <- atomically $ readTVar termInput let updatePrompt pre' = do @@ -179,9 +207,11 @@ getInputLine term@Terminal {..} handleResult = do ( unused, completions@(c : cs) ) -> do let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of - Just common -> updatePrompt $ T.unpack unused ++ T.unpack common - Nothing -> return () - return $ map replacement completions + Just common | T.unpack common /= pre -> do + updatePrompt $ T.unpack unused ++ T.unpack common + return [] + _ -> do + return $ map replacement completions ( _, [] ) -> do return [] @@ -196,6 +226,37 @@ getInputLine term@Terminal {..} handleResult = do InputChar _ -> go + InputMoveUp -> withInput $ \prepost -> do + hist <- readTVar termHistory + pos <- readTVar termHistoryPos + case drop pos hist of + ( h : _ ) -> do + when (pos == 0) $ do + writeTVar termHistoryStash prepost + writeTVar termHistoryPos (pos + 1) + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + + InputMoveDown -> withInput $ \_ -> do + readTVar termHistoryPos >>= \case + 0 -> do + return "" + 1 -> do + writeTVar termHistoryPos 0 + writeTVar termInput =<< readTVar termHistoryStash + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + pos -> do + writeTVar termHistoryPos (pos - 1) + hist <- readTVar termHistory + case drop (pos - 2) hist of + ( h : _ ) -> do + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + InputMoveRight -> withInput $ \case ( pre, c : post ) -> do writeTVar termInput ( pre ++ [ c ], post ) @@ -241,7 +302,7 @@ getInputLine term@Terminal {..} handleResult = do withInput f = do withMVar termLock $ const $ do str <- atomically $ f =<< readTVar termInput - when (not $ null str) $ do + when (termAnsi && not (null str)) $ do putStr str hFlush stdout go @@ -254,6 +315,8 @@ getCurrentPromptLine Terminal {..} = do return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" setPrompt :: Terminal -> String -> IO () +setPrompt Terminal { termAnsi = False } _ = do + return () setPrompt term@Terminal {..} prompt = do withMVar termLock $ \_ -> do join $ atomically $ do @@ -269,17 +332,26 @@ setPrompt term@Terminal {..} prompt = do printLine :: Terminal -> String -> IO TerminalLine printLine tlTerminal@Terminal {..} str = do withMVar termLock $ \_ -> do - promptLine <- atomically $ do - readTVar termShowPrompt >>= \case - True -> getCurrentPromptLine tlTerminal - False -> return "" - putStr $ "\r\ESC[K" <> str <> "\n\ESC[K" <> promptLine - drawBottomLines tlTerminal + let strLines = lines str + tlLineCount = length strLines + if termAnsi + then do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine + drawBottomLines tlTerminal + else do + putStr $ unlines strLines + hFlush stdout return TerminalLine {..} printBottomLines :: Terminal -> String -> IO () +printBottomLines Terminal { termAnsi = False } _ = do + return () printBottomLines term@Terminal {..} str = do case lines str of [] -> clearBottomLines term @@ -290,6 +362,8 @@ printBottomLines term@Terminal {..} str = do hFlush stdout clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal { termAnsi = False } = do + return () clearBottomLines Terminal {..} = do withMVar termLock $ \_ -> do atomically (readTVar termBottomLines) >>= \case |