diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for terminal +## 0.2.0.0 Lars Petersen 2019-02-10 + +* Fixes several inconsistencies and improves the API + (heavily breaks previous API) + ## 0.1.0.0 Lars Petersen 2019-01-22 * Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ -# terminal +terminal [![Hackage](https://img.shields.io/github/release/lpeterse/haskell-terminal.svg)](https://github.com/lpeterse/haskell-terminal/releases) [![Travis](https://img.shields.io/travis/lpeterse/haskell-terminal.svg)](https://travis-ci.org/lpeterse/haskell-terminal) +======================= _terminal_ is a driver library for ANSI terminals like _xterm_. @@ -66,9 +67,11 @@ Arguments against _terminfo_: - - The _terminfo_ binding library is not threadsafe. This is not so much - of a problem when serving a single local terminal, but it might be a problem - when writing something like an SSH daemon in Haskell. + - Static linking and stand-alone binaries: + Apart from eventual linking issues, _terminfo_ has a runtime dependency on the + terminfo database. This might be an issue when the environment is restricted + (`chroot` environment or if the process shall not be allowed to interact with the file + system for security reasons). - _terminfo_ offers more than 500 capabilities. Only a very small part of it is actually needed and since there is no legacy code to support there is no real reason to expose more than a small subset of capabilities that is supported @@ -142,6 +145,6 @@ ### brick - - [brick](https://hackage.haskell.org/package/vty) is library on top of _vty_. Its + - [brick](https://hackage.haskell.org/package/brick) is library on top of _vty_. Its scope is different from what _terminal_ does. diff --git a/platform/posix/src/System/Terminal/Platform.hsc b/platform/posix/src/System/Terminal/Platform.hsc --- a/platform/posix/src/System/Terminal/Platform.hsc +++ b/platform/posix/src/System/Terminal/Platform.hsc @@ -1,22 +1,22 @@ -{-# LANGUAGE LambdaCase #-} module System.Terminal.Platform - ( withTerminal - ) where + ( withTerminal + , LocalTerminal () + ) where +import Control.Applicative import Control.Concurrent import qualified Control.Concurrent.Async as A -import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TMVar import qualified Control.Exception as E -import Control.Monad (forever, when, unless, void) +import Control.Monad (forM_, void, when) import Control.Monad.Catch hiding (handle) import Control.Monad.IO.Class import Control.Monad.STM import Data.Bits +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Maybe -import qualified Data.Text as Text import qualified Data.Text.IO as Text import Foreign.C.Types import Foreign.Marshal.Alloc @@ -26,54 +26,93 @@ import qualified System.IO as IO import qualified GHC.Conc as Conc import qualified Data.Dynamic as Dyn -import System.Posix.Types (Fd(..)) -import Control.Monad.Terminal.Terminal -import Control.Monad.Terminal.Input +import System.Terminal.Terminal +import System.Terminal.MonadInput +import System.Terminal.MonadScreen hiding (getWindowSize) +import System.Terminal.Decoder +import System.Terminal.Encoder #include "Rts.h" #include "hs_terminal.h" -withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a +data LocalTerminal + = LocalTerminal + { localType :: BS.ByteString + , localEvent :: STM Event + , localInterrupt :: STM Interrupt + , localGetCursorPosition :: IO Position + } + +instance Terminal LocalTerminal where + termType = localType + termEvent = localEvent + termInterrupt = localInterrupt + termCommand _ c = Text.hPutStr IO.stdout (defaultEncode c) + termFlush _ = IO.hFlush IO.stdout + termGetWindowSize _ = getWindowSize + termGetCursorPosition = localGetCursorPosition + +withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a withTerminal action = do - term <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM") - mainThread <- liftIO myThreadId - interrupt <- liftIO (newTVarIO False) - output <- liftIO newEmptyTMVarIO - outputFlush <- liftIO newEmptyTMVarIO - events <- liftIO newTChanIO - screenSize <- liftIO (newTVarIO =<< getWindowSize) - withTermiosSettings $ \termios-> - withResizeHandler (handleResize screenSize events) $ - withInputProcessing mainThread termios interrupt events $ - withOutputProcessing output outputFlush $ action $ Terminal { - termType = term - , termInput = readTChan events - , termInterrupt = swapTVar interrupt False >>= check - , termOutput = putTMVar output - , termFlush = putTMVar outputFlush () - , termScreenSize = readTVar screenSize - , termSpecialChars = \case - '\n' -> Just $ KeyEvent EnterKey mempty - '\t' -> Just $ KeyEvent TabKey mempty - '\SP' -> Just $ KeyEvent SpaceKey mempty - '\b' -> Just $ KeyEvent (if termiosVERASE termios == '\b' then BackspaceKey else DeleteKey) mempty - '\DEL' -> Just $ KeyEvent (if termiosVERASE termios == '\DEL' then DeleteKey else BackspaceKey) mempty - _ -> Nothing - } - where - handleResize screenSize events = do - ws <- getWindowSize - atomically $ do - writeTVar screenSize ws - writeTChan events (WindowEvent $ WindowSizeChanged ws) + term <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM") + mainThread <- liftIO myThreadId + interrupt <- liftIO (newTVarIO False) + windowChanged <- liftIO (newTVarIO False) + events <- liftIO newEmptyTMVarIO + cursorPosition <- liftIO newEmptyTMVarIO + withTermiosSettings $ \termios-> + withInterruptHandler (handleInterrupt mainThread interrupt) $ + withResizeHandler (handleResize windowChanged) $ + withInputProcessing termios cursorPosition events $ + action LocalTerminal + { localType = term + , localEvent = do + changed <- swapTVar windowChanged False + if changed + then pure (WindowEvent WindowSizeChanged) + else takeTMVar events + , localInterrupt = swapTVar interrupt False >>= check >> pure Interrupt + , localGetCursorPosition = do + -- Empty the result variable. + atomically (void (takeTMVar cursorPosition) <|> pure ()) + -- Send cursor position report request. + Text.hPutStr IO.stdout (defaultEncode GetCursorPosition) + IO.hFlush IO.stdout + -- Wait for the result variable to be filled by the input processor. + atomically (takeTMVar cursorPosition) + } + where + handleResize :: TVar Bool -> IO () + handleResize windowChanged = + atomically (writeTVar windowChanged True) + -- This function is responsible for passing interrupt signals and + -- eventually throwing an exception to the main thread in case it + -- detects that the main thread is not serving its duty to process + -- interrupt signals. It does this by setting a flag each time an interrupt + -- occurs - if the flag is still set when a new interrupt occurs, it assumes + -- the main thread is not responsive. + handleInterrupt :: ThreadId -> TVar Bool -> IO () + handleInterrupt mainThread interrupt = do + unhandledInterrupt <- atomically (swapTVar interrupt True) + when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt) +specialChar :: Termios -> Modifiers -> Char -> Maybe Event +specialChar t mods = \case + c | c == termiosVERASE t -> Just $ KeyEvent BackspaceKey mods + | c == '\n' -> Just $ KeyEvent EnterKey mods + | c == '\t' -> Just $ KeyEvent TabKey mods + | c == '\b' -> Just $ KeyEvent DeleteKey mods + | c == '\SP' -> Just $ KeyEvent SpaceKey mods + | c == '\DEL' -> Just $ KeyEvent DeleteKey mods + | otherwise -> Nothing + withTermiosSettings :: (MonadIO m, MonadMask m) => (Termios -> m a) -> m a withTermiosSettings fma = bracket before after between where - before = liftIO $ do + before = liftIO do termios <- getTermios - let termios' = termios { termiosISIG = False, termiosICANON = False, termiosECHO = False } + let termios' = termios { termiosICANON = False, termiosECHO = False } setTermios termios' pure termios after = liftIO . setTermios @@ -82,89 +121,95 @@ withResizeHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a withResizeHandler handler = bracket installHandler restoreHandler . const where - installHandler = liftIO $ do + installHandler = liftIO do Conc.ensureIOManagerIsRunning oldHandler <- Conc.setHandler (#const SIGWINCH) (Just (const handler, Dyn.toDyn handler)) oldAction <- stg_sig_install (#const SIGWINCH) (#const STG_SIG_HAN) nullPtr pure (oldHandler,oldAction) - restoreHandler (oldHandler,oldAction) = liftIO $ do + restoreHandler (oldHandler,oldAction) = liftIO do void $ Conc.setHandler (#const SIGWINCH) oldHandler void $ stg_sig_install (#const SIGWINCH) oldAction nullPtr pure () -withOutputProcessing :: (MonadIO m, MonadMask m) => TMVar Text.Text -> TMVar () -> m a -> m a -withOutputProcessing output outputFlush = bracket - ( liftIO $ A.async run ) - ( liftIO . A.cancel ) . const +withInterruptHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a +withInterruptHandler handler = bracket installHandler restoreHandler . const where - run = forever $ atomically ((Just <$> takeTMVar output) `orElse` (takeTMVar outputFlush >> pure Nothing)) >>= \case - Nothing -> IO.hFlush IO.stdout - Just t -> Text.hPutStr IO.stdout t + installHandler = liftIO do + Conc.ensureIOManagerIsRunning + oldHandler <- Conc.setHandler (#const SIGINT) (Just (const handler, Dyn.toDyn handler)) + oldAction <- stg_sig_install (#const SIGINT) (#const STG_SIG_HAN) nullPtr + pure (oldHandler,oldAction) + restoreHandler (oldHandler,oldAction) = liftIO do + void $ Conc.setHandler (#const SIGINT) oldHandler + void $ stg_sig_install (#const SIGINT) oldAction nullPtr + pure () -withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> Termios -> TVar Bool -> TChan Event -> m a -> m a -withInputProcessing mainThread termios interrupt events = bracket - ( liftIO $ A.async run ) - ( liftIO . A.cancel ) . const - where - run :: IO () - run = forever $ do - IO.hGetChar handle >>= \case - c | c == termiosVINTR termios -> handleInterrupt c - | c == termiosVERASE termios -> atomically $ writeChar c >> writeKey BackspaceKey - | otherwise -> atomically $ writeChar c - writeFillCharacterAfterTimeout +withInputProcessing :: (MonadIO m, MonadMask m) => + Termios -> TMVar Position -> TMVar Event -> m a -> m a +withInputProcessing termios cursorPosition events = + bracket (liftIO $ A.async $ run decoder) (liftIO . A.cancel) . const + where + run :: Decoder -> IO () + run d = do + c <- IO.hGetChar IO.stdin + case feedDecoder d mempty c of + -- The decoder is not in final state. + -- There are sequences depending on timing (escape either is literal + -- escape or the beginning of a sequence). + -- This block evaluates whether more input is available within + -- a limited timespan. If this is the case it just recurses + -- with the decoder continuation. + -- Otherwise, a NUL character is fed in order to tell the decoder + -- that there is no more input belonging to the sequence. + Left d' -> IO.hWaitForInput IO.stdin timeoutMilliseconds >>= \case + True -> run d' + False -> case feedDecoder d' mempty '\NUL' of + Left d'' -> run d'' + Right evs -> do + forM_ evs writeEvent + run decoder + -- The decoder reached a final state. + -- All recognized events are appended to the event stream. + Right evs -> do + forM_ evs writeEvent + run decoder - handle :: IO.Handle - handle = IO.stdin - writeEvent :: Event -> STM () - writeEvent = writeTChan events - writeKey :: Key -> STM () - writeKey k = writeTChan events (KeyEvent k mempty) - writeChar :: Char -> STM () - writeChar c = writeTChan events (KeyEvent (CharKey c) mempty) - -- This function is responsible for passing interrupt events and - -- eventually throwing an exception to the main thread in case it - -- detects that the main thread is not serving its duty to process - -- interrupt events. It does this by setting a flag each time an interrupt - -- occurs - if the flag is still set when a new interrupt occurs, it assumes - -- the main thread is not responsive. - handleInterrupt :: Char -> IO () - handleInterrupt c = do - unhandledInterrupt <- liftIO (atomically $ writeChar c >> writeEvent InterruptEvent >> swapTVar interrupt True) - when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt) - -- This function first evaluates whether more input is immediately available. - -- If this is the case it just returns. Otherwise it registers interest in - -- the file descriptor and waits for either input becoming available or a timeout - -- to occur. When the timeout triggers, a NUL character is appended to the - -- event stream to enable subsequent decoders to unambigously decode all - -- cases without the need to take timing into consideration anymore. - writeFillCharacterAfterTimeout :: IO () - writeFillCharacterAfterTimeout = do - ready <- IO.hReady handle - unless ready $ bracket (threadWaitReadSTM (Fd 0)) snd $ \(inputAvailable,_)-> do - timeout <- registerDelay timeoutMicroseconds >>= \t-> pure (readTVar t >>= check) - atomically $ inputAvailable `orElse` (timeout >> writeChar '\NUL') - -- The timeout duration has been choosen as a tradeoff between correctness - -- (actual transmission or scheduling delays shall not be misinterpreted) and - -- responsiveness for a human user (50 ms are barely noticable, but 1000 ms are). - -- I.e. when the user presses the ESC key (as vim users sometimes do ;-) - -- it shall be reflected in the application behavior quite instantly and - -- certainly _before_ the user presses the next key (thereby assuming that the - -- user is not able to type more than 20 characters per second). - -- For escape sequences it shall also be taken into consideration that they are - -- usually transmitted and received as chunks. Only on very rare occasions (buffer - -- boundaries) it might happen that they are split right after the sequence - -- introducer. In a modern environment with virtual terminals there is good - -- reason to consider this more unlikely than a user that types so fast - -- that his input might be misinterpreted as an escape sequence. - timeoutMicroseconds :: Int - timeoutMicroseconds = 50000 + decoder :: Decoder + decoder = defaultDecoder (specialChar termios) -getWindowSize :: IO (Int, Int) + -- Adds events to the event stream and catches certain events + -- that require special treatment. + writeEvent :: Event -> IO () + writeEvent = \case + ev@(DeviceEvent (CursorPositionReport pos)) -> atomically do + -- One of the alternatives will succeed. + -- The second one is not strictly required but a fail safe in order + -- to never block in case the terminal sends a report without request. + putTMVar cursorPosition pos <|> void (swapTMVar cursorPosition pos) + putTMVar events ev + ev -> atomically (putTMVar events ev) + + -- The timeout duration has been choosen as a tradeoff between correctness + -- (actual transmission or scheduling delays shall not be misinterpreted) and + -- responsiveness for a human user (50 ms are barely noticable, but 1000 ms are). + -- I.e. when the user presses the ESC key (as vim users sometimes do ;-) + -- it shall be reflected in the application behavior quite instantly and + -- certainly _before_ the user presses the next key (thereby assuming that the + -- user is not able to type more than 20 characters per second). + -- For escape sequences it shall also be taken into consideration that they are + -- usually transmitted and received as chunks. Only on very rare occasions (buffer + -- boundaries) it might happen that they are split right after the sequence + -- introducer. In a modern environment with virtual terminals there is good + -- reason to consider this more unlikely than a user that types so fast + -- that his input might be misinterpreted as an escape sequence. + timeoutMilliseconds :: Int + timeoutMilliseconds = 50 + +getWindowSize :: IO Size getWindowSize = alloca $ \ptr-> unsafeIOCtl 0 (#const TIOCGWINSZ) ptr >>= \case - 0 -> peek ptr >>= \ws-> pure (fromIntegral $ wsRow ws, fromIntegral $ wsCol ws) + 0 -> peek ptr >>= \ws-> pure $ Size (fromIntegral $ wsRow ws) (fromIntegral $ wsCol ws) _ -> undefined getTermios :: IO Termios diff --git a/platform/windows/src/System/Terminal/Platform.hsc b/platform/windows/src/System/Terminal/Platform.hsc --- a/platform/windows/src/System/Terminal/Platform.hsc +++ b/platform/windows/src/System/Terminal/Platform.hsc @@ -1,27 +1,21 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module System.Terminal.Platform - ( withTerminal + ( LocalTerminal () + , withTerminal ) where +import Control.Applicative ((<|>)) import Control.Concurrent (ThreadId, myThreadId, forkIO) -import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) import Control.Concurrent.STM.TMVar -import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, swapTVar, writeTVar) +import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, readTVarIO, swapTVar, writeTVar) import qualified Control.Exception as E -import Control.Monad (forever, void, when, unless) +import Control.Monad (forM_, when, unless) import Control.Monad.Catch (MonadMask, bracket, bracket_) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.STM (STM, atomically, check, orElse) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad.STM (STM, atomically, check) import Data.Bits -import Data.Function (fix) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.Text as Text -import qualified Data.Text.IO as Text import qualified Data.Text.Encoding as Text import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) @@ -30,37 +24,59 @@ import qualified System.IO as IO import qualified System.IO.Error as IO -import qualified Control.Monad.Terminal.Input as T -import qualified Control.Monad.Terminal.Terminal as T +import System.Terminal.MonadInput +import System.Terminal.MonadScreen +import System.Terminal.Terminal +import System.Terminal.Decoder +import System.Terminal.Encoder #include "hs_terminal.h" -withTerminal :: (MonadIO m, MonadMask m) => (T.Terminal -> m a) -> m a +data LocalTerminal + = LocalTerminal + { localType :: BS.ByteString + , localEvent :: STM Event + , localInterrupt :: STM Interrupt + } + +instance Terminal LocalTerminal where + termType = localType + termEvent = localEvent + termInterrupt = localInterrupt + termCommand _ c = putText (defaultEncode c) + termFlush _ = pure () + termGetWindowSize _ = getConsoleWindowSize + termGetCursorPosition _ = getConsoleCursorPosition + +withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a withTerminal action = do - mainThread <- liftIO myThreadId - interrupt <- liftIO (newTVarIO False) - events <- liftIO newTChanIO - output <- liftIO newEmptyTMVarIO - outputFlush <- liftIO newEmptyTMVarIO - screenSize <- liftIO (newTVarIO =<< getConsoleScreenSize) - withConsoleModes $ - withOutputProcessing mainThread output outputFlush $ - withInputProcessing mainThread interrupt events screenSize $ action $ - T.Terminal { - T.termType = "xterm" -- They claim it behaves like xterm although this is certainly a bit ambituous. - , T.termInput = readTChan events - , T.termOutput = putTMVar output - , T.termInterrupt = swapTVar interrupt False >>= check - , T.termFlush = putTMVar outputFlush () - , T.termScreenSize = readTVar screenSize - , T.termSpecialChars = \case - '\r' -> Just $ T.KeyEvent T.EnterKey mempty - '\t' -> Just $ T.KeyEvent T.TabKey mempty - '\SP' -> Just $ T.KeyEvent T.SpaceKey mempty - '\b' -> Just $ T.KeyEvent T.BackspaceKey mempty - '\DEL' -> Just $ T.KeyEvent T.BackspaceKey mempty + mainThread <- liftIO myThreadId + interrupt <- liftIO (newTVarIO False) + windowChanged <- liftIO (newTVarIO False) + events <- liftIO newEmptyTMVarIO + withConsoleModes $ + withInputProcessing mainThread interrupt windowChanged events $ action $ LocalTerminal + { localType = "xterm" -- They claim it behaves like xterm although this is certainly a bit ambituous. + , localInterrupt = + swapTVar interrupt False >>= check >> pure Interrupt + , localEvent = do + changed <- swapTVar windowChanged False + if changed + then pure (WindowEvent WindowSizeChanged) + else takeTMVar events + } + +decoder0 :: Decoder +decoder0 = defaultDecoder f + where + f mods = \case + '\r' -> Just $ KeyEvent EnterKey mods + '\n' -> Just $ KeyEvent EnterKey mods + '\t' -> Just $ KeyEvent TabKey mods + '\b' -> Just $ KeyEvent BackspaceKey mods + '\SP' -> Just $ KeyEvent SpaceKey mods + '\DEL' -> Just $ KeyEvent BackspaceKey mods _ -> Nothing - } withConsoleModes :: (MonadIO m, MonadMask m) => m a -> m a withConsoleModes = bracket before after . const @@ -102,31 +118,6 @@ when (r == 0) $ E.throwIO (IO.userError "getConsoleOutputMode: not a tty?") peek ptr -withOutputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TMVar Text.Text -> TMVar () -> m a -> m a -withOutputProcessing mainThread output outputFlush ma = do - terminate <- liftIO (newTVarIO False) - terminated <- liftIO (newTVarIO False) - bracket_ - (liftIO $ forkIO $ run terminate terminated) - (liftIO (atomically (writeTVar terminate True) >> atomically (readTVar terminated >>= check))) ma - where - run :: TVar Bool -> TVar Bool -> IO () - run terminate terminated = - -- Synchronous exception will be rethrown to the main thread. - -- Asynchronous exceptions (apart from `E.AsyncException` thrown by the RTS) won't occur. - -- In all cases the thread finally writes `True` into the `terminated` variable. - (loop `E.catch` (\e-> E.throwTo mainThread (e:: E.SomeException))) `E.finally` atomically (writeTVar terminated True) - where - loop :: IO () - loop = do - x <- atomically $ (readTVar terminate >>= check >> pure Nothing) - `orElse` (Just . Just <$> takeTMVar output) - `orElse` (takeTMVar outputFlush >> pure (Just Nothing)) - case x of - Nothing -> pure () - Just Nothing -> IO.hFlush IO.stdout >> loop - Just (Just t) -> putText t >> loop - putText :: Text.Text -> IO () putText text = do -- First, flush everything that is in the regular output buffer. @@ -152,8 +143,8 @@ written <- peek ptrWritten when (written < len) (put (BS.drop (fromIntegral len * 2) bs) ptrWritten) -withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TChan T.Event -> TVar (Int,Int) -> m a -> m a -withInputProcessing mainThread interrupt events screenSize ma = do +withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TVar Bool -> TMVar Event -> m a -> m a +withInputProcessing mainThread interrupt windowChanged events ma = do terminate <- liftIO (newTVarIO False) terminated <- liftIO (newTVarIO False) bracket_ @@ -166,89 +157,106 @@ run :: TVar Bool -> IO () run terminate = do - latestScreenBufferInfo <- newTVarIO =<< getConsoleScreenBufferInfo - latestCharacter <- newTVarIO '\NUL' - latestMouseButton <- newTVarIO T.LeftMouseButton - fix $ \continue-> tryGetConsoleInputEvent >>= \case - -- `tryGetConsoleInputEvent` is a blocking system call. It cannot be interrupted, but - -- is guaranteed to return after at most 100ms. In this case it is checked whether - -- this thread shall either terminate or is allowed to continue. - -- This is cooperative multitasking to circumvent the limitations of IO on Windows. - Nothing -> do - shallTerminate <- atomically (readTVar terminate) - unless shallTerminate $ do - -- The NUL character is a replacement for timing based - -- escape sequence recognition and enables the escape sequence decoder - -- to reliably distinguish real escape key presses and escape sequences - -- from another. A NUL is added after each timeout potentially - -- terminating any ambiguous (escape) sequences. - atomically $ do - latest <- readTVar latestCharacter - when (latest /= '\NUL') $ do - writeTVar latestCharacter '\NUL' - writeTChan events (T.KeyEvent (T.CharKey '\NUL') mempty) - continue - Just ev -> (>> continue) $ case ev of - KeyEvent { ceCharKey = c, ceKeyDown = d, ceKeyModifiers = mods } - -- In virtual terminal mode, Windows actually sends Ctrl+C and there is no - -- way a non-responsive application can be killed from keyboard. - -- The solution is to catch this specific event and swap an STM interrupt flag. - -- If the old value is found to be True then it must at least be the second - -- time the user has pressed Ctrl+C _and_ the application was to busy to - -- to reset the interrupt flag in the meantime. In this specific case - -- an asynchronous `E.UserInterrupt` exception is thrown to the main thread - -- and either terminates the application or at least the current computation. - | c == '\ETX' && d -> do - unhandledInterrupt <- atomically $ do - writeTVar latestCharacter '\ETX' - writeTChan events T.InterruptEvent - swapTVar interrupt True - when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt) - -- When the character is ESC and the key is pressed down it might be - -- that the key is hold pressed. In this case a NUL has to be emitted - -- before emitting the ESC in order to signal that the previous ESC does - -- not introduce a sequence. - | c == '\ESC' && d -> atomically $ do - readTVar latestCharacter >>= \case - '\ESC' -> writeTChan events (T.KeyEvent (T.CharKey '\NUL') mempty) - _ -> writeTVar latestCharacter '\ESC' - writeTChan events (T.KeyEvent (T.CharKey '\ESC') mempty) - | d -> atomically $ do - writeTVar latestCharacter c - writeTChan events (T.KeyEvent (T.CharKey c) mods) - | otherwise -> pure () -- All other key events shall be ignored. - MouseEvent mouseEvent -> case mouseEvent of - T.MouseButtonPressed (r,c) btn -> atomically $ do - csbi <- readTVar latestScreenBufferInfo - writeTChan events $ T.MouseEvent $ T.MouseButtonPressed (r - srWindowTop csbi, c - srWindowLeft csbi) btn - writeTVar latestMouseButton btn - T.MouseButtonReleased (r,c) _ -> atomically $ do - csbi <- readTVar latestScreenBufferInfo - btn <- readTVar latestMouseButton - writeTChan events $ T.MouseEvent $ T.MouseButtonReleased (r - srWindowTop csbi, c - srWindowLeft csbi) btn - writeTChan events $ T.MouseEvent $ T.MouseButtonClicked (r - srWindowTop csbi, c - srWindowLeft csbi) btn - T.MouseButtonClicked (r,c) btn -> atomically $ do - csbi <- readTVar latestScreenBufferInfo - writeTChan events $ T.MouseEvent $ T.MouseButtonClicked (r - srWindowTop csbi, c - srWindowLeft csbi) btn - T.MouseWheeled (r,c) dir -> atomically $ do - csbi <- readTVar latestScreenBufferInfo - writeTChan events $ T.MouseEvent $ T.MouseWheeled (r - srWindowTop csbi, c - srWindowLeft csbi) dir - T.MouseMoved (r,c) -> atomically $ do - csbi <- readTVar latestScreenBufferInfo - writeTChan events $ T.MouseEvent $ T.MouseMoved (r - srWindowTop csbi, c - srWindowLeft csbi) - - WindowEvent wev -> case wev of - T.WindowSizeChanged _ -> do - csbi <- getConsoleScreenBufferInfo - atomically $ do - writeTVar latestScreenBufferInfo csbi - let sz = (srWindowBottom csbi - srWindowTop csbi + 1, srWindowRight csbi - srWindowLeft csbi + 1) - sz' <- swapTVar screenSize sz - -- Observation: Not every event is an actual change to the screen size. - -- Only real changes shall be passed. - when (sz /= sz') (writeTChan events $ T.WindowEvent $ T.WindowSizeChanged sz) - _ -> atomically $ writeTChan events $ T.WindowEvent wev - UnknownEvent x -> atomically $ writeTChan events (T.OtherEvent $ "Unknown console input event " ++ show x ++ ".") + latestScreenBufferInfo <- newTVarIO =<< getConsoleScreenBufferInfo + latestCharacter <- newTVarIO '\NUL' + latestMouseButton <- newTVarIO LeftMouseButton + latestWindowSize <- newTVarIO =<< getConsoleWindowSize + let continue :: Decoder -> IO () + continue decoder = do + shallTerminate <- readTVarIO terminate + unless shallTerminate (waitForEvents decoder) + pushEvent :: Event -> IO () + pushEvent ev = atomically do -- unblock when thread shall terminate + putTMVar events ev <|> (readTVar terminate >>= check) + waitForEvents :: Decoder -> IO () + waitForEvents decoder = tryGetConsoleInputEvent >>= \case + -- `tryGetConsoleInputEvent` is a blocking system call. It cannot be interrupted, but + -- is guaranteed to return after at most 100ms. In this case it is checked whether + -- this thread shall either terminate or is allowed to continue. + -- This is cooperative multitasking to circumvent the limitations of IO on Windows. + Nothing -> + -- The NUL character is a replacement for timing based + -- escape sequence recognition and enables the escape sequence decoder + -- to reliably distinguish real escape key presses and escape sequences + -- from another. A NUL is added after each timeout potentially + -- terminating any ambiguous (escape) sequences. + case feedDecoder decoder mempty '\NUL' of + Left decoder' -> continue decoder' + Right evs -> forM_ evs pushEvent >> continue decoder0 + Just ev -> case ev of + ConsoleKeyEvent { ceCharKey = c, ceKeyDown = d, ceKeyModifiers = mods } + -- In virtual terminal mode, Windows actually sends Ctrl+C and there is no + -- way a non-responsive application can be killed from keyboard. + -- The solution is to catch this specific event and swap an STM interrupt flag. + -- If the old value is found to be True then it must at least be the second + -- time the user has pressed Ctrl+C _and_ the application was to busy to + -- to reset the interrupt flag in the meantime. In this specific case + -- an asynchronous `E.UserInterrupt` exception is thrown to the main thread + -- and either terminates the application or at least the current computation. + | c == '\ETX' && d -> do + unhandledInterrupt <- atomically (swapTVar interrupt True) + when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt) + -- When the character is ESC and the key is pressed down it might be + -- that the key is hold pressed. In this case a NUL has to be emitted + -- before emitting the ESC in order to signal that the previous ESC does + -- not introduce a sequence. + | c == '\ESC' && d -> do + latest <- readTVarIO latestCharacter + case feedDecoder decoder mods (if latest == '\ESC' then '\NUL' else '\ESC') of + Left decoder' -> continue decoder' + Right evs -> forM_ evs pushEvent >> continue decoder0 + | d -> do + atomically (writeTVar latestCharacter c) + case feedDecoder decoder mods c of + Left decoder' -> continue decoder' + Right evs -> forM_ evs pushEvent >> continue decoder0 + | otherwise -> continue decoder -- All other key events shall be ignored. + ConsoleMouseEvent mouseEvent -> case mouseEvent of + MouseButtonPressed (Position r c) btn -> do + csbi <- readTVarIO latestScreenBufferInfo + atomically (writeTVar latestMouseButton btn) + let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1) + pushEvent $ MouseEvent $ MouseButtonPressed pos btn + continue decoder + MouseButtonReleased (Position r c) _ -> do + csbi <- readTVarIO latestScreenBufferInfo + btn <- readTVarIO latestMouseButton + let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1) + pushEvent $ MouseEvent $ MouseButtonReleased pos btn + pushEvent $ MouseEvent $ MouseButtonClicked pos btn + continue decoder + MouseButtonClicked (Position r c) btn -> do + csbi <- readTVarIO latestScreenBufferInfo + let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1) + pushEvent $ MouseEvent $ MouseButtonClicked pos btn + continue decoder + MouseWheeled (Position r c) dir -> do + csbi <- readTVarIO latestScreenBufferInfo + let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1) + pushEvent $ MouseEvent $ MouseWheeled pos dir + continue decoder + MouseMoved (Position r c) -> do + csbi <- readTVarIO latestScreenBufferInfo + let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1) + pushEvent $ MouseEvent $ MouseMoved pos + continue decoder + ConsoleWindowEvent wev -> case wev of + WindowSizeChanged -> do + sz <- readTVarIO latestWindowSize + sz' <- getConsoleWindowSize + -- Observation: Far more events than actual changes to the window size are + -- reported when resizing the window. Only pass actual changes. + when (sz /= sz') $ atomically do + writeTVar latestWindowSize sz' + writeTVar windowChanged True + continue decoder + _ -> do + pushEvent (WindowEvent wev) + continue decoder + ConsoleUnknownEvent x -> do + pushEvent (OtherEvent $ "Unknown console input event " ++ show x ++ ".") + continue decoder + continue decoder0 timeoutMillis :: CULong timeoutMillis = 100 @@ -271,68 +279,75 @@ 0 -> E.throwIO (IO.userError "getConsoleScreenBufferInfo: not a tty?") _ -> peek ptr -getConsoleScreenSize :: IO (Int, Int) -getConsoleScreenSize = do +getConsoleWindowSize :: IO Size +getConsoleWindowSize = do csbi <- getConsoleScreenBufferInfo - pure (srWindowBottom csbi - srWindowTop csbi + 1, srWindowRight csbi - srWindowLeft csbi + 1) + pure $ Size (srWindowBottom csbi - srWindowTop csbi + 1) (srWindowRight csbi - srWindowLeft csbi + 1) +getConsoleCursorPosition :: IO Position +getConsoleCursorPosition = do + sbi <- getConsoleScreenBufferInfo + pure $ Position (cpY sbi - srWindowTop sbi) (cpX sbi - srWindowLeft sbi) + data ConsoleInputEvent - = KeyEvent + = ConsoleKeyEvent { ceKeyDown :: Bool , ceCharKey :: Char - , ceKeyModifiers :: T.Modifiers + , ceKeyModifiers :: Modifiers } - | MouseEvent T.MouseEvent - | WindowEvent T.WindowEvent - | UnknownEvent WORD + | ConsoleMouseEvent MouseEvent + | ConsoleWindowEvent WindowEvent + | ConsoleUnknownEvent WORD deriving (Eq, Ord, Show) data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo - { srWindowLeft :: Int - , srWindowTop :: Int - , srWindowRight :: Int - , srWindowBottom :: Int + { srWindowLeft :: !Int + , srWindowTop :: !Int + , srWindowRight :: !Int + , srWindowBottom :: !Int + , cpX :: !Int + , cpY :: !Int } deriving (Eq, Ord, Show) -modifiersFromControlKeyState :: DWORD -> T.Modifiers +modifiersFromControlKeyState :: DWORD -> Modifiers modifiersFromControlKeyState dw = a $ b $ c $ d $ e mempty where - a = if (#const LEFT_ALT_PRESSED) .&. dw == 0 then id else mappend T.altKey - b = if (#const LEFT_CTRL_PRESSED) .&. dw == 0 then id else mappend T.ctrlKey - c = if (#const RIGHT_ALT_PRESSED) .&. dw == 0 then id else mappend T.altKey - d = if (#const RIGHT_CTRL_PRESSED) .&. dw == 0 then id else mappend T.ctrlKey - e = if (#const SHIFT_PRESSED) .&. dw == 0 then id else mappend T.shiftKey + a = if (#const LEFT_ALT_PRESSED) .&. dw == 0 then id else mappend altKey + b = if (#const LEFT_CTRL_PRESSED) .&. dw == 0 then id else mappend ctrlKey + c = if (#const RIGHT_ALT_PRESSED) .&. dw == 0 then id else mappend altKey + d = if (#const RIGHT_CTRL_PRESSED) .&. dw == 0 then id else mappend ctrlKey + e = if (#const SHIFT_PRESSED) .&. dw == 0 then id else mappend shiftKey instance Storable ConsoleInputEvent where sizeOf _ = (#size struct _INPUT_RECORD) alignment _ = (#alignment struct _INPUT_RECORD) peek ptr = peekEventType >>= \case - (#const KEY_EVENT) -> KeyEvent + (#const KEY_EVENT) -> ConsoleKeyEvent <$> (peek ptrKeyDown >>= \case { 0-> pure False; _-> pure True; }) <*> (toEnum . fromIntegral <$> peek ptrKeyUnicodeChar) <*> (modifiersFromControlKeyState <$> peek ptrKeyControlKeyState) - (#const MOUSE_EVENT) -> MouseEvent <$> do - pos <- peek ptrMousePositionX >>= \x-> peek ptrMousePositionY >>= \y-> pure (fromIntegral y, fromIntegral x) + (#const MOUSE_EVENT) -> ConsoleMouseEvent <$> do + pos <- peek ptrMousePositionX >>= \x-> peek ptrMousePositionY >>= \y-> pure $ Position (fromIntegral y) (fromIntegral x) btn <- peek ptrMouseButtonState peek ptrMouseEventFlags >>= \case - (#const MOUSE_MOVED) -> pure (T.MouseMoved pos) - (#const MOUSE_WHEELED) -> pure (T.MouseWheeled pos $ if btn .&. 0xff000000 > 0 then T.Downwards else T.Upwards) - (#const MOUSE_HWHEELED) -> pure (T.MouseWheeled pos $ if btn .&. 0xff000000 > 0 then T.Rightwards else T.Leftwards) + (#const MOUSE_MOVED) -> pure (MouseMoved pos) + (#const MOUSE_WHEELED) -> pure (MouseWheeled pos $ if btn .&. 0xff000000 > 0 then Downwards else Upwards) + (#const MOUSE_HWHEELED) -> pure (MouseWheeled pos $ if btn .&. 0xff000000 > 0 then Rightwards else Leftwards) _ -> case btn of - (#const FROM_LEFT_1ST_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed pos T.LeftMouseButton - (#const FROM_LEFT_2ND_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed pos T.OtherMouseButton - (#const FROM_LEFT_3RD_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed pos T.OtherMouseButton - (#const FROM_LEFT_4TH_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed pos T.OtherMouseButton - (#const RIGHTMOST_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed pos T.RightMouseButton - _ -> pure $ T.MouseButtonReleased pos T.OtherMouseButton + (#const FROM_LEFT_1ST_BUTTON_PRESSED) -> pure $ MouseButtonPressed pos LeftMouseButton + (#const FROM_LEFT_2ND_BUTTON_PRESSED) -> pure $ MouseButtonPressed pos OtherMouseButton + (#const FROM_LEFT_3RD_BUTTON_PRESSED) -> pure $ MouseButtonPressed pos OtherMouseButton + (#const FROM_LEFT_4TH_BUTTON_PRESSED) -> pure $ MouseButtonPressed pos OtherMouseButton + (#const RIGHTMOST_BUTTON_PRESSED) -> pure $ MouseButtonPressed pos RightMouseButton + _ -> pure $ MouseButtonReleased pos OtherMouseButton (#const FOCUS_EVENT) -> peek ptrFocus >>= \case - 0 -> pure $ WindowEvent T.WindowLostFocus - _ -> pure $ WindowEvent T.WindowGainedFocus + 0 -> pure $ ConsoleWindowEvent WindowLostFocus + _ -> pure $ ConsoleWindowEvent WindowGainedFocus (#const WINDOW_BUFFER_SIZE_EVENT) -> - pure $ WindowEvent $ T.WindowSizeChanged (0,0) - evt -> pure (UnknownEvent evt) + pure $ ConsoleWindowEvent WindowSizeChanged + evt -> pure (ConsoleUnknownEvent evt) where peekEventType = (#peek struct _INPUT_RECORD, EventType) ptr :: IO WORD ptrEvent = castPtr $ (#ptr struct _INPUT_RECORD, Event) ptr :: Ptr a @@ -355,13 +370,18 @@ <*> peek' ptrSrWindowTop <*> peek' ptrSrWindowRight <*> peek' ptrSrWindowBottom + <*> peek' ptrDwCursorPositionX + <*> peek' ptrDwCursorPositionY where - peek' x = fromIntegral <$> peek x - ptrSrWindow = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, srWindow) ptr :: Ptr a - ptrSrWindowLeft = (#ptr struct _SMALL_RECT, Left) ptrSrWindow :: Ptr SHORT - ptrSrWindowTop = (#ptr struct _SMALL_RECT, Top) ptrSrWindow :: Ptr SHORT - ptrSrWindowRight = (#ptr struct _SMALL_RECT, Right) ptrSrWindow :: Ptr SHORT - ptrSrWindowBottom = (#ptr struct _SMALL_RECT, Bottom) ptrSrWindow :: Ptr SHORT + peek' x = fromIntegral <$> peek x + ptrSrWindow = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, srWindow) ptr :: Ptr a + ptrSrWindowLeft = (#ptr struct _SMALL_RECT, Left) ptrSrWindow :: Ptr SHORT + ptrSrWindowTop = (#ptr struct _SMALL_RECT, Top) ptrSrWindow :: Ptr SHORT + ptrSrWindowRight = (#ptr struct _SMALL_RECT, Right) ptrSrWindow :: Ptr SHORT + ptrSrWindowBottom = (#ptr struct _SMALL_RECT, Bottom) ptrSrWindow :: Ptr SHORT + ptrDwCursorPosition = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) ptr :: Ptr b + ptrDwCursorPositionX = (#ptr struct _COORD, X) ptrDwCursorPosition :: Ptr SHORT + ptrDwCursorPositionY = (#ptr struct _COORD, Y) ptrDwCursorPosition :: Ptr SHORT poke = undefined foreign import ccall "hs_wait_console_input" diff --git a/src/Control/Monad/Terminal.hs b/src/Control/Monad/Terminal.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Control.Monad.Terminal - ( -- * Getting started - -- ** TerminalT - TerminalT () - , runTerminalT - -- * Printing & Screen Modification - -- ** MonadPrinter - , MonadPrinter (..) - -- ** MonadPrettyPrinter - , MonadPrettyPrinter (..) - , pprint - -- ** MonadFormatPrinter - , MonadFormatPrinter (..) - -- ** MonadColorPrinter - , MonadColorPrinter (..) - , dull - , bright - , BasicColor (..) - , Color (..) - , ColorMode (..) - -- ** MonadTerminal - , MonadTerminal (..) - -- * Event Processing - -- ** MonadInput - , MonadInput (..) - -- *** waitEvent - , waitEvent - -- *** waitEventOrElse - , waitEventOrElse - -- *** waitInterruptOrElse - , waitInterruptOrElse - -- ** Events - , Event (..) - -- *** Keys & Modifiers - , Key (..) - , Direction (..) - , Modifiers () - , shiftKey - , ctrlKey - , altKey - , metaKey - -- *** Mouse Events - , MouseEvent (..) - , MouseButton (..) - -- *** Window Events - , WindowEvent (..) - -- *** Device Events - , DeviceEvent (..) - -- * Low-Level - -- ** Terminal - , Terminal (..) - -- ** Decoding - , Decoder (..) - , ansiDecoder - ) where - -import Control.Monad.Terminal.Decoder -import Control.Monad.Terminal.Input -import Control.Monad.Terminal.Monad -import Control.Monad.Terminal.Printer -import Control.Monad.Terminal.Terminal -import Control.Monad.Terminal.TerminalT diff --git a/src/Control/Monad/Terminal/Decoder.hs b/src/Control/Monad/Terminal/Decoder.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/Decoder.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -module Control.Monad.Terminal.Decoder where - -import Data.Char -import Data.Monoid ((<>)) - -import Control.Monad.Terminal.Input - --- | The type `Decoder` represents a finite state transducer. --- --- Values of this type can only be constructed by tying the knot --- which causes the resulting transducer to have one entry point --- but no exits. Intermediate state can be passed as closures. --- See below for an example. -newtype Decoder = Decoder { feedDecoder :: Modifiers -> Char -> ([Event], Decoder) } - -ansiDecoder :: (Char -> Maybe Event) -> Decoder -ansiDecoder specialChars = defaultMode - where - -- Make a production and return to `defaultMode`. - produce :: [Event] -> ([Event], Decoder) - produce es = (es, defaultMode) - -- Continue processing with the given decoder. - -- Shall be used for state/mode change. - continue :: Decoder -> ([Event], Decoder) - continue d = ([], d) - - -- The default mode is the decoder's entry point and is returned to - -- after each successful sequence decoding or as fail safe mode after - -- occurences of illegal state (this decoder shall skip errors and will - -- probably resynchronise on the input stream after a few characters). - defaultMode :: Decoder - defaultMode = Decoder $ \mods c-> if - -- In normal mode a NUL is interpreted as a fill character and skipped. - | c == '\NUL' -> produce [] - -- ESC might or might not introduce an escape sequence. - | c == '\ESC' -> continue escapeMode - -- All other C0 control codes are mapped to their corresponding ASCII character + CTRL modifier. - -- If the character is a special character, then two events are produced. - | c <= '\US' -> produce $ KeyEvent (CharKey (toEnum $ (+64) $ fromEnum c)) (mods <> ctrlKey) : specialKey mods c - -- Space shall be interpreted as control code and translated to `SpaceKey` to be - -- consistent with the handling of `TabKey` and other whitespaces. - | c == '\SP' -> produce [KeyEvent SpaceKey mods] - -- All remaning characters of the Latin-1 block are returned as is. - | c < '\DEL' -> produce [KeyEvent (CharKey c) mods] - -- DEL is a very delicate case. It might be `KeyBackspace` or `KeyDelete`. - | c == '\DEL' -> produce $ KeyEvent (CharKey '?') (mods <> ctrlKey) : specialKey mods c - -- Skip all other C1 control codes excpect if they are special characters. - | c < '\xA0' -> produce $ specialKey mods c - -- All other Unicode characters are returned as is. - | otherwise -> produce $ KeyEvent (CharKey c) mods : specialKey mods c - where - specialKey mods c = case specialChars c of - Nothing -> [] - Just ev -> case ev of - KeyEvent key m -> [KeyEvent key (mods <> m)] - _ -> [ev] - - -- This function shall be called if an ESC has been read in default mode - -- and it is stil unclear whether this is the beginning of an escape sequence or not. - -- NOTE: This function is total and consumes at least one more character of input. - escapeMode :: Decoder - escapeMode = Decoder $ \mods c-> if - -- Single escape key press is always followed by a NUL fill character - -- by design (instead of timing). This makes reasoning and testing much easier - -- and reliable. - | c == '\NUL' -> produce [KeyEvent (CharKey '[') (mods <> ctrlKey), KeyEvent EscapeKey mods] - | otherwise -> continue (escapeSequenceMode c) - - -- This function shall be called with the escape sequence introducer. - -- It needs to look at next character to decide whether this is - -- a CSI sequence or an ALT-modified key or illegal state. - escapeSequenceMode :: Char -> Decoder - escapeSequenceMode c = Decoder $ \mods d-> if - | d == '\NUL' && c > '\SP' && c <= '~' -> produce [KeyEvent (CharKey c) (mods <> altKey)] - | d == '\NUL' && c >= '\xa0' -> produce [KeyEvent (CharKey c) (mods <> altKey)] - | d == '\NUL' -> produce $ case specialChars c of - Nothing -> [] - Just ev -> case ev of - KeyEvent key m -> [KeyEvent key (mods <> m <> altKey)] - _ -> [ev] - | c == 'O' -> produce (ss3Mode mods d) - | c == '[' -> csiMode d - | otherwise -> produce [] - - -- SS3 mode is another less well-known escape sequence mode. - -- It is introduced by `\\ESCO`. Some terminal emulators use it for - -- compatibility with veeery old terminals. SS3 mode only allows one - -- subsequent character. Interpretation has been determined empirically - -- and with reference to http://rtfm.etla.org/xterm/ctlseq.html - ss3Mode :: Modifiers -> Char -> [Event] - ss3Mode mods = \case - 'P' -> [KeyEvent (FunctionKey 1) mods] - 'Q' -> [KeyEvent (FunctionKey 2) mods] - 'R' -> [KeyEvent (FunctionKey 3) mods] - 'S' -> [KeyEvent (FunctionKey 4) mods] - _ -> [] - - -- ESC[ is followed by any number (including none) of parameter chars in the - -- range 0–9:;<=>?, then by any number of intermediate chars - -- in the range space and !"#$%&'()*+,-./, then finally by a single char in - -- the range @A–Z[\]^_`a–z{|}~. - -- For security reasons (untrusted input and denial of service) this parser - -- only accepts a very limited number of characters for both parameter and - -- intermediate chars. - -- Unknown (not illegal) sequences are dropped, but it is guaranteed that - -- they will be consumed completely and it is safe for the parser to - -- return to normal mode afterwards. Illegal sequences cause the parser - -- to consume the input up to the first violating character and then reject. - -- The parser might be out of sync afterwards, but this is a protocol - -- violation anyway. The parser's only job here is not to loop (consume - -- and drop the illegal input!) and then to stop and fail reliably. - csiMode :: Char -> ([Event], Decoder) - csiMode c - | c >= '0' && c <= '?' = continue $ f (charLimit - 1) [c] - | c >= '!' && c <= '/' = continue $ g (charLimit - 1) [] [c] - | c >= '@' && c <= '~' = produce $ interpretCSI [] [] c - | otherwise = produce [] -- Illegal state. Return to default mode. - where - charLimit :: Int - charLimit = 16 - -- Note: The following functions use recursion, but recursion is - -- guaranteed to terminate and maximum recursion depth is only - -- dependant on the constant `charLimit`. In case of errors the decoder - -- will therefore recover to default mode after at most 32 characters. - f :: Int -> String -> Decoder - f 0 _ = defaultMode - f i ps = Decoder $ const $ \x-> if - | x >= '0' && x <= '?' -> continue $ f (i - 1) (x:ps) -- More parameters. - | x >= '!' && x <= '/' -> continue $ g charLimit ps [] -- Start of intermediates. - | x >= '@' && x <= '~' -> produce $ interpretCSI (reverse ps) [] x - | otherwise -> produce [] -- Illegal state. Return to default mode. - g :: Int -> String -> String -> Decoder - g 0 _ _ = defaultMode - g i ps is = Decoder $ const $ \x-> if - | x >= '!' && x <= '/' -> continue $ g (i - 1) ps (x:is) -- More intermediates. - | x >= '@' && x <= '~' -> produce $ interpretCSI (reverse ps) (reverse is) x - | otherwise -> produce [] -- Illegal state. Return to default mode. - -interpretCSI :: String -> String -> Char -> [Event] -interpretCSI params _intermediates = \case - '$' -> [KeyEvent DeleteKey (altKey `mappend` shiftKey)] -- urxvt, gnome-terminal - '@' -> [] - 'A' -> modified $ ArrowKey Upwards - 'B' -> modified $ ArrowKey Downwards - 'C' -> modified $ ArrowKey Rightwards - 'D' -> modified $ ArrowKey Leftwards - 'E' -> modified BeginKey - 'F' -> modified EndKey - 'G' -> [] - 'H' -> modified HomeKey - 'I' -> modified TabKey - 'J' -> [] - 'K' -> [] - 'L' -> [] - 'M' -> [] - 'N' -> [] - 'O' -> [] - 'P' -> modified (FunctionKey 1) - 'Q' -> modified (FunctionKey 2) - -- This sequence is ambiguous. xterm and derivatives use this to encode a modified F3 key as - -- well as a cursor position report. There is no real solution to disambiguate these two - -- other than context of expectation (cursor position report has probably been requested). - -- This decoder shall simply emit both events and the user shall ignore unexpected events. - 'R' -> modified (FunctionKey 3) ++ [DeviceEvent $ CursorPositionReport (fstNumber 1 - 1, sndNumber 1 - 1)] - 'S' -> modified (FunctionKey 4) - 'T' -> [] - 'U' -> [] - 'V' -> [] - 'W' -> [] - 'X' -> [] - 'Y' -> [] - 'Z' -> [KeyEvent TabKey shiftKey] - '^' -> case params of - "2" -> [KeyEvent InsertKey ctrlKey] - "3" -> [KeyEvent DeleteKey ctrlKey] - "4" -> [KeyEvent PageUpKey ctrlKey] - "7" -> [KeyEvent PageDownKey ctrlKey] - "5" -> [KeyEvent HomeKey ctrlKey] - "6" -> [KeyEvent EndKey ctrlKey] - "11" -> [KeyEvent (FunctionKey 1) ctrlKey] - "12" -> [KeyEvent (FunctionKey 2) ctrlKey] - "13" -> [KeyEvent (FunctionKey 3) ctrlKey] - "14" -> [KeyEvent (FunctionKey 4) ctrlKey] - "15" -> [KeyEvent (FunctionKey 5) ctrlKey] - "17" -> [KeyEvent (FunctionKey 6) ctrlKey] - "18" -> [KeyEvent (FunctionKey 7) ctrlKey] - "19" -> [KeyEvent (FunctionKey 8) ctrlKey] - "20" -> [KeyEvent (FunctionKey 9) ctrlKey] - "21" -> [KeyEvent (FunctionKey 10) ctrlKey] - "23" -> [KeyEvent (FunctionKey 11) ctrlKey] - "24" -> [KeyEvent (FunctionKey 12) ctrlKey] - _ -> [] - 'f' -> [] - 'i' -> [KeyEvent PrintKey mempty] - 'm' -> [] - '~' -> case fstParam of - "2" -> modified InsertKey - "3" -> modified DeleteKey - "5" -> modified PageUpKey - "6" -> modified PageDownKey - "9" -> modified HomeKey - "10" -> modified EndKey - "11" -> modified (FunctionKey 1) - "12" -> modified (FunctionKey 2) - "13" -> modified (FunctionKey 3) - "14" -> modified (FunctionKey 4) - "15" -> modified (FunctionKey 5) - "17" -> modified (FunctionKey 6) - "18" -> modified (FunctionKey 7) - "19" -> modified (FunctionKey 8) - "20" -> modified (FunctionKey 9) - "21" -> modified (FunctionKey 10) - "23" -> modified (FunctionKey 11) - "24" -> modified (FunctionKey 12) - _ -> [] - _ -> [] - where - fstParam :: String - fstParam = takeWhile (/= ';') params - sndParam :: String - sndParam = takeWhile (/= ';') $ drop 1 $ dropWhile (/= ';') params - fstNumber :: Int -> Int - fstNumber i - | not (null fstParam) && all isDigit fstParam = read fstParam - | otherwise = i - sndNumber :: Int -> Int - sndNumber i - | not (null sndParam) && all isDigit sndParam = read sndParam - | otherwise = i - modified key = case sndParam of - "" -> [KeyEvent key mempty ] - "2" -> [KeyEvent key shiftKey ] - "3" -> [KeyEvent key altKey ] - "4" -> [KeyEvent key $ shiftKey <> altKey ] - "5" -> [KeyEvent key ctrlKey] - "6" -> [KeyEvent key $ shiftKey <> ctrlKey] - "7" -> [KeyEvent key $ altKey <> ctrlKey] - "8" -> [KeyEvent key $ shiftKey <> altKey <> ctrlKey] - _ -> [] diff --git a/src/Control/Monad/Terminal/Input.hs b/src/Control/Monad/Terminal/Input.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/Input.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -module Control.Monad.Terminal.Input where - -import Control.Monad.IO.Class -import Control.Monad.STM -import Data.Bits -import Data.List - --- | This monad describes an environment that maintains a stream of `Event`s --- and offers out-of-band signaling for interrupts. --- --- * An interrupt shall occur if the user either presses CTRL+C --- or any other mechanism the environment designates for that purpose. --- * Implementations shall maintain an interrupt flag that is set --- when an interrupt occurs. Computations in this monad shall check and --- reset this flag regularly. If the execution environment finds this --- flag still set when trying to signal another interrupt, it shall --- throw `Control.Exception.AsyncException.UserInterrupt` to the --- seemingly unresponsive computation. --- * When an interrupt is signaled through the flag, an `Event.InterruptEvent` --- must be added to the event stream in the same transaction. --- This allows to flush all unprocessed events from the stream that --- occured before the interrupt. -class (MonadIO m) => MonadInput m where - -- | Wait for the next interrupt or the next event transformed by a given mapper. - -- - -- * The first mapper parameter is a transaction that succeeds as - -- soon as the interrupt flag gets set. Executing this transaction - -- resets the interrupt flag. If the interrupt flag is not reset - -- before a second interrupt occurs, the current thread shall - -- receive an `Control.Exception.AsyncException.UserInterrupt`. - -- * The second mapper parameter is a transaction that succeeds as - -- as soon as the next event arrives and removes that event from the - -- stream of events. It may be executed several times within the same - -- transaction, but might not succeed every time. - waitMapInterruptAndEvents :: (STM () -> STM Event -> STM a) -> m a - --- | Wait for the next event. --- --- * Returns as soon as an event occurs. --- * This operation resets the interrupt flag it returns, --- signaling responsiveness to the execution environment. --- * `Event.InterruptEvent`s occur in the event stream at their correct --- position wrt to ordering of events. They are returned as regular --- events. This is eventually not desired when trying to handle interrupts --- with highest priority and `waitInterruptOrElse` should be considered then. -waitEvent :: MonadInput m => m Event -waitEvent = waitMapInterruptAndEvents $ \intr evs-> - (intr `orElse` pure ()) >> evs - --- | Wait simultaneously for the next event or a given transaction. --- --- * Returns as soon as either an event occurs or the given transaction --- succeeds. --- * This operation resets the interrupt flag whenever it returns, --- signaling responsiveness to the execution environment. --- * `Event.InterruptEvent`s occur in the event stream at their correct --- position wrt to ordering of events. They are returned as regular --- events. This is eventually not desired when trying to handle interrupts --- with highest priority and `waitInterruptOrElse` should be considered then. -waitEventOrElse :: MonadInput m => STM a -> m (Either Event a) -waitEventOrElse stma = waitMapInterruptAndEvents $ \intr evs-> - (intr `orElse` pure ()) >> ((Prelude.Left <$> evs) `orElse` (Prelude.Right <$> stma)) - --- | Wait simultaneously for the next interrupt or a given transaction. --- --- * Returns `Nothing` on interrupt and `Just` when the supplied transaction --- succeeds first. --- * This operation resets the interrupt flag, signaling responsiveness --- to the execution environment. --- * All pending events up to and including the `InterruptEvent` are flushed --- from the event stream in case of an interrupt. -waitInterruptOrElse :: MonadInput m => STM a -> m (Maybe a) -waitInterruptOrElse stma = waitMapInterruptAndEvents $ \intr evs-> - (intr >> dropTillInterruptEvent evs >> pure Nothing) `orElse` (Just <$> stma) - where - dropTillInterruptEvent :: STM Event -> STM () - dropTillInterruptEvent evs = ((Just <$> evs) `orElse` pure Nothing) >>= \case - Nothing -> pure () - Just InterruptEvent -> pure () - _ -> dropTillInterruptEvent evs - -data Key - = CharKey Char - | TabKey - | SpaceKey - | BackspaceKey - | EnterKey - | InsertKey - | DeleteKey - | HomeKey -- ^ Pos 1 - | BeginKey - | EndKey - | PageUpKey - | PageDownKey - | EscapeKey - | PrintKey - | PauseKey - | ArrowKey Direction - | FunctionKey Int - deriving (Eq,Ord,Show) - -newtype Modifiers = Modifiers Int - deriving (Eq, Ord, Bits) - -instance Semigroup Modifiers where - Modifiers a <> Modifiers b = Modifiers (a .|. b) - -instance Monoid Modifiers where - mempty = Modifiers 0 - -instance Show Modifiers where - show (Modifiers 0) = "mempty" - show (Modifiers 1) = "shiftKey" - show (Modifiers 2) = "ctrlKey" - show (Modifiers 4) = "altKey" - show (Modifiers 8) = "metaKey" - show i = "(" ++ intercalate " <> " ls ++ ")" - where - ls = foldl (\acc x-> if x .&. i /= mempty then show x:acc else acc) [] - [metaKey, altKey, ctrlKey, shiftKey] - -shiftKey, ctrlKey, altKey, metaKey :: Modifiers -shiftKey = Modifiers 1 -ctrlKey = Modifiers 2 -altKey = Modifiers 4 -metaKey = Modifiers 8 - -data Event - = KeyEvent Key Modifiers - | MouseEvent MouseEvent - | WindowEvent WindowEvent - | DeviceEvent DeviceEvent - | InterruptEvent - | OtherEvent String - deriving (Eq,Ord,Show) - -data MouseEvent - = MouseMoved (Int,Int) - | MouseButtonPressed (Int,Int) MouseButton - | MouseButtonReleased (Int,Int) MouseButton - | MouseButtonClicked (Int,Int) MouseButton - | MouseWheeled (Int,Int) Direction - deriving (Eq,Ord,Show) - -data MouseButton - = LeftMouseButton - | RightMouseButton - | OtherMouseButton - deriving (Eq,Ord,Show) - -data Direction - = Upwards - | Downwards - | Leftwards - | Rightwards - deriving (Eq,Ord,Show) - -data WindowEvent - = WindowLostFocus - | WindowGainedFocus - | WindowSizeChanged (Int,Int) - deriving (Eq, Ord, Show) - -data DeviceEvent - = DeviceAttributesReport String - | CursorPositionReport (Int,Int) - deriving (Eq, Ord, Show) diff --git a/src/Control/Monad/Terminal/Monad.hs b/src/Control/Monad/Terminal/Monad.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/Monad.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Control.Monad.Terminal.Monad where - -import Control.Monad.Terminal.Input -import Control.Monad.Terminal.Printer - -class (MonadInput m, MonadPrettyPrinter m, MonadFormatPrinter m, MonadColorPrinter m) => MonadTerminal m where - -- | Move the cursor `n` lines up. Do not change column. - moveCursorUp :: Int -> m () - -- | Move the cursor `n` lines down. Do not change column. - moveCursorDown :: Int -> m () - -- | Move the cursor `n` columns to the left. Do not change line. - moveCursorLeft :: Int -> m () - -- | Move the cursor `n` columns to the right. Do not change line. - moveCursorRight :: Int -> m () - -- | Get the current cursor position. `(0,0) is the upper left of the screen. - getCursorPosition :: m (Int, Int) - -- | Set the cursor position. `(0,0)` is the upper left of the screen. - setCursorPosition :: (Int,Int) -> m () - -- | Set the vertical cursor position to the `n`th line. Do not change column. - setCursorPositionVertical :: Int -> m () - -- | Set the horizontal cursor position to the `n`th column. Do not change line. - setCursorPositionHorizontal :: Int -> m () - -- | Save the current cursor position to be restored later by `restoreCursorPosition`. - saveCursorPosition :: m () - -- | Restore cursor to position previously saved by `saveCursorPosition`. - restoreCursorPosition :: m () - -- | Show the cursor. - showCursor :: m () - -- | Hide the cursor. - hideCursor :: m () - - -- | Clear the entire line containing the cursor. - clearLine :: m () - -- | Clear the line from cursor left. - clearLineLeft :: m () - -- | Clear the line from cursor right. - clearLineRight :: m () - -- | Clear the entire screen. - clearScreen :: m () - -- | Clear the screen above the cursor. - clearScreenAbove :: m () - -- | Clear the screen below the cursor. - clearScreenBelow :: m () - - getScreenSize :: m (Int,Int) - -- | Whether or not to use the alternate screen buffer. - -- - -- - The main screen buffer content is preserved and restored - -- when leaving the alternate screen screen buffer. - -- - The dimensions of the alternate screen buffer are - -- exactly those of the screen. - useAlternateScreenBuffer :: Bool -> m () - --- http://www.noah.org/python/pexpect/ANSI-X3.64.htm --- Erasing parts of the display (EL and ED) in the VT100 is performed thus: --- --- Erase from cursor to end of line Esc [ 0 K or Esc [ K --- Erase from beginning of line to cursor Esc [ 1 K --- Erase line containing cursor Esc [ 2 K --- Erase from cursor to end of screen Esc [ 0 J or Esc [ J --- Erase from beginning of screen to cursor Esc [ 1 J --- Erase entire screen Esc [ 2 J diff --git a/src/Control/Monad/Terminal/Printer.hs b/src/Control/Monad/Terminal/Printer.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/Printer.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Control.Monad.Terminal.Printer where - -import Data.Text -import Data.Text.Prettyprint.Doc - -import Prelude hiding (putChar) - --- | This class describes an environment that Unicode text can be printed to. --- This might either be file or a terminal. --- --- * Instances shall implement the concept of lines and line width. --- * Instances shall implement the concept of a carriage that can be --- set to the beginning of the next line. --- * It is assumed that the carriage automatically moves to the beginning --- of the next line if the end of the current line is reached. --- * Instances shall be Unicode aware or must at least be able to print --- a replacement character. --- * Implementations must be aware of infinite lazy `Prelude.String`s and --- long `Data.Text.Text`s. `String`s should be printed character wise as --- evaluating them might trigger exceptions at any point. Long text should --- be printed chunk wise in order to stay interruptible. --- * Implementations must not use an unbounded output buffer. Print operations --- shall block and be interruptible when the output buffer is full. --- * Instances shall not interpret any control characters but --- \\n (new line, as generated by `putLn`, and \\t (horizontal tabulator). --- * Especially escape sequences shall be filtered or at least defused --- by removing the leading \\ESC. Text formatting shall be done with the --- designated classes like `MonadPrettyPrinter`, `MonadFormatPrinter` --- and `MonadColorPrinter`. Allowing control sequences would cause a --- dependency on certain terminal types, but might also be an underrated --- security risk as modern terminals are highly programmable and should --- not be fed with untrusted input. -class Monad m => MonadPrinter m where - -- | Move the carriage to the beginning of the next line. - putLn :: m () - putLn = putChar '\n' - -- | Print a single printable character or one of the allowed control characters. - putChar :: Char -> m () - -- | Print a `String`. - putString :: String -> m () - putString = mapM_ putChar - -- | Print a `String` and an additional newline. - putStringLn :: String -> m () - putStringLn s = putString s >> putLn - -- | Print a `Text`. - putText :: Text -> m () - putText = putString . Data.Text.unpack - -- | Print a `Text` and an additional newline. - putTextLn :: Text -> m () - putTextLn = putStringLn . Data.Text.unpack - -- | Flush the output buffer and make the all previous output actually - -- visible after a reasonably short amount of time. - -- - -- * The operation may return before the buffer has actually been flushed. - flush :: m () - flush = pure () - -- | Get the current line width. - -- - -- * The operation may return the last known line width and may not be - -- completely precise when I/O is asynchronous. - -- * This operations shall not block too long and rather be called more - -- often in order to adapt to changes in line width. - getLineWidth :: m Int - {-# MINIMAL putChar, getLineWidth #-} - --- | This class is the foundation for all environments that allow --- annotated text and `Doc`uments to be printed to. --- --- * Prefer using the `Data.Text.Prettyprint.Doc` module and the --- `putDoc` operation whenever trying to print structured or --- formatted text as it automatically deals with nested annotations --- and the current line width. -class MonadPrinter m => MonadPrettyPrinter m where - -- | This associated type represents all possible annotations that are available - -- in the current environment. - -- - -- When writing polymorphic code against these monadic interfaces - -- the concrete instantiation of this type is usually unknown and class - -- instances are generally advised to not expose value constructors for - -- this type. - -- - -- Instead, subclasses like `MonadFormatPrinter` and `MonadColorPrinter` - -- offer abstract value constructors like `bold`, `underlined`, `inverted` - -- which are then given meaning by the concrete class instance. The - -- environment `Control.Monad.Terminal.Ansi.AnsiTerminalT` for example - -- implements all of these classes. - data Annotation m - -- | Print an annotated `Doc`. - -- - -- * This operation performs `resetAnnotations` on entry and on exit. - -- * This operation can deal with nested annotations (see example). - -- - -- Example: - -- - -- @ - -- {-# LANGUAGE OverloadedStrings #-} - -- import Control.Monad.Terminal - -- import Data.Text.Prettyprint.Doc - -- - -- printer :: (`MonadFormatPrinter` m, `MonadColorPrinter` m) => m () - -- printer = `putDoc` $ `annotate` (foreground $ `bright` `Blue`) "This is blue!" <> `line` - -- <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again") - -- - -- otherDoc :: (`MonadColorPrinter` m, `Annotation` m ~ ann) => `Doc` ann - -- otherDoc = `annotate` (`background` $ `dull` `Red`) " BOLD ON RED BACKGROUND " - -- @ - -- - -- Note the necessary unification of `Annotation` `m` and `ann` in the definition of `otherDoc`! - putDoc :: Doc (Annotation m) -> m () - -- | Like `putDoc` but adds an additional newline. - putDocLn :: Doc (Annotation m) -> m () - putDocLn doc = putDoc doc >> putLn - -- | Set an annotation so that it affects subsequent output. - setAnnotation :: Annotation m -> m () - setAnnotation _ = pure () - -- | Reset an annotation so that it does no longer affect subsequent output. - -- - -- * Binary attributes like `bold` or `underlined` shall just be reset to their opposite. - -- - -- * For non-binary attributes like colors all of their possible values shall be treated - -- as equal, so that - -- - -- @ - -- `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`foreground` $ `dull` `Red`) - -- @ - -- - -- results in the foreground color attribute reset afterwards whereas after - -- - -- @ - -- `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`background` $ `dull` `Red`) - -- @ - -- - -- the foreground color is still set as `bright` `Blue`. - -- - resetAnnotation :: Annotation m -> m () - resetAnnotation _ = pure () - -- | Reset all annotations to their default. - resetAnnotations :: m () - resetAnnotations = pure () - {-# MINIMAL putDoc, setAnnotation, resetAnnotation, resetAnnotations #-} - -pprint :: (MonadPrettyPrinter m, Pretty a) => a -> m () -pprint = putDocLn . pretty - --- | This class offers abstract constructors for text formatting --- annotations. -class MonadPrettyPrinter m => MonadFormatPrinter m where - -- | This annotation makes text appear __bold__. - bold :: Annotation m - -- | This annotation makes text appear /italic/. - italic :: Annotation m - -- | This annotation makes text appear underlined. - underlined :: Annotation m - --- | This class offers abstract value constructors for --- foreground and background coloring. -class MonadPrettyPrinter m => MonadColorPrinter m where - -- | This annotation swaps foreground and background color. - -- - -- * This operation is idempotent: Applying the annotation a second time - -- won't swap it back. Use `resetAnnotation` instead. - inverted :: Annotation m - -- | This annotation sets the __foreground__ color (the text color). - foreground :: Color -> Annotation m - -- | This annotation sets the __background__ color. - background :: Color -> Annotation m - -data Color = Color ColorMode BasicColor - deriving (Eq, Ord, Show) - -data ColorMode - = Dull - | Bright - deriving (Eq, Ord, Show) - -data BasicColor - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - deriving (Eq, Ord, Show) - -dull :: BasicColor -> Color -dull = Color Dull - -bright :: BasicColor -> Color -bright = Color Bright diff --git a/src/Control/Monad/Terminal/Terminal.hs b/src/Control/Monad/Terminal/Terminal.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/Terminal.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Control.Monad.Terminal.Terminal where - -import Control.Monad.STM -import Data.ByteString -import Data.Text - -import Control.Monad.Terminal.Input - -data Terminal - = Terminal - { -- | The terminal identification string usually extracted from the - -- environment variable `TERM`. Should contain values like `xterm` - -- or `rxvt-unicode`. - termType :: ByteString - -- | A stream of input events. The transaction will succeed as soon as the - -- next input event becomes available. - -- - -- Note: Trying to read more than one event within the same transaction - -- might be successfull, but might also lead to undesired behaviour as - -- the transaction will block until all of its preconditions are fulfilled. - -- Some form of `orElse` needs to be used in a correct way for reading - -- several events at once. - , termInput :: STM Event - -- | This transaction appends a piece of `Data.Text.Text` to the output buffer. - -- It shall block when the buffer exeeded its capacity - -- and unblock as soon as space becomes available again. - -- - -- Note: All implementations must limit the size of the output buffer or - -- the application is at risk of running out of memory when writing much - -- faster than the terminal can read. Using a `Control.Concurrent.STM.TMVar.TMVar` - -- as a buffer of size 1 is perfectly fine here. - , termOutput :: Text -> STM () - -- | This transaction succeeds as soon as an interrupt event occurs. - -- Executing the transaction shall reset an interrupt flag maintained - -- by a supervising background thread. - -- - -- It is mandatory to regularly check this transaction in order to signal - -- responsiveness to the background thread. The supervisor is otherwise - -- advised to terminate the program as soon as a second interrupt arrives. - -- - -- Note: This is a very low-level operation. Operations like `waitEvent`, - -- `waitEventOrElse` or `waitInterruptOrElse` are more convenient and do - -- this automatically. - , termInterrupt :: STM () - -- | This operations flushes the output buffer. Whether it blocks or - -- not until the buffer has actually been flushed shall be undefined - -- (there might be other buffers involved that cannot be force-flushed - -- so it is probably better to not give any guarantees here). - , termFlush :: STM () - -- | This transaction shall return the latest known screen size without - -- blocking. The first parameter denotes the number of rows and the - -- one the number of columns. - , termScreenSize :: STM (Int, Int) - , termSpecialChars :: Char -> Maybe Event - } diff --git a/src/Control/Monad/Terminal/TerminalT.hs b/src/Control/Monad/Terminal/TerminalT.hs deleted file mode 100644 --- a/src/Control/Monad/Terminal/TerminalT.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Control.Monad.Terminal.TerminalT - ( TerminalT () - , runTerminalT - ) -where - -import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TVar -import qualified Control.Exception as E -import Control.Monad (when) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.STM -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Data.Foldable (forM_) -import qualified Data.Text as Text -import qualified Data.Text.Prettyprint.Doc as PP - -import qualified Control.Monad.Terminal.Decoder as T -import qualified Control.Monad.Terminal.Input as T -import qualified Control.Monad.Terminal.Monad as T -import qualified Control.Monad.Terminal.Printer as T -import qualified Control.Monad.Terminal.Terminal as T - -newtype TerminalT m a - = TerminalT (ReaderT T.Terminal m a) - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) - -runTerminalT :: (MonadIO m, MonadMask m) => TerminalT m a -> T.Terminal -> m a -runTerminalT (TerminalT action) ansi = do - eventsChan <- liftIO newTChanIO - decoderVar <- liftIO $ newTVarIO $ T.ansiDecoder $ T.termSpecialChars ansi - runReaderT action ansi { T.termInput = nextEvent eventsChan decoderVar } - where - -- This function transforms the incoming raw event stream and sends - -- parts of it (all plain characters) through the ANSI decoder. - -- It does this in a transactional way whereas it is important that - -- each input event creates _at least one_ immediate output event. - -- This means: When feeding input characters to the decoder it - -- is necessary to emit one intermediate event after each character that - -- has been fed into the decoder. Otherwise the transaction - -- will fail and the actual modification to the decoder won't happen. - nextEvent eventsChan decoderVar = do - processRawEvent `orElse` pure () -- Even without a new raw event there might be events pending. - readTChan eventsChan - where - processRawEvent = T.termInput ansi >>= \case - T.KeyEvent (T.CharKey c) mods -> do - -- NB: This event is essential as it guarantees the whole transaction - -- to succeed by having at least one event in the `events` channel. - -- This information is also quite nice for debbuging. - writeTChan eventsChan (T.OtherEvent $ "ANSI decoder: Feeding character " ++ show c ++ ", modifiers " ++ show mods ++ ".") - -- Feed the decoder, save its new state and write its output to the - -- events chan (if any). - decoder <- readTVar decoderVar - let (ansiEvents, decoder') = T.feedDecoder decoder mods c - writeTVar decoderVar decoder' - forM_ ansiEvents (writeTChan eventsChan) - event -> writeTChan eventsChan event - -instance MonadTrans TerminalT where - lift = TerminalT . lift - -instance (MonadIO m) => T.MonadInput (TerminalT m) where - waitMapInterruptAndEvents f = TerminalT $ do - ansi <- ask - liftIO $ atomically $ f (T.termInterrupt ansi) (T.termInput ansi) - -instance (MonadIO m, MonadThrow m) => T.MonadPrinter (TerminalT m) where - putChar c = TerminalT $ do - ansi <- ask - when (safeChar c) $ - liftIO $ atomically $ T.termOutput ansi $! Text.singleton c - putString cs = TerminalT $ do - ansi <- ask - liftIO $ forM_ (filter safeChar cs) $ \c-> - atomically $ T.termOutput ansi $! Text.singleton c - putText t = TerminalT $ do - ansi <- ask - liftIO $ loop (atomically . T.termOutput ansi) (Text.filter safeChar t) - where - loop out t0 - | Text.null t0 = pure () - | otherwise = let (t1,t2) = Text.splitAt 80 t0 - in out t1 >> loop out t2 - flush = TerminalT $ do - ansi <- ask - liftIO $ atomically $ T.termFlush ansi - getLineWidth = snd <$> T.getScreenSize - -instance (MonadIO m, MonadThrow m) => T.MonadPrettyPrinter (TerminalT m) where - data Annotation (TerminalT m) - = Bold - | Italic - | Underlined - | Inverted - | Foreground T.Color - | Background T.Color deriving (Eq, Ord, Show) - putDocLn doc = T.putDoc doc >> T.putLn - putDoc doc = do - w <- T.getLineWidth - T.resetAnnotations - render [] (sdoc w) - T.resetAnnotations - T.flush - where - options w = PP.defaultLayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine w 1.0 } - sdoc w = PP.layoutSmart (options w) doc - oldFG [] = Nothing - oldFG (Foreground c:_) = Just c - oldFG (_:xs) = oldFG xs - oldBG [] = Nothing - oldBG (Background c:_) = Just c - oldBG (_:xs) = oldBG xs - render anns = \case - PP.SFail -> pure () - PP.SEmpty -> pure () - PP.SChar c ss -> T.putChar c >> render anns ss - PP.SText _ t ss -> T.putText t >> render anns ss - PP.SLine n ss -> T.putLn >> T.putText (Text.replicate n " ") >> render anns ss - PP.SAnnPush ann ss -> T.setAnnotation ann >> render (ann:anns) ss - PP.SAnnPop ss -> case anns of - [] -> render [] ss - (Bold :anns') - | Bold `elem` anns' -> pure () - | otherwise -> T.resetAnnotation Bold >> render anns' ss - (Italic :anns') - | Italic `elem` anns' -> pure () - | otherwise -> T.resetAnnotation Italic >> render anns' ss - (Underlined :anns') - | Underlined `elem` anns' -> pure () - | otherwise -> T.resetAnnotation Underlined >> render anns' ss - (Inverted :anns') - | Inverted `elem` anns' -> pure () - | otherwise -> T.resetAnnotation Inverted >> render anns' ss - (Foreground c :anns') -> case oldFG anns' of - Just d -> T.setAnnotation (Foreground d) >> render anns' ss - Nothing -> T.resetAnnotation (Foreground c) >> render anns' ss - (Background c :anns') -> case oldBG anns' of - Just d -> T.setAnnotation (Background d) >> render anns' ss - Nothing -> T.resetAnnotation (Background c) >> render anns' ss - - setAnnotation Bold = write "\ESC[1m" - setAnnotation Italic = pure () - setAnnotation Underlined = write "\ESC[4m" - setAnnotation Inverted = write "\ESC[7m" - setAnnotation (Foreground (T.Color T.Dull T.Black )) = write "\ESC[30m" - setAnnotation (Foreground (T.Color T.Dull T.Red )) = write "\ESC[31m" - setAnnotation (Foreground (T.Color T.Dull T.Green )) = write "\ESC[32m" - setAnnotation (Foreground (T.Color T.Dull T.Yellow )) = write "\ESC[33m" - setAnnotation (Foreground (T.Color T.Dull T.Blue )) = write "\ESC[34m" - setAnnotation (Foreground (T.Color T.Dull T.Magenta)) = write "\ESC[35m" - setAnnotation (Foreground (T.Color T.Dull T.Cyan )) = write "\ESC[36m" - setAnnotation (Foreground (T.Color T.Dull T.White )) = write "\ESC[37m" - setAnnotation (Foreground (T.Color T.Bright T.Black )) = write "\ESC[90m" - setAnnotation (Foreground (T.Color T.Bright T.Red )) = write "\ESC[91m" - setAnnotation (Foreground (T.Color T.Bright T.Green )) = write "\ESC[92m" - setAnnotation (Foreground (T.Color T.Bright T.Yellow )) = write "\ESC[93m" - setAnnotation (Foreground (T.Color T.Bright T.Blue )) = write "\ESC[94m" - setAnnotation (Foreground (T.Color T.Bright T.Magenta)) = write "\ESC[95m" - setAnnotation (Foreground (T.Color T.Bright T.Cyan )) = write "\ESC[96m" - setAnnotation (Foreground (T.Color T.Bright T.White )) = write "\ESC[97m" - setAnnotation (Background (T.Color T.Dull T.Black )) = write "\ESC[40m" - setAnnotation (Background (T.Color T.Dull T.Red )) = write "\ESC[41m" - setAnnotation (Background (T.Color T.Dull T.Green )) = write "\ESC[42m" - setAnnotation (Background (T.Color T.Dull T.Yellow )) = write "\ESC[43m" - setAnnotation (Background (T.Color T.Dull T.Blue )) = write "\ESC[44m" - setAnnotation (Background (T.Color T.Dull T.Magenta)) = write "\ESC[45m" - setAnnotation (Background (T.Color T.Dull T.Cyan )) = write "\ESC[46m" - setAnnotation (Background (T.Color T.Dull T.White )) = write "\ESC[47m" - setAnnotation (Background (T.Color T.Bright T.Black )) = write "\ESC[100m" - setAnnotation (Background (T.Color T.Bright T.Red )) = write "\ESC[101m" - setAnnotation (Background (T.Color T.Bright T.Green )) = write "\ESC[102m" - setAnnotation (Background (T.Color T.Bright T.Yellow )) = write "\ESC[103m" - setAnnotation (Background (T.Color T.Bright T.Blue )) = write "\ESC[104m" - setAnnotation (Background (T.Color T.Bright T.Magenta)) = write "\ESC[105m" - setAnnotation (Background (T.Color T.Bright T.Cyan )) = write "\ESC[106m" - setAnnotation (Background (T.Color T.Bright T.White )) = write "\ESC[107m" - resetAnnotation Bold = write "\ESC[22m" - resetAnnotation Italic = pure () - resetAnnotation Underlined = write "\ESC[24m" - resetAnnotation Inverted = write "\ESC[27m" - resetAnnotation (Foreground _) = write "\ESC[39m" - resetAnnotation (Background _) = write "\ESC[49m" - resetAnnotations = write "\ESC[m" - -instance (MonadIO m, MonadThrow m) => T.MonadFormatPrinter (TerminalT m) where - bold = Bold - italic = Italic - underlined = Underlined - -instance (MonadIO m, MonadThrow m) => T.MonadColorPrinter (TerminalT m) where - inverted = Inverted - foreground = Foreground - background = Background - -instance (MonadIO m, MonadThrow m) => T.MonadTerminal (TerminalT m) where - moveCursorUp i = write $ "\ESC[" <> Text.pack (show i) <> "A" - moveCursorDown i = write $ "\ESC[" <> Text.pack (show i) <> "B" - moveCursorLeft i = write $ "\ESC[" <> Text.pack (show i) <> "D" - moveCursorRight i = write $ "\ESC[" <> Text.pack (show i) <> "C" - getCursorPosition = do - write "\ESC[6n" - T.flush - waitForCursorPositionReport - where - -- Swallow all incoming events until either a cursor position report - -- arrives or an Interrupt event occurs. - -- An interrupt event will cause an `E.UserInterrupt` exception to be thrown. - waitForCursorPositionReport = T.waitEvent >>= \case - T.InterruptEvent -> throwM E.UserInterrupt - T.DeviceEvent (T.CursorPositionReport pos) -> pure pos - _ -> waitForCursorPositionReport - setCursorPosition (x,y) = write $ "\ESC[" <> Text.pack (show $ x + 1) <> ";" <> Text.pack (show $ y + 1) <> "H" - setCursorPositionVertical i = write $ "\ESC[" <> Text.pack (show $ i + 1) <> "d" - setCursorPositionHorizontal i = write $ "\ESC[" <> Text.pack (show $ i + 1) <> "G" - saveCursorPosition = write "\ESC7" - restoreCursorPosition = write "\ESC8" - showCursor = write "\ESC[?25h" - hideCursor = write "\ESC[?25l" - - clearLine = write "\ESC[2K" - clearLineLeft = write "\ESC[1K" - clearLineRight = write "\ESC[0K" - clearScreen = write "\ESC[2J" - clearScreenAbove = write "\ESC[1J" - clearScreenBelow = write "\ESC[0J" - - getScreenSize = TerminalT $ do - ansi <- ask - liftIO $ atomically $ T.termScreenSize ansi - - useAlternateScreenBuffer True = write "\ESC[?1049h" - useAlternateScreenBuffer False = write "\ESC[?1049l" - --- | See https://en.wikipedia.org/wiki/List_of_Unicode_characters -safeChar :: Char -> Bool -safeChar c - | c == '\n' = True -- Newline - | c == '\t' = True -- Horizontal tab - | c < '\SP' = False -- All other C0 control characters. - | c < '\DEL' = True -- Printable remainder of ASCII. Start of C1. - | c < '\xa0' = False -- C1 up to start of Latin-1. - | otherwise = True - -write :: (MonadIO m) => Text.Text -> TerminalT m () -write t = TerminalT $ do - ansi <- ask - liftIO $ atomically $ T.termOutput ansi t diff --git a/src/System/Terminal.hs b/src/System/Terminal.hs --- a/src/System/Terminal.hs +++ b/src/System/Terminal.hs @@ -1,14 +1,81 @@ module System.Terminal - ( Terminal (..) - , withTerminal + ( -- * Getting started + -- ** withTerminal + withTerminal + -- ** TerminalT + , runTerminalT + , TerminalT () + -- * Printing & Screen Modification + -- ** MonadPrinter + , MonadPrinter (..) + -- *** MonadMarkupPrinter + , MonadMarkupPrinter (..) + -- *** MonadFormattingPrinter + , MonadFormattingPrinter (..) + -- *** MonadColorPrinter + , MonadColorPrinter (..) + -- *** Pretty Printing + , putDoc + , putDocLn + , putPretty + , putPrettyLn + , putSimpleDocStream + -- ** MonadScreen + , MonadScreen (..) + , Size (..) + , Position (..) + , EraseMode (..) + -- ** MonadTerminal + , MonadTerminal + -- * Event Processing + , MonadInput (..) + -- *** awaitEvent + , awaitEvent + -- *** checkInterrupt + , checkInterrupt + -- ** Events + , Event (..) + , Interrupt (..) + -- *** Keys & Modifiers + , Key (..) + , Modifiers () + , shiftKey + , ctrlKey + , altKey + , metaKey + , Direction (..) + -- *** Mouse Events + , MouseEvent (..) + , MouseButton (..) + -- *** Window Events + , WindowEvent (..) + -- *** Device Events + , DeviceEvent (..) ) where -import Control.Monad.Catch (MonadMask) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Catch +import Control.Monad.IO.Class -import Control.Monad.Terminal -import qualified System.Terminal.Platform as Platform +import System.Terminal.MonadInput +import System.Terminal.MonadPrinter +import System.Terminal.MonadScreen +import System.Terminal.MonadTerminal +import System.Terminal.Pretty +import System.Terminal.TerminalT +import qualified System.Terminal.Platform --- | (Indirection just for upcoming documentation). -withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a -withTerminal = Platform.withTerminal +-- | Run the given handler with the locally connected terminal (`System.IO.stdin` / `System.IO.stdout`). +-- +-- @ +-- import System.Terminal +-- +-- main :: IO () +-- main = withTerminal $ `runTerminalT` do +-- `putTextLn` "Hello there, please press a button!" +-- `flush` +-- ev <- `waitEvent` +-- `putStringLn` $ "Event was " ++ show ev +-- `flush` +-- @ +withTerminal :: (MonadIO m, MonadMask m) => (System.Terminal.Platform.LocalTerminal -> m a) -> m a +withTerminal = System.Terminal.Platform.withTerminal diff --git a/src/System/Terminal/Decoder.hs b/src/System/Terminal/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Decoder.hs @@ -0,0 +1,218 @@ +module System.Terminal.Decoder where + +import Data.Char +import Data.Monoid ((<>)) + +import System.Terminal.MonadInput +import System.Terminal.MonadScreen (Position (..)) + +-- | The type `Decoder` is a finite state transducer. +-- +-- Intermediate state can be passed as closure. +-- See below for an example. +newtype Decoder = Decoder { feedDecoder :: Modifiers -> Char -> Either Decoder [Event] } + +defaultDecoder :: (Modifiers -> Char -> Maybe Event) -> Decoder +defaultDecoder specialChar = defaultMode + where + -- The default mode is the decoder's entry point. + defaultMode :: Decoder + defaultMode = Decoder $ \mods c-> if + -- In normal mode a NUL is interpreted as a fill character and skipped. + | c == '\NUL' -> Right [] + -- ESC might or might not introduce an escape sequence. + | c == '\ESC' -> Left escapeMode + -- All other C0 control codes are mapped to their corresponding ASCII character + CTRL modifier. + -- If the character is a special character, then two events are produced. + | c <= '\US' -> Right $ [KeyEvent (CharKey (toEnum $ (+64) $ fromEnum c)) (mods <> ctrlKey)] ++ f mods c + -- All remaning characters of the Latin-1 block are returned as is. + | c < '\DEL' -> Right $ [KeyEvent (CharKey c) mods] ++ f mods c + -- Skip all other C1 control codes and DEL unless they have special meaning configured. + | c < '\xA0' -> Right $ f mods c + -- All other Unicode characters are returned as is. + | otherwise -> Right [KeyEvent (CharKey c) mods] + where + f mods c = maybe [] pure (specialChar mods c) + + -- This function shall be called if an ESC has been read in default mode + -- and it is stil unclear whether this is the beginning of an escape sequence or not. + -- NOTE: This function is total and consumes at least one more character of input. + escapeMode :: Decoder + escapeMode = Decoder $ \mods c-> if + -- Single escape key press is always followed by a NUL fill character + -- by design (instead of timing). This makes reasoning and testing much easier + -- and reliable. + | c == '\NUL' -> Right [KeyEvent (CharKey '[') (mods <> ctrlKey), KeyEvent EscapeKey mods] + | otherwise -> Left (escapeSequenceMode c) + + -- This function shall be called with the escape sequence introducer. + -- It needs to look at next character to decide whether this is + -- a CSI sequence or an ALT-modified key or illegal state. + escapeSequenceMode :: Char -> Decoder + escapeSequenceMode c = Decoder $ \mods d-> if + | d == '\NUL' && c > '\SP' && c <= '~' -> Right [KeyEvent (CharKey c) (mods <> altKey)] + | d == '\NUL' && c >= '\xa0' -> Right [KeyEvent (CharKey c) (mods <> altKey)] + | d == '\NUL' -> Right $ case specialChar mods c of + Nothing -> [] + Just ev -> case ev of + KeyEvent key m -> [KeyEvent key (mods <> m <> altKey)] + _ -> [ev] + | c == 'O' -> Right (ss3Mode mods d) + | c == '[' -> csiMode d + | otherwise -> Right [] + + -- SS3 mode is another less well-known escape sequence mode. + -- It is introduced by `\\ESCO`. Some terminal emulators use it for + -- compatibility with veeery old terminals. SS3 mode only allows one + -- subsequent character. Interpretation has been determined empirically + -- and with reference to http://rtfm.etla.org/xterm/ctlseq.html + ss3Mode :: Modifiers -> Char -> [Event] + ss3Mode mods = \case + 'P' -> [KeyEvent (FunctionKey 1) mods] + 'Q' -> [KeyEvent (FunctionKey 2) mods] + 'R' -> [KeyEvent (FunctionKey 3) mods] + 'S' -> [KeyEvent (FunctionKey 4) mods] + _ -> [] + + -- ESC[ is followed by any number (including none) of parameter chars in the + -- range 0–9:;<=>?, then by any number of intermediate chars + -- in the range space and !"#$%&'()*+,-./, then finally by a single char in + -- the range @A–Z[\]^_`a–z{|}~. + -- For security reasons (untrusted input and denial of service) this parser + -- only accepts a very limited number of characters for both parameter and + -- intermediate chars. + -- Unknown (not illegal) sequences are dropped, but it is guaranteed that + -- they will be consumed completely and it is safe for the parser to + -- return to normal mode afterwards. Illegal sequences cause the parser + -- to consume the input up to the first violating character and then reject. + -- The parser might be out of sync afterwards, but this is a protocol + -- violation anyway. The parser's only job here is not to loop (consume + -- and drop the illegal input!) and then to stop and fail reliably. + csiMode :: Char -> Either Decoder [Event] + csiMode c + | c >= '0' && c <= '?' = Left $ f (charLimit - 1) [c] + | c >= '!' && c <= '/' = Left $ g (charLimit - 1) [] [c] + | c >= '@' && c <= '~' = Right $ interpretCSI [] [] c + | otherwise = Right [] -- Illegal state. Return to default mode. + where + charLimit :: Int + charLimit = 16 + -- Note: The following functions use recursion, but recursion is + -- guaranteed to terminate and maximum recursion depth is only + -- dependant on the constant `charLimit`. In case of errors the decoder + -- will therefore recover to default mode after at most 32 characters. + f :: Int -> String -> Decoder + f 0 _ = defaultMode + f i ps = Decoder $ const $ \x-> if + | x >= '0' && x <= '?' -> Left $ f (i - 1) (x:ps) -- More parameters. + | x >= '!' && x <= '/' -> Left $ g charLimit ps [] -- Start of intermediates. + | x >= '@' && x <= '~' -> Right $ interpretCSI (reverse ps) [] x + | otherwise -> Right [] -- Illegal state. Return to default mode. + g :: Int -> String -> String -> Decoder + g 0 _ _ = defaultMode + g i ps is = Decoder $ const $ \x-> if + | x >= '!' && x <= '/' -> Left $ g (i - 1) ps (x:is) -- More intermediates. + | x >= '@' && x <= '~' -> Right $ interpretCSI (reverse ps) (reverse is) x + | otherwise -> Right [] -- Illegal state. Return to default mode. + +interpretCSI :: String -> String -> Char -> [Event] +interpretCSI params _intermediates = \case + '$' -> [KeyEvent DeleteKey (altKey `mappend` shiftKey)] -- urxvt, gnome-terminal + '@' -> [] + 'A' -> modified $ ArrowKey Upwards + 'B' -> modified $ ArrowKey Downwards + 'C' -> modified $ ArrowKey Rightwards + 'D' -> modified $ ArrowKey Leftwards + 'E' -> modified BeginKey + 'F' -> modified EndKey + 'G' -> [] + 'H' -> modified HomeKey + 'I' -> modified TabKey + 'J' -> [] + 'K' -> [] + 'L' -> [] + 'M' -> [] + 'N' -> [] + 'O' -> [] + 'P' -> modified (FunctionKey 1) + 'Q' -> modified (FunctionKey 2) + -- This sequence is ambiguous. xterm and derivatives use this to encode a modified F3 key as + -- well as a cursor position report. There is no real solution to disambiguate these two + -- other than context of expectation (cursor position report has probably been requested). + -- This decoder shall simply emit both events and the user shall ignore unexpected events. + 'R' -> modified (FunctionKey 3) ++ [DeviceEvent $ CursorPositionReport $ Position (fstNumber 1 - 1) (sndNumber 1 - 1)] + 'S' -> modified (FunctionKey 4) + 'T' -> [] + 'U' -> [] + 'V' -> [] + 'W' -> [] + 'X' -> [] + 'Y' -> [] + 'Z' -> [KeyEvent TabKey shiftKey] + '^' -> case params of + "2" -> [KeyEvent InsertKey ctrlKey] + "3" -> [KeyEvent DeleteKey ctrlKey] + "4" -> [KeyEvent PageUpKey ctrlKey] + "7" -> [KeyEvent PageDownKey ctrlKey] + "5" -> [KeyEvent HomeKey ctrlKey] + "6" -> [KeyEvent EndKey ctrlKey] + "11" -> [KeyEvent (FunctionKey 1) ctrlKey] + "12" -> [KeyEvent (FunctionKey 2) ctrlKey] + "13" -> [KeyEvent (FunctionKey 3) ctrlKey] + "14" -> [KeyEvent (FunctionKey 4) ctrlKey] + "15" -> [KeyEvent (FunctionKey 5) ctrlKey] + "17" -> [KeyEvent (FunctionKey 6) ctrlKey] + "18" -> [KeyEvent (FunctionKey 7) ctrlKey] + "19" -> [KeyEvent (FunctionKey 8) ctrlKey] + "20" -> [KeyEvent (FunctionKey 9) ctrlKey] + "21" -> [KeyEvent (FunctionKey 10) ctrlKey] + "23" -> [KeyEvent (FunctionKey 11) ctrlKey] + "24" -> [KeyEvent (FunctionKey 12) ctrlKey] + _ -> [] + 'f' -> [] + 'i' -> [KeyEvent PrintKey mempty] + 'm' -> [] + '~' -> case fstParam of + "2" -> modified InsertKey + "3" -> modified DeleteKey + "5" -> modified PageUpKey + "6" -> modified PageDownKey + "9" -> modified HomeKey + "10" -> modified EndKey + "11" -> modified (FunctionKey 1) + "12" -> modified (FunctionKey 2) + "13" -> modified (FunctionKey 3) + "14" -> modified (FunctionKey 4) + "15" -> modified (FunctionKey 5) + "17" -> modified (FunctionKey 6) + "18" -> modified (FunctionKey 7) + "19" -> modified (FunctionKey 8) + "20" -> modified (FunctionKey 9) + "21" -> modified (FunctionKey 10) + "23" -> modified (FunctionKey 11) + "24" -> modified (FunctionKey 12) + _ -> [] + _ -> [] + where + fstParam :: String + fstParam = takeWhile (/= ';') params + sndParam :: String + sndParam = takeWhile (/= ';') $ drop 1 $ dropWhile (/= ';') params + fstNumber :: Int -> Int + fstNumber i + | not (null fstParam) && all isDigit fstParam = read fstParam + | otherwise = i + sndNumber :: Int -> Int + sndNumber i + | not (null sndParam) && all isDigit sndParam = read sndParam + | otherwise = i + modified key = case sndParam of + "" -> [KeyEvent key mempty ] + "2" -> [KeyEvent key shiftKey ] + "3" -> [KeyEvent key altKey ] + "4" -> [KeyEvent key $ shiftKey <> altKey ] + "5" -> [KeyEvent key ctrlKey] + "6" -> [KeyEvent key $ shiftKey <> ctrlKey] + "7" -> [KeyEvent key $ altKey <> ctrlKey] + "8" -> [KeyEvent key $ shiftKey <> altKey <> ctrlKey] + _ -> [] diff --git a/src/System/Terminal/Encoder.hs b/src/System/Terminal/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Encoder.hs @@ -0,0 +1,128 @@ +module System.Terminal.Encoder where + +import qualified Data.Text as T + +import System.Terminal.Terminal +import System.Terminal.MonadScreen + +-- | See https://en.wikipedia.org/wiki/List_of_Unicode_characters +safeChar :: Char -> Bool +safeChar c + | c < '\SP' = False -- All other C0 control characters. + | c < '\DEL' = True -- Printable remainder of ASCII. Start of C1. + | c < '\xa0' = False -- C1 up to start of Latin-1. + | otherwise = True +{-# INLINE safeChar #-} + +sanitizeChar :: Char -> Char +sanitizeChar c = if safeChar c then c else '�' +{-# INLINE sanitizeChar #-} + +sanitizeText :: T.Text -> T.Text +sanitizeText t + | T.any (not . safeChar) t = T.map sanitizeChar t + | otherwise = t +{-# INLINE sanitizeText #-} + +defaultEncode :: Command -> T.Text +defaultEncode = \case + PutLn -> "\n" + PutText t -> sanitizeText t + SetAttribute Bold -> "\ESC[1m" + SetAttribute Italic -> "" + SetAttribute Underlined -> "\ESC[4m" + SetAttribute Inverted -> "\ESC[7m" + SetAttribute (Foreground Black ) -> "\ESC[30m" + SetAttribute (Foreground Red ) -> "\ESC[31m" + SetAttribute (Foreground Green ) -> "\ESC[32m" + SetAttribute (Foreground Yellow ) -> "\ESC[33m" + SetAttribute (Foreground Blue ) -> "\ESC[34m" + SetAttribute (Foreground Magenta) -> "\ESC[35m" + SetAttribute (Foreground Cyan ) -> "\ESC[36m" + SetAttribute (Foreground White ) -> "\ESC[37m" + SetAttribute (Foreground BrightBlack ) -> "\ESC[90m" + SetAttribute (Foreground BrightRed ) -> "\ESC[91m" + SetAttribute (Foreground BrightGreen ) -> "\ESC[92m" + SetAttribute (Foreground BrightYellow ) -> "\ESC[93m" + SetAttribute (Foreground BrightBlue ) -> "\ESC[94m" + SetAttribute (Foreground BrightMagenta) -> "\ESC[95m" + SetAttribute (Foreground BrightCyan ) -> "\ESC[96m" + SetAttribute (Foreground BrightWhite ) -> "\ESC[97m" + SetAttribute (Background Black ) -> "\ESC[40m" + SetAttribute (Background Red ) -> "\ESC[41m" + SetAttribute (Background Green ) -> "\ESC[42m" + SetAttribute (Background Yellow ) -> "\ESC[43m" + SetAttribute (Background Blue ) -> "\ESC[44m" + SetAttribute (Background Magenta) -> "\ESC[45m" + SetAttribute (Background Cyan ) -> "\ESC[46m" + SetAttribute (Background White ) -> "\ESC[47m" + SetAttribute (Background BrightBlack ) -> "\ESC[100m" + SetAttribute (Background BrightRed ) -> "\ESC[101m" + SetAttribute (Background BrightGreen ) -> "\ESC[102m" + SetAttribute (Background BrightYellow ) -> "\ESC[103m" + SetAttribute (Background BrightBlue ) -> "\ESC[104m" + SetAttribute (Background BrightMagenta) -> "\ESC[105m" + SetAttribute (Background BrightCyan ) -> "\ESC[106m" + SetAttribute (Background BrightWhite ) -> "\ESC[107m" + ResetAttribute Bold -> "\ESC[22m" + ResetAttribute Italic -> "" + ResetAttribute Underlined -> "\ESC[24m" + ResetAttribute Inverted -> "\ESC[27m" + ResetAttribute (Foreground _) -> "\ESC[39m" + ResetAttribute (Background _) -> "\ESC[49m" + ResetAttributes -> "\ESC[m" + ShowCursor -> "\ESC[?25h" + HideCursor -> "\ESC[?25l" + SaveCursor -> "\ESC7" + RestoreCursor -> "\ESC8" + MoveCursorUp i | i <= 0 -> "" + | i == 0 -> "\ESC[A" + | otherwise -> "\ESC[" <> T.pack (show i) <> "A" + MoveCursorDown i | i <= 0 -> "" + | i == 0 -> "\ESC[B" + | otherwise -> "\ESC[" <> T.pack (show i) <> "B" + MoveCursorForward i | i <= 0 -> "" + | i == 0 -> "\ESC[C" + | otherwise -> "\ESC[" <> T.pack (show i) <> "C" + MoveCursorBackward i | i <= 0 -> "" + | i == 0 -> "\ESC[D" + | otherwise -> "\ESC[" <> T.pack (show i) <> "D" + GetCursorPosition -> "\ESC[6n" + SetCursorPosition (Position x y) -> "\ESC[" <> T.pack (show $ x + 1) <> ";" <> T.pack (show $ y + 1) <> "H" + SetCursorRow i -> "\ESC[" <> T.pack (show $ i + 1) <> "d" + SetCursorColumn i -> "\ESC[" <> T.pack (show $ i + 1) <> "G" + InsertChars i | i <= 0 -> "" + | i == 1 -> "\ESC[@" + | otherwise -> "\ESC[" <> T.pack (show i) <> "@" + DeleteChars i | i <= 0 -> "" + | i == 1 -> "\ESC[P" + | otherwise -> "\ESC[" <> T.pack (show i) <> "P" + EraseChars i | i <= 0 -> "" + | i == 1 -> "\ESC[X" + | otherwise -> "\ESC[" <> T.pack (show i) <> "X" + InsertLines i | i <= 0 -> "" + | i == 1 -> "\ESC[L" + | otherwise -> "\ESC[" <> T.pack (show i) <> "L" + DeleteLines i | i <= 0 -> "" + | i == 1 -> "\ESC[M" + | otherwise -> "\ESC[" <> T.pack (show i) <> "M" + EraseInLine EraseForward -> "\ESC[0K" + EraseInLine EraseBackward -> "\ESC[1K" + EraseInLine EraseAll -> "\ESC[2K" + EraseInDisplay EraseForward -> "\ESC[0J" + EraseInDisplay EraseBackward -> "\ESC[1J" + EraseInDisplay EraseAll -> "\ESC[2J" + SetAutoWrap True -> "\ESC[?7h" + SetAutoWrap False -> "\ESC[?7l" + SetAlternateScreenBuffer True -> "\ESC[?1049h" + SetAlternateScreenBuffer False -> "\ESC[?1049l" + +-- http://www.noah.org/python/pexpect/ANSI-X3.64.htm +-- Erasing parts of the display (EL and ED) in the VT100 is performed thus: +-- +-- Erase from cursor to end of line Esc [ 0 K or Esc [ K +-- Erase from beginning of line to cursor Esc [ 1 K +-- Erase line containing cursor Esc [ 2 K +-- Erase from cursor to end of screen Esc [ 0 J or Esc [ J +-- Erase from beginning of screen to cursor Esc [ 1 J +-- Erase entire screen Esc [ 2 J diff --git a/src/System/Terminal/Internal.hs b/src/System/Terminal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Internal.hs @@ -0,0 +1,22 @@ +module System.Terminal.Internal ( + -- ** Terminal + Terminal (..) + , Command (..) + , Attribute (..) + , Color (..) + , Decoder (..) + , defaultDecoder + , defaultEncode + -- ** LocalTerminal + , System.Terminal.Platform.LocalTerminal () + -- ** VirtualTerminal (for testing) + , VirtualTerminal (..) + , VirtualTerminalSettings (..) + , withVirtualTerminal + ) where + +import System.Terminal.Decoder +import System.Terminal.Encoder +import System.Terminal.Terminal +import System.Terminal.Platform +import System.Terminal.Virtual diff --git a/src/System/Terminal/MonadInput.hs b/src/System/Terminal/MonadInput.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/MonadInput.hs @@ -0,0 +1,167 @@ +module System.Terminal.MonadInput where + +import Control.Applicative ((<|>)) +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Bits +import Data.List + +import System.Terminal.MonadScreen + +-- | This monad describes an environment that maintains a stream of `Event`s +-- and offers out-of-band signaling for interrupts. +-- +-- * An interrupt shall occur if the user either presses CTRL+C +-- or any other mechanism the environment designates for that purpose. +-- * Implementations shall maintain an interrupt flag that is set +-- when an interrupt occurs. Computations in this monad shall check and +-- reset this flag regularly. If the execution environment finds this +-- flag still set when trying to signal another interrupt, it shall +-- throw `Control.Exception.AsyncException.UserInterrupt` to the +-- seemingly unresponsive computation. +class (MonadIO m) => MonadInput m where + -- | Wait for the next interrupt or next event transformed by a given mapper. + -- + -- * The first mapper parameter is a transaction that succeeds as + -- soon as an interrupt occurs. Executing this transaction + -- resets the interrupt flag. When a second interrupt occurs before + -- the interrupt flag has been reset, the current thread shall + -- receive an `Control.Exception.AsyncException.UserInterrupt`. + -- * The second mapper parameter is a transaction that succeeds as + -- as soon as the next event arrives and removes that event from the + -- stream of events. It shall be executed at most once within a single + -- transaction or the transaction would block until the requested number + -- of events is available. + -- * The mapper may also be used in order to additionally wait on external + -- events (like an `Control.Monad.Async.Async` to complete). + awaitWith :: (STM Interrupt -> STM Event -> STM a) -> m a + +-- | Wait for the next event. +-- +-- * Returns as soon as an interrupt or a regular event occurs. +-- * This operation resets the interrupt flag, signaling responsiveness to +-- the execution environment. +awaitEvent :: MonadInput m => m (Either Interrupt Event) +awaitEvent = awaitWith$ \intr ev -> + (Left <$> intr) <|> (Right <$> ev) + +-- | Check whether an interrupt is pending. +-- +-- * This operation resets the interrupt flag, signaling responsiveness +-- to the execution environment. +checkInterrupt :: MonadInput m => m Bool +checkInterrupt = awaitWith $ \intr _ -> + (intr >> pure True) <|> pure False + +-- | Events emitted by the terminal. +-- +-- * Event decoding might be ambique. In case of ambiqueness all +-- possible meaning shall be emitted. The user is advised to only +-- match on events expected in a certain context and ignore all +-- others. +-- * Key events are highly ambique: I.e. when the user presses @space@ +-- it might either be meant as a regular text element (like @a@,@b@,@c@) +-- or the focus is on the key itself (like in "Press space to continue..."). +-- * The story is even more complicated: Depending on terminal type and +-- @termios@ settings, certain control codes have special meaning or not +-- (@Ctrl+C@ sometimes means interrupt, but not if the environment supports +-- delivering it as a signal). Don't wait for @Ctrl+C@ when you mean `Interrupt`! +-- Example: The tab key will likely emit @KeyEvent (CharKey 'I') ctrlKey@ and +-- @KeyEvent TabKey mempty@ in most settings. +data Event + = KeyEvent Key Modifiers + | MouseEvent MouseEvent + | WindowEvent WindowEvent + | DeviceEvent DeviceEvent + | OtherEvent String + deriving (Eq,Ord,Show) + +-- | Events triggered by key press. +data Key + = CharKey Char + | TabKey + | SpaceKey + | BackspaceKey + | EnterKey + | InsertKey + | DeleteKey + | HomeKey + | BeginKey + | EndKey + | PageUpKey + | PageDownKey + | EscapeKey + | PrintKey + | PauseKey + | ArrowKey Direction + | FunctionKey Int + deriving (Eq,Ord,Show) + +-- | Modifier keys. +newtype Modifiers = Modifiers Int + deriving (Eq, Ord, Bits) + +instance Semigroup Modifiers where + Modifiers a <> Modifiers b = Modifiers (a .|. b) + +instance Monoid Modifiers where + mempty = Modifiers 0 + +instance Show Modifiers where + show (Modifiers 0) = "mempty" + show (Modifiers 1) = "shiftKey" + show (Modifiers 2) = "ctrlKey" + show (Modifiers 4) = "altKey" + show (Modifiers 8) = "metaKey" + show i = "(" ++ intercalate " <> " ls ++ ")" + where + ls = foldl (\acc x-> if x .&. i /= mempty then show x:acc else acc) [] + [metaKey, altKey, ctrlKey, shiftKey] + +shiftKey, ctrlKey, altKey, metaKey :: Modifiers +shiftKey = Modifiers 1 +ctrlKey = Modifiers 2 +altKey = Modifiers 4 +metaKey = Modifiers 8 + +-- | Events triggered by mouse action. +-- +-- * Mouse event reporting must be activated before (TODO). +data MouseEvent + = MouseMoved Position + | MouseButtonPressed Position MouseButton + | MouseButtonReleased Position MouseButton + | MouseButtonClicked Position MouseButton + | MouseWheeled Position Direction + deriving (Eq,Ord,Show) + +data MouseButton + = LeftMouseButton + | RightMouseButton + | OtherMouseButton + deriving (Eq,Ord,Show) + +data Direction + = Upwards + | Downwards + | Leftwards + | Rightwards + deriving (Eq,Ord,Show) + +data WindowEvent + = WindowLostFocus + | WindowGainedFocus + | WindowSizeChanged + deriving (Eq, Ord, Show) + +data DeviceEvent + = DeviceAttributesReport String + | CursorPositionReport Position + deriving (Eq, Ord, Show) + +-- | Interrupt is a special type of event that needs +-- to be treated with priority. It is therefor not +-- included in the regular event stream. +data Interrupt + = Interrupt + deriving (Eq, Ord, Show) diff --git a/src/System/Terminal/MonadPrinter.hs b/src/System/Terminal/MonadPrinter.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/MonadPrinter.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module System.Terminal.MonadPrinter where + +import Data.Text as T +import Prelude hiding (putChar) + +-- | This class describes an environment that Unicode text can be printed to. +-- This might either be file or a terminal. +-- +-- * Instances shall implement the concept of lines and line width. +-- * Instances shall implement the concept of a carriage that can be +-- set to the beginning of the next line. +-- * It is assumed that the carriage automatically moves to the beginning +-- of the next line if the end of the current line is reached. +-- * Instances shall be Unicode aware or must at least be able to print +-- a replacement character. +-- * Implementations must be aware of infinite lazy `Prelude.String`s and +-- long `Data.Text.Text`s. `String`s should be printed character wise as +-- evaluating them might trigger exceptions at any point. Long text should +-- be printed chunk wise in order to stay interruptible. +-- * Implementations must not use an unbounded output buffer. Print operations +-- shall block and be interruptible when the output buffer is full. +-- * Instances shall not pass control characters in text to the printer (not even line break). +-- Control characters shall be replaced with �. Text formatting shall be done +-- with the designated classes extending `MonadMarkupPrinter`. +-- Allowing control sequences would cause a dependency on certain terminal +-- types, but also pose an underrated security risk as modern terminals are +-- highly programmable and should not be fed with untrusted input. +class Monad m => MonadPrinter m where + -- | Move the carriage to the beginning of the next line. + putLn :: m () + -- | Print a single character. + putChar :: Char -> m () + -- | Print a `String`. + putString :: String -> m () + putString = mapM_ putChar + -- | Print a `String` and an additional newline. + putStringLn :: String -> m () + putStringLn s = putString s >> putLn + -- | Print a `Text`. + putText :: Text -> m () + putText = putString . T.unpack + -- | Print a `Text` and an additional newline. + putTextLn :: Text -> m () + putTextLn = putStringLn . T.unpack + -- | Flush the output buffer and make the all previous output actually + -- visible after a reasonably short amount of time. + -- + -- * The operation may return before the buffer has actually been flushed. + flush :: m () + flush = pure () + -- | Get the current line width. + -- + -- * The operation may return the last known line width and may not be + -- completely precise when I/O is asynchronous. + -- * This operations shall not block too long and rather be called more + -- often in order to adapt to changes in line width. + getLineWidth :: m Int + {-# MINIMAL putLn, putChar, putText, getLineWidth #-} + +-- | This class introduces abstract constructors for text markup. +class MonadPrinter m => MonadMarkupPrinter m where + -- | This associated type represents all possible attributes that are + -- available in the current environment. + -- + -- When writing polymorphic code against these monadic interfaces + -- the concrete instantiation of this type is usually unknown and class + -- instances are generally advised to not expose value constructors for + -- this type. + -- + -- Instead, subclasses like `MonadFormattingPrinter` and `MonadColorPrinter` + -- offer abstract value constructors like `bold`, `underlined`, `inverted` + -- which are then given meaning by the concrete class instance. + data Attribute m + setAttribute :: Attribute m -> m () + setAttribute _ = pure () + -- | Reset an attribute so that it does no longer affect subsequent output. + -- + -- * Binary attributes like `bold` or `underlined` shall just be reset to their opposite. + -- + -- * For non-binary attributes like colors all of their possible values shall be treated + -- as equal, so that + -- + -- @ + -- `setAttribute` (`foreground` $ `bright` `blue`) >> `resetAttribute` (`foreground` `red`) + -- @ + -- + -- results in the foreground color attribute reset afterwards whereas after + -- + -- @ + -- `setAttribute` (`foreground` $ `bright` `blue`) >> `resetAttribute` (`background` `red`) + -- @ + -- + -- the foreground color is still set as `bright` `blue`. + -- + resetAttribute :: Attribute m -> m () + -- | Reset all attributes to their default. + resetAttributes :: m () + -- | Shall determine wheter two attribute values would override each other + -- or can be applied independently. + -- + -- * Shall obey the laws of equivalence. + resetsAttribute :: Attribute m -> Attribute m -> Bool + +class MonadMarkupPrinter m => MonadFormattingPrinter m where + -- | This attribute makes text appear __bold__. + bold :: Attribute m + -- | This attribute makes text appear /italic/. + italic :: Attribute m + -- | This attribute makes text appear underlined. + underlined :: Attribute m + -- | This attribute swaps foreground and background (color). + -- + -- * This operation is idempotent: Applying the attribute a second time + -- won't swap it back. Use `resetAttribute` instead. + inverted :: Attribute m + +-- | This class offers abstract value constructors for +-- foreground and background coloring. +class MonadMarkupPrinter m => MonadColorPrinter m where + data Color m + + black :: Color m + red :: Color m + green :: Color m + yellow :: Color m + blue :: Color m + magenta :: Color m + cyan :: Color m + white :: Color m + + bright :: Color m -> Color m + + -- | This attribute sets the __foreground__ color (the text color). + foreground :: Color m -> Attribute m + -- | This attribute sets the __background__ color. + background :: Color m -> Attribute m diff --git a/src/System/Terminal/MonadScreen.hs b/src/System/Terminal/MonadScreen.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/MonadScreen.hs @@ -0,0 +1,94 @@ +module System.Terminal.MonadScreen where + +import System.Terminal.MonadPrinter + +data Size = Size + { height :: {-# UNPACK #-} !Int + , width :: {-# UNPACK #-} !Int + } deriving (Eq, Ord, Show) + +data Position = Position + { row :: {-# UNPACK #-} !Int + , col :: {-# UNPACK #-} !Int + } deriving (Eq, Ord, Show) + +data EraseMode + = EraseBackward -- ^ Erase left of/above current cursor position. + | EraseForward -- ^ Erase right of/below current cursor position. + | EraseAll -- ^ Erase whole line/screen. + deriving (Eq, Ord, Show) + +class (MonadPrinter m) => MonadScreen m where + -- | Get the dimensions of the visible window. + getWindowSize :: m Size + -- | Move the cursor `n` lines up. Do not change column. + moveCursorUp :: Int -> m () + -- | Move the cursor `n` lines down. Do not change column. + moveCursorDown :: Int -> m () + -- | Move the cursor `n` columns to the right. Do not change line. + moveCursorForward :: Int -> m () + -- | Move the cursor `n` columns to the left. Do not change line. + moveCursorBackward :: Int -> m () + -- | Get the current cursor position as reported by the terminal. + -- + -- * @Position 0 0@ is the upper left of the window. + -- * The cursor is always within window bounds. + -- * This operation causes a round-trip to the terminal and + -- shall be used sparely (e.g. on window size change). + getCursorPosition :: m Position + -- | Set the cursor position. + -- + -- * @Position 0 0@ is the upper left of the window. + -- * The resulting cursor position is undefined when it is outside + -- the window bounds. + setCursorPosition :: Position -> m () + -- | Set the cursor row. + -- + -- * @0@ is the topmost row. + setCursorRow :: Int -> m () + -- | Set the cursor column. + -- + -- * @0@ is the leftmost column. + setCursorColumn :: Int -> m () + -- | Save cursor position and attributes. + saveCursor :: m () + -- | Restore cursor position and attributes. + -- + -- * Restores the cursor as previously saved by `saveCursor`. + -- * The cursor position is strictly relative to the visible + -- window and does not take eventual scrolling into account. + -- The advantage of this operation is that it does not require + -- transmission of coordinates and attributes to the terminal + -- and is therefor slightly more efficient than all other alternatives. + -- * Only use this when auto-wrap is disabled, alternate screen + -- buffer is enabled or you can otherwise guarantee that the + -- window does not scroll between `saveCursor` and `restoreCursor`! + restoreCursor :: m () + -- | Insert whitespace at the cursor position and + -- shift existing characters to the right. + insertChars :: Int -> m () + -- | Delete characters and shift existing characters from the right. + deleteChars :: Int -> m () + -- | Replace characters with whitespace. + eraseChars :: Int -> m () + -- | Insert lines and shift existing lines downwards. + insertLines :: Int -> m () + -- | Delete lines and shift up existing lines from below. + deleteLines :: Int -> m () + -- | Clears characters in the current line. + eraseInLine :: EraseMode -> m () + -- | Clears lines above/below the current line. + eraseInDisplay :: EraseMode -> m () + -- | Show the cursor. + showCursor :: m () + -- | Hide the cursor. + hideCursor :: m () + -- | Whether or not to automatically wrap on line ends. + setAutoWrap :: Bool -> m () + -- | Whether or not to use the alternate screen buffer. + -- + -- - The main screen buffer content is preserved and restored + -- when leaving the alternate screen screen buffer. + -- - The dimensions of the alternate screen buffer are + -- exactly those of the screen. + setAlternateScreenBuffer :: Bool -> m () diff --git a/src/System/Terminal/MonadTerminal.hs b/src/System/Terminal/MonadTerminal.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/MonadTerminal.hs @@ -0,0 +1,8 @@ +module System.Terminal.MonadTerminal where + +import System.Terminal.MonadInput +import System.Terminal.MonadPrinter +import System.Terminal.MonadScreen + +-- | This is a convenience class combining all other terminal related classes. +class (MonadInput m, MonadFormattingPrinter m, MonadColorPrinter m, MonadScreen m) => MonadTerminal m where diff --git a/src/System/Terminal/Pretty.hs b/src/System/Terminal/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Pretty.hs @@ -0,0 +1,61 @@ +module System.Terminal.Pretty where + +import Data.Text as T +import Data.Text.Prettyprint.Doc +import Prelude hiding (putChar) + +import System.Terminal.MonadPrinter + +-- | Print an annotated `Doc`. +-- +-- Example: +-- +-- @ +-- import System.Terminal +-- import Data.Text.Prettyprint.Doc +-- +-- printer :: (`MonadFormatingPrinter` m, `MonadColorPrinter` m) => m () +-- printer = `putDoc` $ `annotate` (foreground $ `bright` `blue`) "This is blue!" <> `line` +-- <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again") +-- +-- otherDoc :: (`MonadColorPrinter` m, `Attribute` m ~ ann) => `Doc` ann +-- otherDoc = `annotate` (`background` `red`) " BOLD ON RED BACKGROUND " +-- @ +-- +-- Note the necessary unification of `Attribute` `m` and `ann` in the definition of `otherDoc`! +putDoc :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m () +putDoc doc = do + w <- getLineWidth + putSimpleDocStream (sdoc w) + where + options w = defaultLayoutOptions { layoutPageWidth = AvailablePerLine w 1.0 } + sdoc w = layoutSmart (options w) doc + +-- | Like `putDoc` but adds an additional newline. +putDocLn :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m () +putDocLn doc = putDoc doc >> putLn + +-- | Prints types instantiating the `Pretty` class. +putPretty :: (MonadMarkupPrinter m, Pretty a) => a -> m () +putPretty a = putDoc (pretty a) + +-- | Prints types instantiating the `Pretty` class and adds an additional newline. +putPrettyLn :: (MonadMarkupPrinter m, Pretty a) => a -> m () +putPrettyLn a = putPretty a >> putLn + +-- | Prints `SimpleDocStream`s (rather internal and not for the average user). +putSimpleDocStream :: (MonadMarkupPrinter m) => SimpleDocStream (Attribute m) -> m () +putSimpleDocStream sdoc = do + resetAttributes + f [] sdoc + where + f _ SFail = pure () + f _ SEmpty = pure () + f aa (SChar c xx) = putChar c >> f aa xx + f aa (SText _ t xx) = putText t >> f aa xx + f aa (SLine i xx) = putLn >> putText (T.replicate i " ") >> f aa xx + f aa (SAnnPush a xx) = setAttribute a >> f (a:aa) xx + f [] (SAnnPop xx) = f [] xx + f (a:aa) (SAnnPop xx) = case Prelude.filter (resetsAttribute a) aa of + [] -> resetAttribute a >> f aa xx + (e:_) -> setAttribute e >> f aa xx diff --git a/src/System/Terminal/Terminal.hs b/src/System/Terminal/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Terminal.hs @@ -0,0 +1,123 @@ +module System.Terminal.Terminal where + +import Control.Monad.STM +import Data.ByteString +import Data.Text + +import System.Terminal.MonadInput +import System.Terminal.MonadScreen (Size (..), Position (..), EraseMode (..)) + +-- | Types that represent terminals need to implement this class in order +-- to be driven by this library. +-- +-- This library ships with two instances: +-- +-- * `System.Terminal.Platform.LocalTerminal` represents the local +-- terminal wired to the process. +-- * `System.Terminal.Virtual.VirtualTerminal` is a minimal in-process +-- terminal emulator designed to be used for unit-testing terminal applications. +class Terminal t where + -- | The terminal identification string usually extracted from the + -- environment variable @TERM@. Should contain values like @xterm@ + -- or @rxvt-unicode@. + termType :: t -> ByteString + -- | A stream of input events. The transaction will succeed as soon as the + -- next input event becomes available. + -- + -- Note: Trying to read more than one event within the same transaction + -- might be successfull, but might also lead to undesired behaviour as + -- the transaction will block until all of its preconditions are fulfilled. + termEvent :: t -> STM Event + -- | This transaction succeeds as soon as an interrupt occurs. + -- Executing the transaction shall reset an interrupt flag maintained + -- by a supervising background thread. + -- + -- It is mandatory to regularly check this transaction in order to signal + -- responsiveness to the background thread. The execution environment is otherwise + -- advised to throw an `System.IO.Error.UserInterrupt` exception as soon as a + -- second interrupt arrives and it sees a previous one unhandled. + termInterrupt :: t -> STM Interrupt + -- | This operation shall send a command to the terminal. + -- It shall block when the buffer exeeded its capacity + -- and unblock as soon as space becomes available again. + -- + -- Note: All implementations must limit the size of the output buffer or + -- the application is at risk of running out of memory when writing much + -- faster than the terminal can read. + termCommand :: t -> Command -> IO () + -- | This operations flushes the output buffer. Whether it blocks or + -- not until the buffer has actually been flushed shall be undefined + -- (there might be other buffers involved that cannot be force-flushed + -- so it is probably better to not give any guarantees here). + termFlush :: t -> IO () + -- | This operation shall return the latest known window size without + -- blocking. + termGetWindowSize :: t -> IO Size + -- | This operation shall return the current cursor position. + -- It may block as depending on implementation it usually requires an + -- in-band roundtrip to the terminal. Use it wisely. + termGetCursorPosition :: t -> IO Position + +-- | The commands every terminal needs to understand. +-- +-- This shall only be extended when something is missing +-- that all terminals understand. Otherwise portability will +-- be lost. +data Command + = PutLn + | PutText Text + | SetAttribute Attribute + | ResetAttribute Attribute + | ResetAttributes + | MoveCursorUp Int + | MoveCursorDown Int + | MoveCursorForward Int + | MoveCursorBackward Int + | ShowCursor + | HideCursor + | SaveCursor + | RestoreCursor + | GetCursorPosition + | SetCursorPosition Position + | SetCursorRow Int + | SetCursorColumn Int + | InsertChars Int + | DeleteChars Int + | EraseChars Int + | InsertLines Int + | DeleteLines Int + | EraseInLine EraseMode + | EraseInDisplay EraseMode + | SetAutoWrap Bool + | SetAlternateScreenBuffer Bool + deriving (Eq, Ord, Show) + +-- | ANSI text attributes. +data Attribute + = Bold + | Italic + | Underlined + | Inverted + | Foreground Color + | Background Color + deriving (Eq, Ord, Show) + +-- | ANSI colors. +data Color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + deriving (Eq, Ord, Show) diff --git a/src/System/Terminal/TerminalT.hs b/src/System/Terminal/TerminalT.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/TerminalT.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module System.Terminal.TerminalT + ( TerminalT () + , runTerminalT + ) +where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.STM +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.Foldable (forM_) +import qualified Data.Text as Text +import Prelude hiding (putChar) + +import System.Terminal.MonadInput +import System.Terminal.MonadPrinter +import System.Terminal.MonadScreen +import System.Terminal.MonadTerminal +import qualified System.Terminal.Terminal as T + +-- | This monad transformer represents terminal applications. +-- +-- It implements all classes in this module and should serve as a good +-- foundation for most use cases. +-- +-- Note that it is not necessary nor recommended to have this type in +-- every signature. Keep your application abstract and mention `TerminalT` +-- only once at the top level. +-- +-- Example: +-- +-- @ +-- main :: IO () +-- main = `withTerminal` (`runTerminalT` myApplication) +-- +-- myApplication :: (`MonadPrinter` m) => m () +-- myApplication = do +-- `putTextLn` "Hello world!" +-- `flush` +-- @ +newtype TerminalT t m a + = TerminalT (ReaderT t m a) + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) + +-- | Run a `TerminalT` application on the given terminal. +runTerminalT :: (MonadIO m, MonadMask m, T.Terminal t) => TerminalT t m a -> t -> m a +runTerminalT tma t = runReaderT ma t + where + TerminalT ma = tma + +instance MonadTrans (TerminalT t) where + lift = TerminalT . lift + +instance (MonadIO m, T.Terminal t) => MonadInput (TerminalT t m) where + awaitWith f = TerminalT do + t <- ask + liftIO $ atomically $ f (T.termInterrupt t) (T.termEvent t) + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadPrinter (TerminalT t m) where + putLn = + command T.PutLn + putChar c = + command (T.PutText $ Text.singleton c) + putString cs = + forM_ cs (command . T.PutText . Text.singleton) + putText t = + command (T.PutText t) + flush = TerminalT do + t <- ask + liftIO $ T.termFlush t + getLineWidth = TerminalT do + t <- ask + liftIO (width <$> T.termGetWindowSize t) + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadMarkupPrinter (TerminalT t m) where + data Attribute (TerminalT t m) = AttributeT T.Attribute deriving (Eq, Ord, Show) + setAttribute (AttributeT a) = command (T.SetAttribute a) + resetAttribute (AttributeT a) = command (T.ResetAttribute a) + resetAttributes = command T.ResetAttributes + resetsAttribute (AttributeT T.Bold {}) (AttributeT T.Bold {}) = True + resetsAttribute (AttributeT T.Italic {}) (AttributeT T.Italic {}) = True + resetsAttribute (AttributeT T.Underlined {}) (AttributeT T.Underlined {}) = True + resetsAttribute (AttributeT T.Inverted {}) (AttributeT T.Inverted {}) = True + resetsAttribute (AttributeT T.Foreground {}) (AttributeT T.Foreground {}) = True + resetsAttribute (AttributeT T.Foreground {}) (AttributeT T.Background {}) = True + resetsAttribute _ _ = False + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadFormattingPrinter (TerminalT t m) where + bold = AttributeT T.Bold + italic = AttributeT T.Italic + underlined = AttributeT T.Underlined + inverted = AttributeT T.Inverted + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadColorPrinter (TerminalT t m) where + data Color (TerminalT t m) = ColorT T.Color deriving (Eq, Ord, Show) + black = ColorT T.Black + red = ColorT T.Red + green = ColorT T.Green + yellow = ColorT T.Yellow + blue = ColorT T.Blue + magenta = ColorT T.Magenta + cyan = ColorT T.Cyan + white = ColorT T.White + bright (ColorT T.Black ) = ColorT T.BrightBlack + bright (ColorT T.Red ) = ColorT T.BrightRed + bright (ColorT T.Green ) = ColorT T.BrightGreen + bright (ColorT T.Yellow ) = ColorT T.BrightYellow + bright (ColorT T.Blue ) = ColorT T.BrightBlue + bright (ColorT T.Magenta) = ColorT T.BrightMagenta + bright (ColorT T.Cyan ) = ColorT T.BrightCyan + bright (ColorT T.White ) = ColorT T.BrightWhite + bright (ColorT c ) = ColorT c + foreground (ColorT c) = AttributeT (T.Foreground c) + background (ColorT c) = AttributeT (T.Background c) + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadScreen (TerminalT t m) where + getWindowSize = + TerminalT (liftIO . T.termGetWindowSize =<< ask) + + moveCursorUp i + | i > 0 = command (T.MoveCursorUp i) + | i < 0 = moveCursorDown i + | otherwise = pure () + moveCursorDown i + | i > 0 = command (T.MoveCursorDown i) + | i < 0 = moveCursorUp i + | otherwise = pure () + moveCursorForward i + | i > 0 = command (T.MoveCursorForward i) + | i < 0 = moveCursorBackward i + | otherwise = pure () + moveCursorBackward i + | i > 0 = command (T.MoveCursorBackward i) + | i < 0 = moveCursorForward i + | otherwise = pure () + + getCursorPosition = + TerminalT (liftIO . T.termGetCursorPosition =<< ask) + setCursorPosition pos = + command (T.SetCursorPosition pos) + setCursorRow i = + command (T.SetCursorRow i) + setCursorColumn i = + command (T.SetCursorColumn i) + + saveCursor = + command T.SaveCursor + restoreCursor = + command T.RestoreCursor + + insertChars i = do + command (T.InsertChars i) + deleteChars i = do + command (T.DeleteChars i) + eraseChars i = do + command (T.EraseChars i) + insertLines i = do + command (T.InsertLines i) + deleteLines i = do + command (T.DeleteLines i) + + eraseInLine = + command . T.EraseInLine + eraseInDisplay = + command . T.EraseInDisplay + + showCursor = + command T.ShowCursor + hideCursor = + command T.HideCursor + + setAutoWrap x = + command (T.SetAutoWrap x) + setAlternateScreenBuffer x = + command (T.SetAlternateScreenBuffer x) + +instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadTerminal (TerminalT t m) where + +command :: (MonadIO m, MonadThrow m, T.Terminal t) => T.Command -> TerminalT t m () +command c = TerminalT do + t <- ask + liftIO $ T.termCommand t c diff --git a/src/System/Terminal/Virtual.hs b/src/System/Terminal/Virtual.hs new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Virtual.hs @@ -0,0 +1,240 @@ +module System.Terminal.Virtual where + +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import qualified Data.Text as T + +import System.Terminal.MonadInput +import System.Terminal.MonadScreen (Size (..), Position (..), EraseMode (..)) +import System.Terminal.Terminal + +data VirtualTerminal + = VirtualTerminal + { virtualSettings :: VirtualTerminalSettings + , virtualCursor :: TVar Position + , virtualWindow :: TVar [String] + , virtualAutoWrap :: TVar Bool + , virtualAlternateScreenBuffer :: TVar Bool + } + +data VirtualTerminalSettings + = VirtualTerminalSettings + { virtualType :: BS.ByteString + , virtualWindowSize :: STM Size + , virtualEvent :: STM Event + , virtualInterrupt :: STM Interrupt + } + +instance Terminal VirtualTerminal where + termType = virtualType . virtualSettings + termEvent = virtualEvent . virtualSettings + termInterrupt = virtualInterrupt . virtualSettings + termCommand t c = atomically (command t c) + termFlush _ = pure () + termGetWindowSize = atomically . virtualWindowSize . virtualSettings + termGetCursorPosition = readTVarIO . virtualCursor + +withVirtualTerminal :: (MonadIO m) => VirtualTerminalSettings -> (VirtualTerminal -> m a) -> m a +withVirtualTerminal settings handler = do + size <- liftIO $ atomically $ virtualWindowSize settings + term <- liftIO $ atomically $ VirtualTerminal settings + <$> newTVar (Position 0 0) + <*> newTVar (replicate (height size) (replicate (width size) ' ')) + <*> newTVar True + <*> newTVar False + handler term + +command :: VirtualTerminal -> Command -> STM () +command t = \case + PutLn -> putLn t + PutText s -> putString t (T.unpack s) + SetAttribute _ -> pure () + ResetAttribute _ -> pure () + ResetAttributes -> pure () + MoveCursorUp i -> moveCursorVertical t (negate i) + MoveCursorDown i -> moveCursorVertical t i + MoveCursorForward i -> moveCursorHorizontal t i + MoveCursorBackward i -> moveCursorHorizontal t (negate i) + ShowCursor -> pure () + HideCursor -> pure () + SaveCursor -> pure () + RestoreCursor -> pure () + GetCursorPosition -> getCursorPosition t + SetCursorPosition pos -> setCursorPosition t pos + SetCursorRow r -> setCursorRow t r + SetCursorColumn c -> setCursorColumn t c + InsertChars i -> insertChars t i + DeleteChars i -> deleteChars t i + EraseChars i -> eraseChars t i + InsertLines i -> insertLines t i + DeleteLines i -> deleteLines t i + EraseInLine m -> eraseInLine t m + EraseInDisplay m -> eraseInDisplay t m + SetAutoWrap b -> setAutoWrap t b + SetAlternateScreenBuffer b -> setAlternateScreenBuffer t b + +scrollDown :: Int -> [String] -> [String] +scrollDown w window = + drop 1 window ++ [replicate w ' '] + +putLn :: VirtualTerminal -> STM () +putLn t = do + Size h w <- virtualWindowSize (virtualSettings t) + Position r _ <- readTVar (virtualCursor t) + window <- readTVar (virtualWindow t) + if r + 1 == h + then do + writeTVar (virtualCursor t) $ Position r 0 + writeTVar (virtualWindow t) (scrollDown w window) + else do + writeTVar (virtualCursor t) $ Position (r + 1) 0 + +putString :: VirtualTerminal -> String -> STM () +putString t s = do + Size h w <- virtualWindowSize (virtualSettings t) + autoWrap <- readTVar (virtualAutoWrap t) + Position r c <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let cl = w - c -- space in cursor line + f "" ls = ls + f x [] = let k = (take w x) in (k <> replicate (w - length k) ' ') : f (drop w x) [] + f x (l:ls) = let k = (take w x) in (k <> drop (length k) l) : f (drop w x) ls + w1 = take r wndw + w2 = [take c l <> k <> drop (c + length k) l] + where + k = take cl s + l = wndw !! r + w3 | autoWrap = f (drop cl s) $ drop (r + 1) wndw + | otherwise = drop (r + 1) wndw + w4 = w1 <> w2 <> w3 + writeTVar (virtualWindow t) (reverse $ take h $ reverse w4) + if autoWrap + then do + let (r',c') = quotRem (r * w + c + length s) w + writeTVar (virtualCursor t) $ Position (min r' (h - 1)) c' + else do + let (r', c') = (r, min (w - 1) (c + length s)) + writeTVar (virtualCursor t) $ Position r' c' + +moveCursorHorizontal :: VirtualTerminal -> Int -> STM () +moveCursorHorizontal t i = do + Size _ w <- virtualWindowSize (virtualSettings t) + Position r c <- readTVar (virtualCursor t) + writeTVar (virtualCursor t) $ Position r (max 0 $ min (w - 1) $ c + i) + +moveCursorVertical :: VirtualTerminal -> Int -> STM () +moveCursorVertical t i = do + Size h _ <- virtualWindowSize (virtualSettings t) + Position r c <- readTVar (virtualCursor t) + writeTVar (virtualCursor t) $ Position (max 0 $ min (h - 1) $ r + i) c + +getCursorPosition :: VirtualTerminal -> STM () +getCursorPosition _ = pure () + +setCursorPosition :: VirtualTerminal -> Position -> STM () +setCursorPosition t (Position r c) = do + Size h w <- virtualWindowSize (virtualSettings t) + writeTVar (virtualCursor t) $ Position (max 0 (min (h - 1) r)) (max 0 (min (w - 1) c)) + +setCursorRow :: VirtualTerminal -> Int -> STM () +setCursorRow t r = do + Size h _ <- virtualWindowSize (virtualSettings t) + Position _ c <- readTVar (virtualCursor t) + writeTVar (virtualCursor t) $ Position (max 0 (min (h - 1) r)) c + +setCursorColumn :: VirtualTerminal -> Int -> STM () +setCursorColumn t c = do + Size _ w <- virtualWindowSize (virtualSettings t) + Position r _ <- readTVar (virtualCursor t) + writeTVar (virtualCursor t) $ Position r (max 0 (min (w - 1) c)) + +insertChars :: VirtualTerminal -> Int -> STM () +insertChars t i = do + Size _ w <- virtualWindowSize (virtualSettings t) + Position r c <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let l = wndw !! r + w1 = take r wndw + w2 = [take w $ take c l <> replicate i ' ' <> drop c l] + w3 = drop (r + 1) wndw + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +deleteChars :: VirtualTerminal -> Int -> STM () +deleteChars t i = do + Position r c <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let l = wndw !! r + w1 = take r wndw + w2 = [take c l <> drop (c + i) l <> replicate i ' '] + w3 = drop (r + 1) wndw + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +eraseChars :: VirtualTerminal -> Int -> STM () +eraseChars t i = do + Position r c <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let l = wndw !! r + w1 = take r wndw + w2 = [take c l <> replicate i ' ' <> drop (c + i) l] + w3 = drop (r + 1) wndw + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +insertLines :: VirtualTerminal -> Int -> STM () +insertLines t i = do + Size h w <- virtualWindowSize (virtualSettings t) + Position r _ <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let w1 = take r wndw + w2 = replicate i (replicate w ' ') + w3 = take (h - r - i) $ drop r wndw + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +deleteLines :: VirtualTerminal -> Int -> STM () +deleteLines t i = do + Size h w <- virtualWindowSize (virtualSettings t) + Position r _ <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let w1 = take r wndw + w2 = take (h - r - i) $ drop r wndw + w3 = replicate i (replicate w ' ') + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +eraseInLine :: VirtualTerminal -> EraseMode -> STM () +eraseInLine t m = do + Size _ w <- virtualWindowSize (virtualSettings t) + Position r c <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let l = wndw !! r + w1 = take r wndw + w2 = case m of + EraseBackward -> [replicate (c + 1) ' ' <> drop (c + 1) l] + EraseForward -> [take c l <> replicate (w - c) ' '] + EraseAll -> [replicate w ' '] + w3 = drop (r + 1) wndw + writeTVar (virtualWindow t) (w1 <> w2 <> w3) + +eraseInDisplay :: VirtualTerminal -> EraseMode -> STM () +eraseInDisplay t m = do + Size h w <- virtualWindowSize (virtualSettings t) + Position r _ <- readTVar (virtualCursor t) + wndw <- readTVar (virtualWindow t) + let w1 = take r wndw + w1E = replicate r (replicate w ' ') + w2 = [wndw !! r] + w2E = [replicate w ' '] + w3 = drop (r + 1) wndw + w3E = replicate (h - r - 1) (replicate w ' ') + writeTVar (virtualWindow t) $ case m of + EraseBackward -> w1E <> w2 <> w3 + EraseForward -> w1 <> w2 <> w3E + EraseAll -> w1E <> w2E <> w3E + +setAutoWrap :: VirtualTerminal -> Bool -> STM () +setAutoWrap t b = do + writeTVar (virtualAutoWrap t) b + +setAlternateScreenBuffer :: VirtualTerminal -> Bool -> STM () +setAlternateScreenBuffer t b = do + writeTVar (virtualAlternateScreenBuffer t) b diff --git a/terminal.cabal b/terminal.cabal --- a/terminal.cabal +++ b/terminal.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d91d510e786ae40879fb10b28886159723665030111771a9d1c4da45720ffb86 +-- hash: 7730a811f80e3894006e167e612c4bcbb50b5fb0a6dd2bd8a56f92c0ebf941a5 name: terminal -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Portable terminal interaction library description: Please see the README on Github at category: Terminal @@ -35,30 +35,36 @@ library exposed-modules: - Control.Monad.Terminal System.Terminal + System.Terminal.Internal other-modules: - Control.Monad.Terminal.Decoder - Control.Monad.Terminal.Input - Control.Monad.Terminal.Monad - Control.Monad.Terminal.Printer - Control.Monad.Terminal.Terminal - Control.Monad.Terminal.TerminalT + System.Terminal.Decoder + System.Terminal.Encoder + System.Terminal.MonadInput + System.Terminal.MonadPrinter + System.Terminal.MonadScreen + System.Terminal.MonadTerminal + System.Terminal.Pretty + System.Terminal.Terminal + System.Terminal.TerminalT System.Terminal.Platform + System.Terminal.Virtual hs-source-dirs: src + default-extensions: LambdaCase MultiWayIf BlockArguments OverloadedStrings GeneralizedNewtypeDeriving TupleSections ghc-options: -Wall -fwarn-incomplete-patterns build-depends: async , base >=4.7 && <5 , bytestring - , exceptions + , exceptions >=0.10.0 , prettyprinter , stm , text , transformers if os(windows) hs-source-dirs: + src platform/windows/src include-dirs: platform/windows/include @@ -66,6 +72,7 @@ platform/windows/cbits/hs_terminal.c else hs-source-dirs: + src platform/posix/src include-dirs: platform/posix/include @@ -77,15 +84,18 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Spec.Decoder + Spec.Virtual Paths_terminal hs-source-dirs: test + default-extensions: LambdaCase MultiWayIf BlockArguments OverloadedStrings GeneralizedNewtypeDeriving TupleSections ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: async , base >=4.7 && <5 , bytestring - , exceptions + , exceptions >=0.10.0 , prettyprinter , stm , tasty diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Main where import Data.Monoid @@ -7,133 +5,11 @@ import Test.Tasty import Test.Tasty.HUnit -import Control.Monad.Terminal +import qualified Spec.Decoder +import qualified Spec.Virtual main :: IO () main = defaultMain $ testGroup "Control.Monad.Terminal" - [ testDecoder - ] - -testDecoder :: TestTree -testDecoder = testGroup "ansiDecoder" - [ testDecoderGeneric - , testDecoderWindowsConsole - , testDecoderXterm - , testDecoderGnomeTerminal - , testDecoderRxvtUnicode - ] - -testDecoderGeneric :: TestTree -testDecoderGeneric = testGroup "Generic Ansi" - [ testCase "NUL is skipped" $ f mempty "\NUL" [[]] - , testCase "SOH is ctrl+A" $ f mempty "\SOH" [[KeyEvent (CharKey 'A') ctrlKey]] - , testCase "STX is ctrl+B" $ f mempty "\STX" [[KeyEvent (CharKey 'B') ctrlKey]] - , testCase "ETX is ctrl+C" $ f mempty "\ETX" [[KeyEvent (CharKey 'C') ctrlKey]] - , testCase "EOT is ctrl+D" $ f mempty "\EOT" [[KeyEvent (CharKey 'D') ctrlKey]] - , testCase "ENQ is ctrl+E" $ f mempty "\ENQ" [[KeyEvent (CharKey 'E') ctrlKey]] - , testCase "ACK is ctrl+F" $ f mempty "\ACK" [[KeyEvent (CharKey 'F') ctrlKey]] - , testCase "\\a is ctrl+G" $ f mempty "\a" [[KeyEvent (CharKey 'G') ctrlKey]] - , testCase "\\b is ctrl+H" $ f mempty "\b" [[KeyEvent (CharKey 'H') ctrlKey]] - , testCase "\\t is ctrl+I" $ f mempty "\t" [[KeyEvent (CharKey 'I') ctrlKey]] - , testCase "\\n is ctrl+J" $ f mempty "\n" [[KeyEvent (CharKey 'J') ctrlKey]] - , testCase "\\v is ctrl+K" $ f mempty "\v" [[KeyEvent (CharKey 'K') ctrlKey]] - , testCase "\\f is ctrl+L" $ f mempty "\f" [[KeyEvent (CharKey 'L') ctrlKey]] - , testCase "\\r is ctrl+M" $ f mempty "\r" [[KeyEvent (CharKey 'M') ctrlKey]] - , testCase "SO is ctrl+N" $ f mempty "\SO" [[KeyEvent (CharKey 'N') ctrlKey]] - , testCase "SI is ctrl+O" $ f mempty "\SI" [[KeyEvent (CharKey 'O') ctrlKey]] - , testCase "DLE is ctrl+P" $ f mempty "\DLE" [[KeyEvent (CharKey 'P') ctrlKey]] - , testCase "DC1 is ctrl+Q" $ f mempty "\DC1" [[KeyEvent (CharKey 'Q') ctrlKey]] - , testCase "DC2 is ctrl+R" $ f mempty "\DC2" [[KeyEvent (CharKey 'R') ctrlKey]] - , testCase "DC3 is ctrl+S" $ f mempty "\DC3" [[KeyEvent (CharKey 'S') ctrlKey]] - , testCase "DC4 is ctrl+T" $ f mempty "\DC4" [[KeyEvent (CharKey 'T') ctrlKey]] - , testCase "NAK is ctrl+U" $ f mempty "\NAK" [[KeyEvent (CharKey 'U') ctrlKey]] - , testCase "SYN is ctrl+V" $ f mempty "\SYN" [[KeyEvent (CharKey 'V') ctrlKey]] - , testCase "ETB is ctrl+W" $ f mempty "\ETB" [[KeyEvent (CharKey 'W') ctrlKey]] - , testCase "CAN is ctrl+X" $ f mempty "\CAN" [[KeyEvent (CharKey 'X') ctrlKey]] - , testCase "EM is ctrl+Y" $ f mempty "\EM" [[KeyEvent (CharKey 'Y') ctrlKey]] - , testCase "SUB is ctrl+Z" $ f mempty "\SUB" [[KeyEvent (CharKey 'Z') ctrlKey]] - , testCase "ESC cannot be decided" $ f mempty "\ESC" [[]] - , testCase "ESC+NUL is ctrl+[ and escape key" $ f mempty "\ESC\NUL" [[],[KeyEvent (CharKey '[') ctrlKey, KeyEvent EscapeKey mempty]] - , testCase "FS is ctrl+\\" $ f mempty "\FS" [[KeyEvent (CharKey '\\') ctrlKey]] - , testCase "GS is ctrl+]" $ f mempty "\GS" [[KeyEvent (CharKey ']') ctrlKey]] - , testCase "RS is ctrl+^" $ f mempty "\RS" [[KeyEvent (CharKey '^') ctrlKey]] - , testCase "US is ctrl+_" $ f mempty "\US" [[KeyEvent (CharKey '_') ctrlKey]] - , testCase "SP is space key" $ f mempty "\SP" [[KeyEvent SpaceKey mempty]] - , testCase "'a' is character key 'a''" $ f mempty "a" [[KeyEvent (CharKey 'a') mempty]] - ] - where - f = assertDecoding (const Nothing) - --- | Only change these tests after having validated the behavior --- with the actual terminal emulator! This is the primary reason --- for having duplicate tests for different terminal emulators. -testDecoderWindowsConsole :: TestTree -testDecoderWindowsConsole = testGroup "Windows Console" - [ testCase "tab key" $ f mempty "\t" [[KeyEvent (CharKey 'I') ctrlKey, KeyEvent TabKey mempty]] - , testCase "enter key" $ f mempty "\r" [[KeyEvent (CharKey 'M') ctrlKey, KeyEvent EnterKey mempty]] - , testCase "enter key (when pressed with ctrl)" $ f ctrlKey "\n" [[KeyEvent (CharKey 'J') ctrlKey, KeyEvent EnterKey ctrlKey]] - , testCase "delete key" $ f mempty "\ESC[3~" [[],[],[],[KeyEvent DeleteKey mempty]] - , testCase "space key" $ f mempty "\SP" [[KeyEvent SpaceKey mempty]] - , testCase "space key, shift" $ f shiftKey "\SP" [[KeyEvent SpaceKey shiftKey]] - , testCase "backspace key" $ f mempty "\DEL" [[KeyEvent (CharKey '?') ctrlKey, KeyEvent BackspaceKey mempty]] - , testCase "backspace key, alt" $ f mempty "\ESC\b\NUL" [[],[],[KeyEvent BackspaceKey altKey]] - , testCase "function key 1" $ f mempty "\ESCOP" [[],[],[KeyEvent (FunctionKey 1) mempty]] - , testCase "function key 2" $ f mempty "\ESCOQ" [[],[],[KeyEvent (FunctionKey 2) mempty]] - , testCase "function key 3" $ f mempty "\ESCOR" [[],[],[KeyEvent (FunctionKey 3) mempty]] - , testCase "function key 4" $ f mempty "\ESCOS" [[],[],[KeyEvent (FunctionKey 4) mempty]] - , testCase "function key 5" $ f mempty "\ESC[15~" [[],[],[],[],[KeyEvent (FunctionKey 5) mempty]] - , testCase "function key 6" $ f mempty "\ESC[17~" [[],[],[],[],[KeyEvent (FunctionKey 6) mempty]] - , testCase "function key 7" $ f mempty "\ESC[18~" [[],[],[],[],[KeyEvent (FunctionKey 7) mempty]] - , testCase "function key 8" $ f mempty "\ESC[19~" [[],[],[],[],[KeyEvent (FunctionKey 8) mempty]] - , testCase "function key 9" $ f mempty "\ESC[20~" [[],[],[],[],[KeyEvent (FunctionKey 9) mempty]] - , testCase "function key 10" $ f mempty "\ESC[21~" [[],[],[],[],[KeyEvent (FunctionKey 10) mempty]] - , testCase "function key 11" $ f mempty "\ESC[23~" [[],[],[],[],[KeyEvent (FunctionKey 11) mempty]] - , testCase "function key 12" $ f mempty "\ESC[24~" [[],[],[],[],[KeyEvent (FunctionKey 12) mempty]] - , testCase "function key 12, shift" $ f mempty "\ESC[24;2~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) shiftKey]] - , testCase "function key 12, alt" $ f mempty "\ESC[24;3~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) altKey]] - , testCase "function key 12, shift+alt" $ f mempty "\ESC[24;4~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> altKey)]] - , testCase "function key 12, ctrl" $ f mempty "\ESC[24;5~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) ctrlKey]] - , testCase "function key 12, shift+ctrl" $ f mempty "\ESC[24;6~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> ctrlKey)]] - , testCase "function key 12, alt+ctrl" $ f mempty "\ESC[24;7~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (altKey <> ctrlKey)]] - , testCase "function key 12, shift+alt+ctrl" $ f mempty "\ESC[24;8~" [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> altKey <> ctrlKey)]] + [ Spec.Decoder.tests + , Spec.Virtual.tests ] - where - -- The special chars are assumed to be constant on Windows. - f = assertDecoding $ \case - '\t' -> Just $ KeyEvent TabKey mempty - '\r' -> Just $ KeyEvent EnterKey mempty - '\n' -> Just $ KeyEvent EnterKey mempty -- when pressed with ctrl - '\b' -> Just $ KeyEvent BackspaceKey mempty -- when pressed with alt - '\DEL' -> Just $ KeyEvent BackspaceKey mempty - _ -> Nothing - --- | Only change these tests after having validated the behavior --- with the actual terminal emulator! This is the primary reason --- for having duplicate tests for different terminal emulators. -testDecoderXterm :: TestTree -testDecoderXterm = testGroup "Xterm" - [] - --- | Only change these tests after having validated the behavior --- with the actual terminal emulator! This is the primary reason --- for having duplicate tests for different terminal emulators. -testDecoderGnomeTerminal :: TestTree -testDecoderGnomeTerminal = testGroup "Gnome Terminal" - [] - --- | Only change these tests after having validated the behavior --- with the actual terminal emulator! This is the primary reason --- for having duplicate tests for different terminal emulators. -testDecoderRxvtUnicode :: TestTree -testDecoderRxvtUnicode = testGroup "Rxvt Unicode" - [] - -assertDecoding :: (Char -> Maybe Event) -> Modifiers -> String -> [[Event]] -> Assertion -assertDecoding specialChars mods input expected - = expected @=? decode (ansiDecoder specialChars) input - where - decode :: Decoder -> String -> [[Event]] - decode decoder = \case - [] -> [] - (x:xs) -> let (events, decoder') = feedDecoder decoder mods x - in events : decode decoder' xs diff --git a/test/Spec/Decoder.hs b/test/Spec/Decoder.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Decoder.hs @@ -0,0 +1,133 @@ +module Spec.Decoder where + +import Test.Tasty +import Test.Tasty.HUnit + +import System.Terminal +import System.Terminal.Internal + +tests :: TestTree +tests = testGroup "System.Terminal.Decoder" + [ testDecoderGeneric + , testDecoderWindowsConsole + , testDecoderXterm + , testDecoderGnomeTerminal + , testDecoderRxvtUnicode + ] + +testDecoderGeneric :: TestTree +testDecoderGeneric = testGroup "Generic Ansi" + [ testCase "NUL is skipped" $ f mempty "\NUL" [] + , testCase "SOH is ctrl+A" $ f mempty "\SOH" [KeyEvent (CharKey 'A') ctrlKey] + , testCase "STX is ctrl+B" $ f mempty "\STX" [KeyEvent (CharKey 'B') ctrlKey] + , testCase "ETX is ctrl+C" $ f mempty "\ETX" [KeyEvent (CharKey 'C') ctrlKey] + , testCase "EOT is ctrl+D" $ f mempty "\EOT" [KeyEvent (CharKey 'D') ctrlKey] + , testCase "ENQ is ctrl+E" $ f mempty "\ENQ" [KeyEvent (CharKey 'E') ctrlKey] + , testCase "ACK is ctrl+F" $ f mempty "\ACK" [KeyEvent (CharKey 'F') ctrlKey] + , testCase "\\a is ctrl+G" $ f mempty "\a" [KeyEvent (CharKey 'G') ctrlKey] + , testCase "\\b is ctrl+H" $ f mempty "\b" [KeyEvent (CharKey 'H') ctrlKey] + , testCase "\\t is ctrl+I" $ f mempty "\t" [KeyEvent (CharKey 'I') ctrlKey] + , testCase "\\n is ctrl+J" $ f mempty "\n" [KeyEvent (CharKey 'J') ctrlKey] + , testCase "\\v is ctrl+K" $ f mempty "\v" [KeyEvent (CharKey 'K') ctrlKey] + , testCase "\\f is ctrl+L" $ f mempty "\f" [KeyEvent (CharKey 'L') ctrlKey] + , testCase "\\r is ctrl+M" $ f mempty "\r" [KeyEvent (CharKey 'M') ctrlKey] + , testCase "SO is ctrl+N" $ f mempty "\SO" [KeyEvent (CharKey 'N') ctrlKey] + , testCase "SI is ctrl+O" $ f mempty "\SI" [KeyEvent (CharKey 'O') ctrlKey] + , testCase "DLE is ctrl+P" $ f mempty "\DLE" [KeyEvent (CharKey 'P') ctrlKey] + , testCase "DC1 is ctrl+Q" $ f mempty "\DC1" [KeyEvent (CharKey 'Q') ctrlKey] + , testCase "DC2 is ctrl+R" $ f mempty "\DC2" [KeyEvent (CharKey 'R') ctrlKey] + , testCase "DC3 is ctrl+S" $ f mempty "\DC3" [KeyEvent (CharKey 'S') ctrlKey] + , testCase "DC4 is ctrl+T" $ f mempty "\DC4" [KeyEvent (CharKey 'T') ctrlKey] + , testCase "NAK is ctrl+U" $ f mempty "\NAK" [KeyEvent (CharKey 'U') ctrlKey] + , testCase "SYN is ctrl+V" $ f mempty "\SYN" [KeyEvent (CharKey 'V') ctrlKey] + , testCase "ETB is ctrl+W" $ f mempty "\ETB" [KeyEvent (CharKey 'W') ctrlKey] + , testCase "CAN is ctrl+X" $ f mempty "\CAN" [KeyEvent (CharKey 'X') ctrlKey] + , testCase "EM is ctrl+Y" $ f mempty "\EM" [KeyEvent (CharKey 'Y') ctrlKey] + , testCase "SUB is ctrl+Z" $ f mempty "\SUB" [KeyEvent (CharKey 'Z') ctrlKey] + , testCase "ESC cannot be decided" $ f mempty "\ESC" [] + , testCase "ESC+NUL is ctrl+[ and escape key" $ f mempty "\ESC\NUL" [KeyEvent (CharKey '[') ctrlKey, KeyEvent EscapeKey mempty] + , testCase "FS is ctrl+\\" $ f mempty "\FS" [KeyEvent (CharKey '\\') ctrlKey] + , testCase "GS is ctrl+]" $ f mempty "\GS" [KeyEvent (CharKey ']') ctrlKey] + , testCase "RS is ctrl+^" $ f mempty "\RS" [KeyEvent (CharKey '^') ctrlKey] + , testCase "US is ctrl+_" $ f mempty "\US" [KeyEvent (CharKey '_') ctrlKey] + , testCase "'a' is character key 'a''" $ f mempty "a" [KeyEvent (CharKey 'a') mempty] + ] + where + f = assertDecoding (\_ _ -> Nothing) + +-- | Only change these tests after having validated the behavior +-- with the actual terminal emulator! This is the primary reason +-- for having duplicate tests for different terminal emulators. +testDecoderWindowsConsole :: TestTree +testDecoderWindowsConsole = testGroup "Windows Console" + [ testCase "tab key" $ f mempty "\t" [KeyEvent (CharKey 'I') ctrlKey, KeyEvent TabKey mempty] + , testCase "enter key" $ f mempty "\r" [KeyEvent (CharKey 'M') ctrlKey, KeyEvent EnterKey mempty] + , testCase "enter key (when pressed with ctrl)" $ f ctrlKey "\n" [KeyEvent (CharKey 'J') ctrlKey, KeyEvent EnterKey ctrlKey] + , testCase "delete key" $ f mempty "\ESC[3~" [KeyEvent DeleteKey mempty] + , testCase "space key" $ f mempty "\SP" [KeyEvent (CharKey ' ') mempty, KeyEvent SpaceKey mempty] + , testCase "space key, shift" $ f shiftKey "\SP" [KeyEvent (CharKey ' ') shiftKey, KeyEvent SpaceKey shiftKey] + , testCase "backspace key" $ f mempty "\DEL" [KeyEvent BackspaceKey mempty] + , testCase "backspace key, alt" $ f mempty "\ESC\b\NUL" [KeyEvent BackspaceKey altKey] + , testCase "function key 1" $ f mempty "\ESCOP" [KeyEvent (FunctionKey 1) mempty] + , testCase "function key 2" $ f mempty "\ESCOQ" [KeyEvent (FunctionKey 2) mempty] + , testCase "function key 3" $ f mempty "\ESCOR" [KeyEvent (FunctionKey 3) mempty] + , testCase "function key 4" $ f mempty "\ESCOS" [KeyEvent (FunctionKey 4) mempty] + , testCase "function key 5" $ f mempty "\ESC[15~" [KeyEvent (FunctionKey 5) mempty] + , testCase "function key 6" $ f mempty "\ESC[17~" [KeyEvent (FunctionKey 6) mempty] + , testCase "function key 7" $ f mempty "\ESC[18~" [KeyEvent (FunctionKey 7) mempty] + , testCase "function key 8" $ f mempty "\ESC[19~" [KeyEvent (FunctionKey 8) mempty] + , testCase "function key 9" $ f mempty "\ESC[20~" [KeyEvent (FunctionKey 9) mempty] + , testCase "function key 10" $ f mempty "\ESC[21~" [KeyEvent (FunctionKey 10) mempty] + , testCase "function key 11" $ f mempty "\ESC[23~" [KeyEvent (FunctionKey 11) mempty] + , testCase "function key 12" $ f mempty "\ESC[24~" [KeyEvent (FunctionKey 12) mempty] + , testCase "function key 12, shift" $ f mempty "\ESC[24;2~" [KeyEvent (FunctionKey 12) shiftKey] + , testCase "function key 12, alt" $ f mempty "\ESC[24;3~" [KeyEvent (FunctionKey 12) altKey] + , testCase "function key 12, shift+alt" $ f mempty "\ESC[24;4~" [KeyEvent (FunctionKey 12) (shiftKey <> altKey)] + , testCase "function key 12, ctrl" $ f mempty "\ESC[24;5~" [KeyEvent (FunctionKey 12) ctrlKey] + , testCase "function key 12, shift+ctrl" $ f mempty "\ESC[24;6~" [KeyEvent (FunctionKey 12) (shiftKey <> ctrlKey)] + , testCase "function key 12, alt+ctrl" $ f mempty "\ESC[24;7~" [KeyEvent (FunctionKey 12) (altKey <> ctrlKey)] + , testCase "function key 12, shift+alt+ctrl" $ f mempty "\ESC[24;8~" [KeyEvent (FunctionKey 12) (shiftKey <> altKey <> ctrlKey)] + ] + where + -- The special chars are assumed to be constant on Windows. + f = assertDecoding sk + sk mods = \case + '\r' -> Just $ KeyEvent EnterKey mods + '\n' -> Just $ KeyEvent EnterKey mods + '\t' -> Just $ KeyEvent TabKey mods + '\b' -> Just $ KeyEvent BackspaceKey mods + '\SP' -> Just $ KeyEvent SpaceKey mods + '\DEL' -> Just $ KeyEvent BackspaceKey mods + _ -> Nothing + +-- | Only change these tests after having validated the behavior +-- with the actual terminal emulator! This is the primary reason +-- for having duplicate tests for different terminal emulators. +testDecoderXterm :: TestTree +testDecoderXterm = testGroup "Xterm" + [] + +-- | Only change these tests after having validated the behavior +-- with the actual terminal emulator! This is the primary reason +-- for having duplicate tests for different terminal emulators. +testDecoderGnomeTerminal :: TestTree +testDecoderGnomeTerminal = testGroup "Gnome Terminal" + [] + +-- | Only change these tests after having validated the behavior +-- with the actual terminal emulator! This is the primary reason +-- for having duplicate tests for different terminal emulators. +testDecoderRxvtUnicode :: TestTree +testDecoderRxvtUnicode = testGroup "Rxvt Unicode" + [] + +assertDecoding :: (Modifiers -> Char -> Maybe Event) -> Modifiers -> String -> [Event] -> Assertion +assertDecoding specialChars mods input expected + = expected @=? decode (defaultDecoder specialChars) input + where + decode :: Decoder -> String -> [Event] + decode decoder = \case + [] -> [] + (x:xs) -> case feedDecoder decoder mods x of + Left decoder' -> decode decoder' xs + Right evs -> evs diff --git a/test/Spec/Virtual.hs b/test/Spec/Virtual.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Virtual.hs @@ -0,0 +1,695 @@ +module Spec.Virtual (tests) where + +import Control.Monad +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Data.Monoid + +import Test.Tasty +import Test.Tasty.HUnit + +import System.Terminal +import System.Terminal.Internal + +tests :: TestTree +tests = testGroup "System.Terminal.Virtual" + [ testGroup "withVirtualTerminal" + [ testWithVirtualTerminal01 + ] + , testGroup "PutLn" + [ testPutLn01 + , testPutLn02 + , testPutLn03 + ] + , testGroup "PutText" + [ testPutText01 + , testPutText02 + , testPutText03 + , testPutText04 + ] + , testGroup "MoveCursor*" + [ testMoveCursor01 + , testMoveCursor02 + , testMoveCursor03 + , testMoveCursor04 + ] + , testGroup "GetCursorPosition" + [ testGetCursorPosition01 + ] + , testGroup "SetCursorPosition" + [ testSetCursorPosition01 + , testSetCursorPosition02 + , testSetCursorPosition03 + , testSetCursorPosition04 + , testSetCursorPosition05 + ] + , testGroup "SetCursorRow" + [ testSetCursorRow01 + ] + , testGroup "SetCursorColumn" + [ testSetCursorColumn + ] + , testGroup "InsertChars" + [ testInsertChars01 + ] + , testGroup "DeleteChars" + [ testDeleteChars01 + ] + , testGroup "EraseChars" + [ testEraseChars01 + ] + , testGroup "InsertLines" + [ testInsertLines01 + ] + , testGroup "DeleteLines" + [ testDeleteLines01 + ] + , testGroup "EraseInLine" + [ testEraseInLine01 + , testEraseInLine02 + , testEraseInLine03 + ] + , testGroup "EraseInDisplay" + [ testEraseInDisplay01 + , testEraseInDisplay02 + , testEraseInDisplay03 + ] + ] + +defaultSettings :: VirtualTerminalSettings +defaultSettings = VirtualTerminalSettings + { virtualType = "xterm" + , virtualWindowSize = pure (Size 4 10) + , virtualEvent = retry + , virtualInterrupt = retry + } + +testWithVirtualTerminal01 :: TestTree +testWithVirtualTerminal01 = + testCase "shall yield empty window and cursor on home position" do + t <- withVirtualTerminal settings pure + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 0 0 + expWindow = + [ " " + , " " + , " " ] + +testPutLn01 :: TestTree +testPutLn01 = + testCase "shall set cursor to next line" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t PutLn + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 0 + expWindow = + [ " " + , " " + , " " ] + +testPutLn02 :: TestTree +testPutLn02 = + testCase "shall not exceed bottom margin" do + t <- withVirtualTerminal settings $ \t -> do + replicateM_ 6 (termCommand t PutLn) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 0 + expWindow = + [ " " + , " " + , " " ] + +testPutLn03 :: TestTree +testPutLn03 = + testCase "shall scroll when reaching bottom margin" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "ABC") + termCommand t PutLn + termCommand t (PutText "123") + termCommand t PutLn + termCommand t PutLn + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 0 + expWindow = + [ "123 " + , " " + , " " ] + +testPutText01 :: TestTree +testPutText01 = + testCase "shall put text in first line" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "ABC") + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 0 3 + expWindow = + [ "ABC " + , " " + , " " ] + +testPutText02 :: TestTree +testPutText02 = + testCase "shall wrap text around (when autoWrap is on)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (SetAutoWrap True) + termCommand t (PutText "ABC") + termCommand t (PutText "123456789") + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 2 + expWindow = + [ "ABC1234567" + , "89 " + , " " ] + +testPutText03 :: TestTree +testPutText03 = + testCase "shall not wrap text around (when autoWrap is off)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (SetAutoWrap False) + termCommand t (PutText "ABC") + termCommand t (PutText "123456789") + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 0 9 + expWindow = + [ "ABC1234567" + , " " + , " " ] + +testPutText04 :: TestTree +testPutText04 = + testCase "shall scroll when reaching bottom margin" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890ABCDEFGHIJabcdefghijX") + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 1 + expWindow = + [ "ABCDEFGHIJ" + , "abcdefghij" + , "X " ] + +testMoveCursor01 :: TestTree +testMoveCursor01 = + testCase "shall move up" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (MoveCursorUp 1) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 0 5 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testMoveCursor02 :: TestTree +testMoveCursor02 = + testCase "shall move down" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (MoveCursorDown 1) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 5 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testMoveCursor03 :: TestTree +testMoveCursor03 = + testCase "shall move forward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (MoveCursorForward 2) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 7 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testMoveCursor04 :: TestTree +testMoveCursor04 = + testCase "shall move backward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (MoveCursorBackward 2) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 3 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testGetCursorPosition01 :: TestTree +testGetCursorPosition01 = + testCase "shall return cursor position" do + pos <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termGetCursorPosition t + assertEqual "cursor" expCursor pos + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 5 + +testSetCursorPosition01 :: TestTree +testSetCursorPosition01 = + testCase "shall set cursor position" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorPosition (Position 2 8)) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 8 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorPosition02 :: TestTree +testSetCursorPosition02 = + testCase "shall set cursor position (limit top margin)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorPosition $ Position (-1) 8) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 0 8 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorPosition03 :: TestTree +testSetCursorPosition03 = + testCase "shall set cursor position (limit bottom margin)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorPosition (Position 5 8)) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 8 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorPosition04 :: TestTree +testSetCursorPosition04 = + testCase "shall set cursor position (limit left margin)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorPosition $ Position 1 (-1)) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 0 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorPosition05 :: TestTree +testSetCursorPosition05 = + testCase "shall set cursor position (limit right margin)" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorPosition (Position 1 11)) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 9 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorRow01 :: TestTree +testSetCursorRow01 = + testCase "shall set vertical cursor position" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorRow 2) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 2 5 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testSetCursorColumn :: TestTree +testSetCursorColumn = + testCase "shall set horizontal cursor position" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "123456789012345") + termCommand t (SetCursorColumn 8) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = Position 1 8 + expWindow = + [ "1234567890" + , "12345 " + , " " ] + +testInsertChars01 :: TestTree +testInsertChars01 = + testCase "shall insert space and shift out existing chars" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 0 4)) + termCommand t (InsertChars 3) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 0 4) + expWindow = + [ "1234 567" + , " " + , " " ] + +testDeleteChars01 :: TestTree +testDeleteChars01 = + testCase "shall shift chars from right and fill with whitespace" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 0 4)) + termCommand t (DeleteChars 3) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 0 4) + expWindow = + [ "1234890 " + , " " + , " " ] + +testEraseChars01 :: TestTree +testEraseChars01 = + testCase "shall override chars with spaces" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 0 4)) + termCommand t (EraseChars 3) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 0 4) + expWindow = + [ "1234 890" + , " " + , " " ] + +testInsertLines01 :: TestTree +testInsertLines01 = + testCase "shall shift lines cursor and below downwards" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "ABCDEFGHIJ") + termCommand t (PutText "QRSTUVWXYZ") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (InsertLines 1) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure (Size 4 10) + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , " " + , "ABCDEFGHIJ" + , "QRSTUVWXYZ" ] + +testDeleteLines01 :: TestTree +testDeleteLines01 = + testCase "shall shift chars from right and fill with whitespace" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "ABCDEFGHIJ") + termCommand t (PutText "QRSTUVWXYZ") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (InsertLines 1) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure (Size 4 10) + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , " " + , "ABCDEFGHIJ" + , "QRSTUVWXYZ" ] + +testEraseInLine01 :: TestTree +testEraseInLine01 = + testCase "shall erase left with EraseBackward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInLine EraseBackward) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , " 67890" + , "1234567890" ] + +testEraseInLine02 :: TestTree +testEraseInLine02 = + testCase "shall erase right with EraseForward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInLine EraseForward) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , "1234 " + , "1234567890" ] + +testEraseInLine03 :: TestTree +testEraseInLine03 = + testCase "shall erase whole line with EraseAll" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInLine EraseAll) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , " " + , "1234567890" ] + +testEraseInDisplay01 :: TestTree +testEraseInDisplay01 = + testCase "shall erase left with EraseBackward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInDisplay EraseBackward) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ " " + , "1234567890" + , "1234567890" ] + +testEraseInDisplay02 :: TestTree +testEraseInDisplay02 = + testCase "shall erase right with EraseForward" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInDisplay EraseForward) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ "1234567890" + , "1234567890" + , " " ] + +testEraseInDisplay03 :: TestTree +testEraseInDisplay03 = + testCase "shall erase whole line with EraseAll" do + t <- withVirtualTerminal settings $ \t -> do + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (PutText "1234567890") + termCommand t (SetCursorPosition (Position 1 4)) + termCommand t (EraseInDisplay EraseAll) + pure t + assertEqual "window" expWindow =<< readTVarIO (virtualWindow t) + assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t) + where + settings = defaultSettings + { virtualWindowSize = pure $ Size 3 10 + } + expCursor = (Position 1 4) + expWindow = + [ " " + , " " + , " " ]