diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for terminal + +## 0.1.0.0 Lars Petersen 2019-01-22 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Lars Petersen (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lars Petersen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,147 @@ +# terminal + +_terminal_ is a driver library for ANSI terminals like _xterm_. + +## Features + + - Abstract monadic interfaces for different concerns: Write code that is only allowed to print + to the screen using the `MonadColorPrinter m => m ()` constraint! + - A monad transformer `TerminalT` which implements all of the interfaces. + Either use it directly or include it in your monad transformer stack and lift/derive + the functions you need. + - Unicode support by design (assuming all terminals understand UTF-8; Windows support is implemented separately). + - Supports the `Text` instead of `String` movement without being to radical about it. + - Windows support: + - Windows 10 finally supports ANSI escape sequences and the _Windows Console_ now essentially + behaves like an _xterm_. + - Windows 8, Windows 7 and older is not supported. Windows 7's support officially ended in 2015 and + the extended support will end in 2020. As this is a hobby project aiming at + enthusiasts, I have no intention to bloat this code base with all the quirks necessary + to make it work on older versions of Windows. + - Unicode is fully supported on Windows for input and output and independant of unreliably + hacks like changing the code page. A Unicode compatible console font needs to be configured. + - A very small set of dependencies, most of which are likely to be included + in every Haskell project anyway. + - No dependency on terminfo (see below). + - Rich event handling (partly inspired by _vty_): + - Keyboard events (all control codes and escape sequences are mapped to a useful set of keys and modifiers). + - Mouse events (TODO on Linux). + - Screen resize events. + - Window focus events. + - Interrupt events. + - Event handling is implemented using [STM](https://hackage.haskell.org/package/stm) instead of `IO` + which makes it very easy to wait for several events simultaneously or combine it + with custom or external events like timeouts. + - Proper signal handling (Ctrl+C): + - When using the standard terminal, the library will hook the + interrupt signal (or something equivalent e.g. on Windows). + Incoming interrupts are passed to the application code and can be + dispatched and processed. A supervisor thread assures that the application + gets killed on a second interrupt when the application is non-responsive. + This resembles the default behavior of GHC's RTS and a lot of work has been + invested to make this mechanism work reliably. + - Integrates the relatively new [prettyprinter](https://hackage.haskell.org/package/prettyprinter) + library. Nicely formatted and colorful output requires nothing more than a few combinators. + +## To use or not to use _terminfo_ + +The [terminfo](https://hackage.haskell.org/package/terminfo) library is a binding to +[libtinfo](https://en.wikipedia.org/wiki/Terminfo). + +_libtinfo_ is a library that queries a database (usually below `/usr/share/terminfo`) +to determine the specifica and necessary control codes for interacting with a given +terminal. + +Unfortunately, it is a reocurring source of issues: + +- https://github.com/commercialhaskell/stack/issues/1012 +- https://github.com/purescript/purescript/issues/2176 +- https://ghc.haskell.org/trac/ghc/ticket/8746?cversion=0&cnum_hist=2 +- https://ghc.haskell.org/trac/ghc/ticket/13210 + +Arguments in favor of _terminfo_: + + - Would allow to support all terminals in existence. + - It's "the standard". + +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. + - _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 + by all terminals (-> ANSI sequences). + - Claim: All relevant terminals support and understand the relevant ANSI escape sequences + and/or try to behave like _xterm_. Terminals that don't are not relevant. + - Is it really necessary to support something like _tvi925_ (Televideo 925, around 1982)? + I honor that _terminfo_ takes the burden to maintain the definition files + for such historical hardware, but I doubt that anyone would miss it if we decide not + to support it. + +For now, I decided to not use _terminfo_ and see how well it works. +This decision might be revised in the future. The API won't be affected by it. + +## How _terminal_ compares to.. + +### ansi-terminal + + - [ansi-terminal](https://hackage.haskell.org/package/ansi-terminal) + offers very similar primitives for printing to the terminal + and controlling the cursor. + - It also achieves doing this in portable way (very good Windows support, + no _terminfo_ requirement on Linux/Posix). + - It doesn't offer mechanisms for event processing. + - Its operations live in `IO` (control code output is possible as well) + and assume that the terminal is either connected to `stdin/stdout` or + to a handle. + +### ansi-wl-pprint + + - [ansi-wl-pprint](https://hackage.haskell.org/package/ansi-wl-pprint) is an + extension library to _ansi-terminal_. It offers a Wadler-Leyen pretty-printer + adapted to the needs of terminal screens (colors and text formatting). + - _terminal_ has a dependency on the more generic + [prettyprinter](https://hackage.haskell.org/package/prettyprinter) in order + to offer the same features and make pretty and colorful terminal output + the default rather than an exception. + +### Haskeline + + - [haskeline](https://hackage.haskell.org/package/haskeline) is a pure-Haskell + [readline](https://en.wikipedia.org/wiki/GNU_Readline) replacement. + - Its primary job is offering a line editing interface and it does this very well. + - Like _terminal_ it offers a monad transformer interface to the user (`InputT`). + - It does signal handling (Ctrl+C, Ctrl+D). + - It has a dependency on _terminfo_ in order to support a broad range of terminals + (especially those that are non-ANSI). + - It offers operations for printing to the terminal which pass control codes + unescaped. + - It might be interesting to investigate whether _terminal_ could be used + as an alternative backend for _haskeline_. + +### vty + + - [vty](https://hackage.haskell.org/package/vty) is a library that serves + as a foundation for _curses_-like applications (full-screen terminal applications + like `vim` or `htop`). + - It is very similar to `terminal` (especially the event processing has been inspired + by _vty_): It completely abstracts away the details and quirks of + communication with different terminals and offers a canonical interface to the user. + - Its scope is wider than that of _terminal_: + - _vty_ has the concept of `Images` that can be assembled and manipulated by the user. + The library keeps track of the changes and computes minimal changesets which it + then transmits to the terminal. + - Compared to _terminal_ it (currently) has the following shortcomings: + - Lack of Windows support (there has been + [a call to arms](https://www.reddit.com/r/haskell/comments/7tutxa/vty_needs_your_help_supporting_windows/) recently; + I'd be happy if my findings with _terminal_ could help improve the situation with _vty_). + - Dependency on `terminfo`. + - No proper signal handling. + +### brick + + - [brick](https://hackage.haskell.org/package/vty) is library on top of _vty_. Its + scope is different from what _terminal_ does. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/platform/posix/cbits/hs_terminal.c b/platform/posix/cbits/hs_terminal.c new file mode 100644 --- /dev/null +++ b/platform/posix/cbits/hs_terminal.c diff --git a/platform/posix/include/hs_terminal.h b/platform/posix/include/hs_terminal.h new file mode 100644 --- /dev/null +++ b/platform/posix/include/hs_terminal.h @@ -0,0 +1,4 @@ +#include +#include +#include +#include diff --git a/platform/posix/src/System/Terminal/Platform.hsc b/platform/posix/src/System/Terminal/Platform.hsc new file mode 100644 --- /dev/null +++ b/platform/posix/src/System/Terminal/Platform.hsc @@ -0,0 +1,265 @@ +{-# LANGUAGE LambdaCase #-} +module System.Terminal.Platform + ( withTerminal + ) where + +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.Catch hiding (handle) +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Bits +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 +import Foreign.Ptr +import Foreign.Storable +import System.Environment +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 + +#include "Rts.h" +#include "hs_terminal.h" + +withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> 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) + +withTermiosSettings :: (MonadIO m, MonadMask m) => (Termios -> m a) -> m a +withTermiosSettings fma = bracket before after between + where + before = liftIO $ do + termios <- getTermios + let termios' = termios { termiosISIG = False, termiosICANON = False, termiosECHO = False } + setTermios termios' + pure termios + after = liftIO . setTermios + between = fma + +withResizeHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a +withResizeHandler handler = bracket installHandler restoreHandler . const + where + 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 + 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 + 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 + +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 + + 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 + +getWindowSize :: IO (Int, Int) +getWindowSize = + alloca $ \ptr-> + unsafeIOCtl 0 (#const TIOCGWINSZ) ptr >>= \case + 0 -> peek ptr >>= \ws-> pure (fromIntegral $ wsRow ws, fromIntegral $ wsCol ws) + _ -> undefined + +getTermios :: IO Termios +getTermios = + alloca $ \ptr-> + unsafeGetTermios 0 ptr >>= \case + 0 -> peek ptr + _ -> undefined + +setTermios :: Termios -> IO () +setTermios t = + alloca $ \ptr-> + unsafeGetTermios 0 ptr >>= \case + 0 -> do + poke ptr t + unsafeSetTermios 0 (#const TCSANOW) ptr >>= \case + 0 -> pure () + _ -> undefined + _ -> undefined + +data Winsize + = Winsize + { wsRow :: !CUShort + , wsCol :: !CUShort + } deriving (Eq, Ord, Show) + +data Termios + = Termios + { termiosVEOF :: !Char + , termiosVERASE :: !Char + , termiosVINTR :: !Char + , termiosVKILL :: !Char + , termiosVQUIT :: !Char + , termiosISIG :: !Bool + , termiosICANON :: !Bool + , termiosECHO :: !Bool + } deriving (Eq, Ord, Show) + +instance Storable Winsize where + sizeOf _ = (#size struct winsize) + alignment _ = (#alignment struct winsize) + peek ptr = Winsize + <$> (#peek struct winsize, ws_row) ptr + <*> (#peek struct winsize, ws_col) ptr + poke ptr ws = do + (#poke struct winsize, ws_row) ptr (wsRow ws) + (#poke struct winsize, ws_col) ptr (wsCol ws) + +instance Storable Termios where + sizeOf _ = (#size struct termios) + alignment _ = (#alignment struct termios) + peek ptr = do + lflag <- peekLFlag + Termios + <$> (toEnum . fromIntegral <$> peekVEOF) + <*> (toEnum . fromIntegral <$> peekVERASE) + <*> (toEnum . fromIntegral <$> peekVINTR) + <*> (toEnum . fromIntegral <$> peekVKILL) + <*> (toEnum . fromIntegral <$> peekVQUIT) + <*> pure (lflag .&. (#const ISIG) /= 0) + <*> pure (lflag .&. (#const ICANON) /= 0) + <*> pure (lflag .&. (#const ECHO) /= 0) + where + peekVEOF = (#peek struct termios, c_cc[VEOF]) ptr :: IO CUChar + peekVERASE = (#peek struct termios, c_cc[VERASE]) ptr :: IO CUChar + peekVINTR = (#peek struct termios, c_cc[VINTR]) ptr :: IO CUChar + peekVKILL = (#peek struct termios, c_cc[VKILL]) ptr :: IO CUChar + peekVQUIT = (#peek struct termios, c_cc[VQUIT]) ptr :: IO CUChar + peekLFlag = (#peek struct termios, c_lflag) ptr :: IO CUInt + poke ptr termios = do + pokeVEOF $ fromIntegral $ fromEnum $ termiosVEOF termios + pokeVERASE $ fromIntegral $ fromEnum $ termiosVERASE termios + pokeVINTR $ fromIntegral $ fromEnum $ termiosVINTR termios + pokeVKILL $ fromIntegral $ fromEnum $ termiosVKILL termios + pokeVQUIT $ fromIntegral $ fromEnum $ termiosVQUIT termios + peekLFlag >>= \flag-> pokeLFlag (if termiosISIG termios then flag .|. (#const ISIG) else flag .&. complement (#const ISIG)) + peekLFlag >>= \flag-> pokeLFlag (if termiosICANON termios then flag .|. (#const ICANON) else flag .&. complement (#const ICANON)) + peekLFlag >>= \flag-> pokeLFlag (if termiosECHO termios then flag .|. (#const ECHO) else flag .&. complement (#const ECHO)) + where + pokeVEOF = (#poke struct termios, c_cc[VEOF]) ptr :: CUChar -> IO () + pokeVERASE = (#poke struct termios, c_cc[VERASE]) ptr :: CUChar -> IO () + pokeVINTR = (#poke struct termios, c_cc[VINTR]) ptr :: CUChar -> IO () + pokeVKILL = (#poke struct termios, c_cc[VKILL]) ptr :: CUChar -> IO () + pokeVQUIT = (#poke struct termios, c_cc[VQUIT]) ptr :: CUChar -> IO () + pokeLFlag = (#poke struct termios, c_lflag) ptr :: CUInt -> IO () + peekLFlag = (#peek struct termios, c_lflag) ptr :: IO CUInt + +foreign import ccall unsafe "tcgetattr" + unsafeGetTermios :: CInt -> Ptr Termios -> IO CInt + +foreign import ccall unsafe "tcsetattr" + unsafeSetTermios :: CInt -> CInt -> Ptr Termios -> IO CInt + +foreign import ccall unsafe "ioctl" + unsafeIOCtl :: CInt -> CInt -> Ptr a -> IO CInt + +foreign import ccall unsafe + stg_sig_install :: CInt -> CInt -> Ptr a -> IO CInt diff --git a/platform/windows/cbits/hs_terminal.c b/platform/windows/cbits/hs_terminal.c new file mode 100644 --- /dev/null +++ b/platform/windows/cbits/hs_terminal.c @@ -0,0 +1,50 @@ +#include "hs_terminal.h" + +BOOL hs_get_console_input_mode(LPDWORD mode) { + HANDLE h = GetStdHandle(STD_INPUT_HANDLE); + return GetConsoleMode(h, mode); +} + +BOOL hs_set_console_input_mode(DWORD mode) { + HANDLE h = GetStdHandle(STD_INPUT_HANDLE); + return SetConsoleMode(h, mode); +} + +BOOL hs_get_console_output_mode(LPDWORD mode) { + HANDLE h = GetStdHandle(STD_OUTPUT_HANDLE); + return GetConsoleMode(h, mode); +} + +BOOL hs_set_console_output_mode(DWORD mode) { + HANDLE h = GetStdHandle(STD_OUTPUT_HANDLE); + return SetConsoleMode(h, mode); +} + +BOOL hs_read_console_input(INPUT_RECORD *record) { + HANDLE h = GetStdHandle(STD_INPUT_HANDLE); + INPUT_RECORD irInBuf[1]; + DWORD recordsRead = 0; + + if (!ReadConsoleInputW(h, record, 1, &recordsRead)) { + return -1; + } + if (!recordsRead) { + return -1; + } + return 0; +} + +DWORD hs_wait_console_input(DWORD timeoutMillis) { + HANDLE h = GetStdHandle(STD_INPUT_HANDLE); + return WaitForSingleObject(h, timeoutMillis); +} + +BOOL hs_get_console_screen_buffer_info(CONSOLE_SCREEN_BUFFER_INFO *csbi) { + HANDLE h = GetStdHandle(STD_OUTPUT_HANDLE); + return GetConsoleScreenBufferInfo(h, csbi); +} + +BOOL hs_write_console(VOID *lpBuffer, DWORD nNumberOfCharsToWrite, DWORD *lpNumberOfCharsWritten) { + HANDLE h = GetStdHandle(STD_OUTPUT_HANDLE); + return WriteConsoleW(h, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, NULL); +} diff --git a/platform/windows/include/hs_terminal.h b/platform/windows/include/hs_terminal.h new file mode 100644 --- /dev/null +++ b/platform/windows/include/hs_terminal.h @@ -0,0 +1,46 @@ +#ifndef HS_TERMINAL_H +#define HS_TERMINAL_H + +#define DEFINE_CONSOLEV2_PROPERTIES + +#include +#include +#include +#include + +#ifndef ENABLE_VIRTUAL_TERMINAL_PROCESSING +#define ENABLE_VIRTUAL_TERMINAL_PROCESSING 0x0004 +#endif + +#ifndef ENABLE_PROCESSED_INPUT +#define ENABLE_PROCESSED_INPUT 0x0001 +#endif + +#ifndef ENABLE_LINE_INPUT +#define ENABLE_LINE_INPUT 0x0002 +#endif + +#ifndef ENABLE_ECHO_INPUT +#define ENABLE_ECHO_INPUT 0x0004 +#endif + +#ifndef ENABLE_VIRTUAL_TERMINAL_INPUT +#define ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 +#endif + +#ifndef MOUSE_HWHEELED +#define MOUSE_HWHEELED 0x0008 +#endif + +BOOL hs_get_console_input_mode(LPDWORD); +BOOL hs_set_console_input_mode(DWORD); +BOOL hs_get_console_output_mode(LPDWORD); +BOOL hs_set_console_output_mode(DWORD); + +DWORD hs_wait_console_input(DWORD); +BOOL hs_read_console_input(INPUT_RECORD*); +BOOL hs_write_console(VOID*, DWORD, DWORD*); + +BOOL hs_get_console_screen_buffer_info(CONSOLE_SCREEN_BUFFER_INFO*); + +#endif diff --git a/platform/windows/src/System/Terminal/Platform.hsc b/platform/windows/src/System/Terminal/Platform.hsc new file mode 100644 --- /dev/null +++ b/platform/windows/src/System/Terminal/Platform.hsc @@ -0,0 +1,397 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Terminal.Platform + ( withTerminal + ) where + +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 qualified Control.Exception as E +import Control.Monad (forever, void, 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 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) +import Foreign.Ptr (Ptr, plusPtr, castPtr) +import Foreign.Storable +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 + +#include "hs_terminal.h" + +withTerminal :: (MonadIO m, MonadMask m) => (T.Terminal -> 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 + _ -> Nothing + } + +withConsoleModes :: (MonadIO m, MonadMask m) => m a -> m a +withConsoleModes = bracket before after . const + where + modeInput m0 = m7 + where + m1 = m0 .|. (#const ENABLE_VIRTUAL_TERMINAL_INPUT) + m2 = m1 .|. (#const ENABLE_MOUSE_INPUT) + m3 = m2 .|. (#const ENABLE_WINDOW_INPUT) + m4 = m3 .|. (#const ENABLE_EXTENDED_FLAGS) + m5 = m4 .&. complement (#const ENABLE_LINE_INPUT) + m6 = m5 .&. complement (#const ENABLE_PROCESSED_INPUT) + m7 = m6 .&. complement (#const ENABLE_QUICK_EDIT_MODE) + modeOutput m0 = m1 + where + m1 = m0 .|. (#const ENABLE_VIRTUAL_TERMINAL_PROCESSING) + before = liftIO $ do + i <- getConsoleInputMode + o <- getConsoleOutputMode + setConsoleInputMode (modeInput i) + setConsoleOutputMode (modeOutput o) + pure (i, o) + after (i, o) = liftIO $ do + setConsoleInputMode i + setConsoleOutputMode o + setConsoleInputMode mode = do + r <- unsafeSetConsoleInputMode mode + -- TODO: Function reports error, but nonetheless has the correct effect. Windows bug? + when (r == 0) $ pure () -- E.throwIO (IO.userError "setConsoleInputMode: not a tty?") + setConsoleOutputMode mode = do + r <- unsafeSetConsoleOutputMode mode + when (r == 0) $ E.throwIO (IO.userError "setConsoleOutputMode: not a tty?") + getConsoleInputMode = alloca $ \ptr-> do + r <- unsafeGetConsoleInputMode ptr + when (r == 0) $ E.throwIO (IO.userError "getConsoleInputMode: not a tty?") + peek ptr + getConsoleOutputMode = alloca $ \ptr-> do + r <- unsafeGetConsoleOutputMode ptr + 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. + -- Just in case the user uses the regular output opertions + -- it is desirable to interleave with it as little as possible. + IO.hFlush IO.stdout + alloca $ put (Text.encodeUtf16LE text) + where + -- Windows expects Unicode encoded as UTF16LE. + -- This _does not_ mean that every character is just 2 bytes long. + -- Consider the character '\\x1d11e': Its encoded form is + -- 11011000 00110100 11011101 00011110 (4 bytes). + -- The underlying `writeConsoleW` function reports the UTF-16 encoding + -- units (2 bytes) written and not the bytes written. + put bs ptrWritten + | BS.null bs = pure () + | otherwise = do + (r,len) <- BS.unsafeUseAsCStringLen bs $ \(ptr,len2)-> do + let len = fromIntegral (len2 `div` 2) + r <- unsafeWriteConsole ptr len ptrWritten + pure (r,len) + when (r == 0) $ E.throwIO (IO.userError "putText: not a tty?") + 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 + terminate <- liftIO (newTVarIO False) + terminated <- liftIO (newTVarIO False) + bracket_ + (liftIO $ forkIO $ runUntilTermination terminate terminated) + (liftIO (atomically (writeTVar terminate True) >> atomically (readTVar terminated >>= check))) ma + where + runUntilTermination :: TVar Bool -> TVar Bool -> IO () + runUntilTermination terminate terminated = + (run terminate `E.catch` (\e-> E.throwTo mainThread (e:: E.SomeException))) `E.finally` atomically (writeTVar terminated True) + + 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 ++ ".") + + timeoutMillis :: CULong + timeoutMillis = 100 + + -- Wait at most `timeoutMillis` for the handle to signal readyness. + -- Then either read one console event or return `Nothing`. + tryGetConsoleInputEvent :: IO (Maybe ConsoleInputEvent) + tryGetConsoleInputEvent = + unsafeWaitConsoleInput timeoutMillis >>= \case + (#const WAIT_TIMEOUT) -> pure Nothing -- Timeout occured. + (#const WAIT_OBJECT_0) -> alloca $ \ptr-> -- Handle signaled readyness. + unsafeReadConsoleInput ptr >>= \case + 0 -> Just <$> peek ptr + _ -> E.throwIO (IO.userError "getConsoleInputEvent: error reading console events") + _ -> E.throwIO (IO.userError "getConsoleInputEvent: error waiting for console events") + +getConsoleScreenBufferInfo :: IO ConsoleScreenBufferInfo +getConsoleScreenBufferInfo = alloca $ \ptr-> + unsafeGetConsoleScreenBufferInfo ptr >>= \case + 0 -> E.throwIO (IO.userError "getConsoleScreenBufferInfo: not a tty?") + _ -> peek ptr + +getConsoleScreenSize :: IO (Int, Int) +getConsoleScreenSize = do + csbi <- getConsoleScreenBufferInfo + pure (srWindowBottom csbi - srWindowTop csbi + 1, srWindowRight csbi - srWindowLeft csbi + 1) + +data ConsoleInputEvent + = KeyEvent + { ceKeyDown :: Bool + , ceCharKey :: Char + , ceKeyModifiers :: T.Modifiers + } + | MouseEvent T.MouseEvent + | WindowEvent T.WindowEvent + | UnknownEvent WORD + deriving (Eq, Ord, Show) + +data ConsoleScreenBufferInfo + = ConsoleScreenBufferInfo + { srWindowLeft :: Int + , srWindowTop :: Int + , srWindowRight :: Int + , srWindowBottom :: Int + } + deriving (Eq, Ord, Show) + +modifiersFromControlKeyState :: DWORD -> T.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 + +instance Storable ConsoleInputEvent where + sizeOf _ = (#size struct _INPUT_RECORD) + alignment _ = (#alignment struct _INPUT_RECORD) + peek ptr = peekEventType >>= \case + (#const KEY_EVENT) -> KeyEvent + <$> (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) + 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) + _ -> 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 FOCUS_EVENT) -> peek ptrFocus >>= \case + 0 -> pure $ WindowEvent T.WindowLostFocus + _ -> pure $ WindowEvent T.WindowGainedFocus + (#const WINDOW_BUFFER_SIZE_EVENT) -> + pure $ WindowEvent $ T.WindowSizeChanged (0,0) + evt -> pure (UnknownEvent evt) + where + peekEventType = (#peek struct _INPUT_RECORD, EventType) ptr :: IO WORD + ptrEvent = castPtr $ (#ptr struct _INPUT_RECORD, Event) ptr :: Ptr a + ptrKeyDown = (#ptr struct _KEY_EVENT_RECORD, bKeyDown) ptrEvent :: Ptr BOOL + ptrKeyUnicodeChar = (#ptr struct _KEY_EVENT_RECORD, uChar) ptrEvent :: Ptr CWchar + ptrKeyControlKeyState = (#ptr struct _KEY_EVENT_RECORD, dwControlKeyState) ptrEvent :: Ptr DWORD + ptrMousePosition = (#ptr struct _MOUSE_EVENT_RECORD, dwMousePosition) ptrEvent :: Ptr a + ptrMousePositionX = (#ptr struct _COORD, X) ptrMousePosition :: Ptr SHORT + ptrMousePositionY = (#ptr struct _COORD, Y) ptrMousePosition :: Ptr SHORT + ptrMouseEventFlags = (#ptr struct _MOUSE_EVENT_RECORD, dwEventFlags) ptrEvent :: Ptr DWORD + ptrMouseButtonState = (#ptr struct _MOUSE_EVENT_RECORD, dwButtonState) ptrEvent :: Ptr DWORD + ptrFocus = (#ptr struct _FOCUS_EVENT_RECORD, bSetFocus) ptrEvent :: Ptr BOOL + poke = undefined + +instance Storable ConsoleScreenBufferInfo where + sizeOf _ = (#size struct _CONSOLE_SCREEN_BUFFER_INFO) + alignment _ = (#alignment struct _CONSOLE_SCREEN_BUFFER_INFO) + peek ptr = ConsoleScreenBufferInfo + <$> peek' ptrSrWindowLeft + <*> peek' ptrSrWindowTop + <*> peek' ptrSrWindowRight + <*> peek' ptrSrWindowBottom + 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 + poke = undefined + +foreign import ccall "hs_wait_console_input" + unsafeWaitConsoleInput :: DWORD -> IO DWORD + +foreign import ccall "hs_read_console_input" + unsafeReadConsoleInput :: Ptr ConsoleInputEvent -> IO BOOL + +foreign import ccall unsafe "hs_get_console_input_mode" + unsafeGetConsoleInputMode :: Ptr DWORD -> IO BOOL + +foreign import ccall unsafe "hs_set_console_input_mode" + unsafeSetConsoleInputMode :: DWORD -> IO BOOL + +foreign import ccall unsafe "hs_get_console_output_mode" + unsafeGetConsoleOutputMode :: Ptr DWORD -> IO BOOL + +foreign import ccall unsafe "hs_set_console_output_mode" + unsafeSetConsoleOutputMode :: DWORD -> IO BOOL + +foreign import ccall unsafe "hs_get_console_screen_buffer_info" + unsafeGetConsoleScreenBufferInfo :: Ptr ConsoleScreenBufferInfo -> IO BOOL + +foreign import ccall unsafe "hs_write_console" + unsafeWriteConsole :: Ptr a -> DWORD -> Ptr DWORD -> IO BOOL + +-- See https://msdn.microsoft.com/en-us/library/windows/desktop/aa383751(v=vs.85).aspx +-- for how Windows data types translate to stdint types. + +type BOOL = CInt +type SHORT = CShort +type WORD = CUShort +type DWORD = CULong diff --git a/src/Control/Monad/Terminal.hs b/src/Control/Monad/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal.hs @@ -0,0 +1,63 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/Decoder.hs @@ -0,0 +1,241 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/Input.hs @@ -0,0 +1,169 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/Monad.hs @@ -0,0 +1,62 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/Printer.hs @@ -0,0 +1,192 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/Terminal.hs @@ -0,0 +1,55 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Terminal/TerminalT.hs @@ -0,0 +1,255 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/System/Terminal.hs @@ -0,0 +1,14 @@ +module System.Terminal + ( Terminal (..) + , withTerminal + ) where + +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (MonadIO) + +import Control.Monad.Terminal +import qualified System.Terminal.Platform as Platform + +-- | (Indirection just for upcoming documentation). +withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a +withTerminal = Platform.withTerminal diff --git a/terminal.cabal b/terminal.cabal new file mode 100644 --- /dev/null +++ b/terminal.cabal @@ -0,0 +1,97 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d91d510e786ae40879fb10b28886159723665030111771a9d1c4da45720ffb86 + +name: terminal +version: 0.1.0.0 +synopsis: Portable terminal interaction library +description: Please see the README on Github at +category: Terminal +homepage: https://github.com/lpeterse/haskell-terminal#readme +bug-reports: https://github.com/lpeterse/haskell-terminal/issues +author: Lars Petersen +maintainer: info@lars-petersen.net +copyright: 2018 Lars Petersen +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + LICENSE + platform/posix/cbits/hs_terminal.c + platform/posix/include/hs_terminal.h + platform/posix/src/System/Terminal/Platform.hsc + platform/windows/cbits/hs_terminal.c + platform/windows/include/hs_terminal.h + platform/windows/src/System/Terminal/Platform.hsc + README.md + +source-repository head + type: git + location: https://github.com/lpeterse/haskell-terminal + +library + exposed-modules: + Control.Monad.Terminal + System.Terminal + 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.Platform + hs-source-dirs: + src + ghc-options: -Wall -fwarn-incomplete-patterns + build-depends: + async + , base >=4.7 && <5 + , bytestring + , exceptions + , prettyprinter + , stm + , text + , transformers + if os(windows) + hs-source-dirs: + platform/windows/src + include-dirs: + platform/windows/include + c-sources: + platform/windows/cbits/hs_terminal.c + else + hs-source-dirs: + platform/posix/src + include-dirs: + platform/posix/include + c-sources: + platform/posix/cbits/hs_terminal.c + default-language: Haskell2010 + +test-suite terminal-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_terminal + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + async + , base >=4.7 && <5 + , bytestring + , exceptions + , prettyprinter + , stm + , tasty + , tasty-hunit + , tasty-quickcheck + , terminal + , text + , transformers + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Monoid + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad.Terminal + +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)]] + ] + 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