terminal (empty) → 0.1.0.0
raw patch · 20 files changed
+2233/−0 lines, 20 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, exceptions, prettyprinter, stm, tasty, tasty-hunit, tasty-quickcheck, terminal, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +147/−0
- Setup.hs +2/−0
- platform/posix/cbits/hs_terminal.c +0/−0
- platform/posix/include/hs_terminal.h +4/−0
- platform/posix/src/System/Terminal/Platform.hsc +265/−0
- platform/windows/cbits/hs_terminal.c +50/−0
- platform/windows/include/hs_terminal.h +46/−0
- platform/windows/src/System/Terminal/Platform.hsc +397/−0
- src/Control/Monad/Terminal.hs +63/−0
- src/Control/Monad/Terminal/Decoder.hs +241/−0
- src/Control/Monad/Terminal/Input.hs +169/−0
- src/Control/Monad/Terminal/Monad.hs +62/−0
- src/Control/Monad/Terminal/Printer.hs +192/−0
- src/Control/Monad/Terminal/Terminal.hs +55/−0
- src/Control/Monad/Terminal/TerminalT.hs +255/−0
- src/System/Terminal.hs +14/−0
- terminal.cabal +97/−0
- test/Spec.hs +139/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for terminal++## 0.1.0.0 Lars Petersen <info@lars-petersen.net> 2019-01-22++* Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ platform/posix/cbits/hs_terminal.c view
+ platform/posix/include/hs_terminal.h view
@@ -0,0 +1,4 @@+#include <sys/ioctl.h>+#include <stdio.h>+#include <signal.h>+#include <termios.h>
+ platform/posix/src/System/Terminal/Platform.hsc view
@@ -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
+ platform/windows/cbits/hs_terminal.c view
@@ -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); +}
+ platform/windows/include/hs_terminal.h view
@@ -0,0 +1,46 @@+#ifndef HS_TERMINAL_H +#define HS_TERMINAL_H + +#define DEFINE_CONSOLEV2_PROPERTIES + +#include <windows.h> +#include <wchar.h> +#include <stdlib.h> +#include <stdio.h> + +#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
+ platform/windows/src/System/Terminal/Platform.hsc view
@@ -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
+ src/Control/Monad/Terminal.hs view
@@ -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
+ src/Control/Monad/Terminal/Decoder.hs view
@@ -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] + _ -> []
+ src/Control/Monad/Terminal/Input.hs view
@@ -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)
+ src/Control/Monad/Terminal/Monad.hs view
@@ -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
+ src/Control/Monad/Terminal/Printer.hs view
@@ -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
+ src/Control/Monad/Terminal/Terminal.hs view
@@ -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 + }
+ src/Control/Monad/Terminal/TerminalT.hs view
@@ -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
+ src/System/Terminal.hs view
@@ -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
+ terminal.cabal view
@@ -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 <https://github.com/lpeterse/haskell-terminal#readme>+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
+ test/Spec.hs view
@@ -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