terminal 0.1.0.0 → 0.2.0.0

raw patch · 27 files changed

+2690/−1489 lines, 27 filesdep ~exceptionsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: exceptions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +8/−5
• platform/posix/src/System/Terminal/Platform.hsc +156/−111
• platform/windows/src/System/Terminal/Platform.hsc +208/−188
• src/Control/Monad/Terminal.hs +0/−63
• src/Control/Monad/Terminal/Decoder.hs +0/−241
• src/Control/Monad/Terminal/Input.hs +0/−169
• src/Control/Monad/Terminal/Monad.hs +0/−62
• src/Control/Monad/Terminal/Printer.hs +0/−192
• src/Control/Monad/Terminal/Terminal.hs +0/−55
• src/Control/Monad/Terminal/TerminalT.hs +0/−255
• src/System/Terminal.hs +76/−9
• src/System/Terminal/Decoder.hs +218/−0
• src/System/Terminal/Encoder.hs +128/−0
• src/System/Terminal/Internal.hs +22/−0
• src/System/Terminal/MonadInput.hs +167/−0
• src/System/Terminal/MonadPrinter.hs +138/−0
• src/System/Terminal/MonadScreen.hs +94/−0
• src/System/Terminal/MonadTerminal.hs +8/−0
• src/System/Terminal/Pretty.hs +61/−0
• src/System/Terminal/Terminal.hs +123/−0
• src/System/Terminal/TerminalT.hs +185/−0
• src/System/Terminal/Virtual.hs +240/−0
• terminal.cabal +21/−11
• test/Spec.hs +4/−128
• test/Spec/Decoder.hs +133/−0
• test/Spec/Virtual.hs +695/−0

@@ -1,5 +1,10 @@ # Changelog for terminal +## 0.2.0.0 Lars Petersen <info@lars-petersen.net> 2019-02-10++* Fixes several inconsistencies and improves the API+  (heavily breaks previous API)+ ## 0.1.0.0 Lars Petersen <info@lars-petersen.net> 2019-01-22  * Initial release

@@ -1,4 +1,5 @@-# terminal+terminal [![Hackage](https://img.shields.io/github/release/lpeterse/haskell-terminal.svg)](https://github.com/lpeterse/haskell-terminal/releases) [![Travis](https://img.shields.io/travis/lpeterse/haskell-terminal.svg)](https://travis-ci.org/lpeterse/haskell-terminal)+=======================  _terminal_ is a driver library for ANSI terminals like _xterm_. @@ -66,9 +67,11 @@  Arguments against _terminfo_: -  - The _terminfo_ binding library is not threadsafe. This is not so much-    of a problem when serving a single local terminal, but it might be a problem-    when writing something like an SSH daemon in Haskell.+  - Static linking and stand-alone binaries:+    Apart from eventual linking issues, _terminfo_ has a runtime dependency on the+    terminfo database. This might be an issue when the environment is restricted+    (`chroot` environment or if the process shall not be allowed to interact with the file+    system for security reasons).   - _terminfo_ offers more than 500 capabilities. Only a very small part of it     is actually needed and since there is no legacy code to support there is no     real reason to expose more than a small subset of capabilities that is supported@@ -142,6 +145,6 @@  ### brick -  - [brick](https://hackage.haskell.org/package/vty) is library on top of _vty_. Its+  - [brick](https://hackage.haskell.org/package/brick) is library on top of _vty_. Its     scope is different from what _terminal_ does. 

@@ -1,22 +1,22 @@-{-# LANGUAGE LambdaCase #-} module System.Terminal.Platform-  ( withTerminal-  ) where+    ( withTerminal+    , LocalTerminal ()+    ) where +import           Control.Applicative import           Control.Concurrent import qualified Control.Concurrent.Async      as A-import           Control.Concurrent.STM.TChan import           Control.Concurrent.STM.TVar import           Control.Concurrent.STM.TMVar import qualified Control.Exception             as E-import           Control.Monad                 (forever, when, unless, void)+import           Control.Monad                 (forM_, void, when) import           Control.Monad.Catch hiding    (handle) import           Control.Monad.IO.Class import           Control.Monad.STM import           Data.Bits+import qualified Data.ByteString               as BS import qualified Data.ByteString.Char8         as BS8 import           Data.Maybe-import qualified Data.Text                     as Text import qualified Data.Text.IO                  as Text import           Foreign.C.Types import           Foreign.Marshal.Alloc@@ -26,54 +26,93 @@ import qualified System.IO                     as IO import qualified GHC.Conc                      as Conc import qualified Data.Dynamic                  as Dyn-import           System.Posix.Types            (Fd(..)) -import           Control.Monad.Terminal.Terminal-import           Control.Monad.Terminal.Input+import           System.Terminal.Terminal+import           System.Terminal.MonadInput+import           System.Terminal.MonadScreen hiding (getWindowSize)+import           System.Terminal.Decoder+import           System.Terminal.Encoder  #include "Rts.h" #include "hs_terminal.h" -withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a+data LocalTerminal+    = LocalTerminal+    { localType              :: BS.ByteString+    , localEvent             :: STM Event+    , localInterrupt         :: STM Interrupt+    , localGetCursorPosition :: IO Position+    }++instance Terminal LocalTerminal where+    termType              = localType+    termEvent             = localEvent+    termInterrupt         = localInterrupt+    termCommand _ c       = Text.hPutStr IO.stdout (defaultEncode c)+    termFlush _           = IO.hFlush IO.stdout+    termGetWindowSize _   = getWindowSize+    termGetCursorPosition = localGetCursorPosition++withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a withTerminal action = do-  term        <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM")-  mainThread  <- liftIO myThreadId-  interrupt   <- liftIO (newTVarIO False)-  output      <- liftIO newEmptyTMVarIO-  outputFlush <- liftIO newEmptyTMVarIO-  events      <- liftIO newTChanIO-  screenSize  <- liftIO (newTVarIO =<< getWindowSize)-  withTermiosSettings $ \termios->-    withResizeHandler (handleResize screenSize events) $-    withInputProcessing mainThread termios interrupt events $ -    withOutputProcessing output outputFlush $ action $ Terminal {-        termType           = term-      , termInput          = readTChan events-      , termInterrupt      = swapTVar interrupt False >>= check-      , termOutput         = putTMVar output-      , termFlush          = putTMVar outputFlush ()-      , termScreenSize     = readTVar screenSize-      , termSpecialChars   = \case-          '\n'   -> Just $ KeyEvent EnterKey mempty-          '\t'   -> Just $ KeyEvent TabKey mempty-          '\SP'  -> Just $ KeyEvent SpaceKey mempty-          '\b'   -> Just $ KeyEvent (if termiosVERASE termios == '\b'   then BackspaceKey else DeleteKey) mempty-          '\DEL' -> Just $ KeyEvent (if termiosVERASE termios == '\DEL' then DeleteKey else BackspaceKey) mempty-          _      -> Nothing-      }-  where-    handleResize screenSize events = do-      ws <- getWindowSize-      atomically $ do-        writeTVar screenSize ws-        writeTChan events (WindowEvent $ WindowSizeChanged ws)+    term           <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM")+    mainThread     <- liftIO myThreadId+    interrupt      <- liftIO (newTVarIO False)+    windowChanged  <- liftIO (newTVarIO False)+    events         <- liftIO newEmptyTMVarIO+    cursorPosition <- liftIO newEmptyTMVarIO+    withTermiosSettings $ \termios->+        withInterruptHandler (handleInterrupt mainThread interrupt) $+        withResizeHandler (handleResize windowChanged) $+        withInputProcessing termios cursorPosition events $ +        action LocalTerminal+            { localType = term+            , localEvent = do+                changed <- swapTVar windowChanged False+                if changed+                  then pure (WindowEvent WindowSizeChanged)+                  else takeTMVar events+            , localInterrupt = swapTVar interrupt False >>= check >> pure Interrupt+            , localGetCursorPosition = do+                -- Empty the result variable.+                atomically (void (takeTMVar cursorPosition) <|> pure ())+                -- Send cursor position report request.+                Text.hPutStr IO.stdout (defaultEncode GetCursorPosition)+                IO.hFlush IO.stdout+                -- Wait for the result variable to be filled by the input processor.+                atomically (takeTMVar cursorPosition)+            }+    where+        handleResize :: TVar Bool -> IO ()+        handleResize windowChanged =+            atomically (writeTVar windowChanged True)+        -- This function is responsible for passing interrupt signals and+        -- eventually throwing an exception to the main thread in case it+        -- detects that the main thread is not serving its duty to process+        -- interrupt signals. It does this by setting a flag each time an interrupt+        -- occurs - if the flag is still set when a new interrupt occurs, it assumes+        -- the main thread is not responsive.+        handleInterrupt  :: ThreadId -> TVar Bool -> IO ()+        handleInterrupt mainThread interrupt = do+            unhandledInterrupt <- atomically (swapTVar interrupt True)+            when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt) +specialChar :: Termios -> Modifiers -> Char -> Maybe Event+specialChar t mods = \case+    c | c == termiosVERASE t -> Just $ KeyEvent BackspaceKey mods+      | c == '\n'            -> Just $ KeyEvent EnterKey     mods+      | c == '\t'            -> Just $ KeyEvent TabKey       mods+      | c == '\b'            -> Just $ KeyEvent DeleteKey    mods+      | c == '\SP'           -> Just $ KeyEvent SpaceKey     mods+      | c == '\DEL'          -> Just $ KeyEvent DeleteKey    mods+      | otherwise            -> Nothing+ withTermiosSettings :: (MonadIO m, MonadMask m) => (Termios -> m a) -> m a withTermiosSettings fma = bracket before after between   where-    before  = liftIO $ do+    before  = liftIO do       termios <- getTermios-      let termios' = termios { termiosISIG = False, termiosICANON = False, termiosECHO = False }+      let termios' = termios { termiosICANON = False, termiosECHO = False }       setTermios termios'       pure termios     after   = liftIO . setTermios@@ -82,89 +121,95 @@ withResizeHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a withResizeHandler handler = bracket installHandler restoreHandler . const   where-    installHandler = liftIO $ do+    installHandler = liftIO do       Conc.ensureIOManagerIsRunning       oldHandler <- Conc.setHandler (#const SIGWINCH) (Just (const handler, Dyn.toDyn handler))       oldAction  <- stg_sig_install (#const SIGWINCH) (#const STG_SIG_HAN) nullPtr       pure (oldHandler,oldAction)-    restoreHandler (oldHandler,oldAction) = liftIO $ do+    restoreHandler (oldHandler,oldAction) = liftIO do       void $ Conc.setHandler (#const SIGWINCH) oldHandler       void $ stg_sig_install (#const SIGWINCH) oldAction nullPtr       pure () -withOutputProcessing :: (MonadIO m, MonadMask m) => TMVar Text.Text -> TMVar () -> m a -> m a-withOutputProcessing output outputFlush = bracket-  ( liftIO $ A.async run )-  ( liftIO . A.cancel ) . const+withInterruptHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a+withInterruptHandler handler = bracket installHandler restoreHandler . const   where-    run = forever $ atomically ((Just <$> takeTMVar output) `orElse` (takeTMVar outputFlush >> pure Nothing)) >>= \case-        Nothing -> IO.hFlush IO.stdout-        Just t  -> Text.hPutStr IO.stdout t+    installHandler = liftIO do+      Conc.ensureIOManagerIsRunning+      oldHandler <- Conc.setHandler (#const SIGINT) (Just (const handler, Dyn.toDyn handler))+      oldAction  <- stg_sig_install (#const SIGINT) (#const STG_SIG_HAN) nullPtr+      pure (oldHandler,oldAction)+    restoreHandler (oldHandler,oldAction) = liftIO do+      void $ Conc.setHandler (#const SIGINT) oldHandler+      void $ stg_sig_install (#const SIGINT) oldAction nullPtr+      pure () -withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> Termios -> TVar Bool -> TChan Event -> m a -> m a-withInputProcessing mainThread termios interrupt events = bracket-  ( liftIO $ A.async run )-  ( liftIO . A.cancel ) . const-  where-    run :: IO ()-    run = forever $ do -        IO.hGetChar handle >>= \case-          c | c == termiosVINTR  termios -> handleInterrupt c-            | c == termiosVERASE termios -> atomically $ writeChar c >> writeKey BackspaceKey-            | otherwise                  -> atomically $ writeChar c-        writeFillCharacterAfterTimeout+withInputProcessing :: (MonadIO m, MonadMask m) =>+    Termios -> TMVar Position -> TMVar Event -> m a -> m a+withInputProcessing termios cursorPosition events =+    bracket (liftIO $ A.async $ run decoder) (liftIO . A.cancel) . const+    where+        run :: Decoder -> IO ()+        run d = do+            c <- IO.hGetChar IO.stdin+            case feedDecoder d mempty c of+              -- The decoder is not in final state.+              -- There are sequences depending on timing (escape either is literal+              -- escape or the beginning of a sequence).+              -- This block evaluates whether more input is available within+              -- a limited timespan. If this is the case it just recurses +              -- with the decoder continuation.+              -- Otherwise, a NUL character is fed in order to tell the decoder+              -- that there is no more input belonging to the sequence.+              Left d' -> IO.hWaitForInput IO.stdin timeoutMilliseconds >>= \case+                  True  -> run d'+                  False -> case feedDecoder d' mempty '\NUL' of+                      Left d'' -> run d''+                      Right evs -> do+                          forM_ evs writeEvent+                          run decoder+              -- The decoder reached a final state.+              -- All recognized events are appended to the event stream.+              Right evs -> do+                  forM_ evs writeEvent+                  run decoder -    handle     :: IO.Handle-    handle      = IO.stdin-    writeEvent :: Event -> STM ()-    writeEvent  = writeTChan events-    writeKey   :: Key -> STM ()-    writeKey k  = writeTChan events (KeyEvent k mempty)-    writeChar  :: Char -> STM ()-    writeChar c = writeTChan events (KeyEvent (CharKey c) mempty)-    -- This function is responsible for passing interrupt events and-    -- eventually throwing an exception to the main thread in case it-    -- detects that the main thread is not serving its duty to process-    -- interrupt events. It does this by setting a flag each time an interrupt-    -- occurs - if the flag is still set when a new interrupt occurs, it assumes-    -- the main thread is not responsive.-    handleInterrupt  :: Char -> IO ()-    handleInterrupt c =  do-      unhandledInterrupt <- liftIO (atomically $ writeChar c >> writeEvent InterruptEvent >> swapTVar interrupt True)-      when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)-    -- This function first evaluates whether more input is immediately available.-    -- If this is the case it just returns. Otherwise it registers interest in-    -- the file descriptor and waits for either input becoming available or a timeout-    -- to occur. When the timeout triggers, a NUL character is appended to the-    -- event stream to enable subsequent decoders to unambigously decode all-    -- cases without the need to take timing into consideration anymore.-    writeFillCharacterAfterTimeout :: IO ()-    writeFillCharacterAfterTimeout = do-      ready <- IO.hReady handle-      unless ready $ bracket (threadWaitReadSTM (Fd 0)) snd $ \(inputAvailable,_)-> do-        timeout <- registerDelay timeoutMicroseconds >>= \t-> pure (readTVar t >>= check)-        atomically $ inputAvailable `orElse` (timeout >> writeChar '\NUL')-    -- The timeout duration has been choosen as a tradeoff between correctness-    -- (actual transmission or scheduling delays shall not be misinterpreted) and-    -- responsiveness for a human user (50 ms are barely noticable, but 1000 ms are).-    -- I.e. when the user presses the ESC key (as vim users sometimes do ;-)-    -- it shall be reflected in the application behavior quite instantly and-    -- certainly _before_ the user presses the next key (thereby assuming that the-    -- user is not able to type more than 20 characters per second).-    -- For escape sequences it shall also be taken into consideration that they are-    -- usually transmitted and received as chunks. Only on very rare occasions (buffer-    -- boundaries) it might happen that they are split right after the sequence-    -- introducer. In a modern environment with virtual terminals there is good-    -- reason to consider this more unlikely than a user that types so fast-    -- that his input might be misinterpreted as an escape sequence.-    timeoutMicroseconds :: Int-    timeoutMicroseconds  = 50000+        decoder :: Decoder+        decoder = defaultDecoder (specialChar termios) -getWindowSize :: IO (Int, Int)+        -- Adds events to the event stream and catches certain events+        -- that require special treatment.+        writeEvent :: Event -> IO ()+        writeEvent = \case+            ev@(DeviceEvent (CursorPositionReport pos)) -> atomically do+                -- One of the alternatives will succeed.+                -- The second one is not strictly required but a fail safe in order+                -- to never block in case the terminal sends a report without request.+                putTMVar cursorPosition pos <|> void (swapTMVar cursorPosition pos)+                putTMVar events ev+            ev -> atomically (putTMVar events ev)++        -- The timeout duration has been choosen as a tradeoff between correctness+        -- (actual transmission or scheduling delays shall not be misinterpreted) and+        -- responsiveness for a human user (50 ms are barely noticable, but 1000 ms are).+        -- I.e. when the user presses the ESC key (as vim users sometimes do ;-)+        -- it shall be reflected in the application behavior quite instantly and+        -- certainly _before_ the user presses the next key (thereby assuming that the+        -- user is not able to type more than 20 characters per second).+        -- For escape sequences it shall also be taken into consideration that they are+        -- usually transmitted and received as chunks. Only on very rare occasions (buffer+        -- boundaries) it might happen that they are split right after the sequence+        -- introducer. In a modern environment with virtual terminals there is good+        -- reason to consider this more unlikely than a user that types so fast+        -- that his input might be misinterpreted as an escape sequence.+        timeoutMilliseconds :: Int+        timeoutMilliseconds  = 50++getWindowSize :: IO Size getWindowSize =   alloca $ \ptr->     unsafeIOCtl 0 (#const TIOCGWINSZ) ptr >>= \case-      0 -> peek ptr >>= \ws-> pure (fromIntegral $ wsRow ws, fromIntegral $ wsCol ws)+      0 -> peek ptr >>= \ws-> pure $ Size (fromIntegral $ wsRow ws) (fromIntegral $ wsCol ws)       _ -> undefined  getTermios :: IO Termios

@@ -1,27 +1,21 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE OverloadedStrings          #-} module System.Terminal.Platform-  ( withTerminal+  ( LocalTerminal ()+  , withTerminal   ) where +import           Control.Applicative           ((<|>)) import           Control.Concurrent            (ThreadId, myThreadId, forkIO)-import           Control.Concurrent.STM.TChan  (TChan, newTChanIO, readTChan, writeTChan) import           Control.Concurrent.STM.TMVar-import           Control.Concurrent.STM.TVar   (TVar, newTVarIO, readTVar, swapTVar, writeTVar)+import           Control.Concurrent.STM.TVar   (TVar, newTVarIO, readTVar, readTVarIO, swapTVar, writeTVar) import qualified Control.Exception             as E-import           Control.Monad                 (forever, void, when, unless)+import           Control.Monad                 (forM_, when, unless) import           Control.Monad.Catch           (MonadMask, bracket, bracket_) import           Control.Monad.IO.Class        (MonadIO, liftIO)-import           Control.Monad.STM             (STM, atomically, check, orElse)-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.State+import           Control.Monad.STM             (STM, atomically, check) import           Data.Bits-import           Data.Function                 (fix) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.Text                     as Text-import qualified Data.Text.IO                  as Text import qualified Data.Text.Encoding            as Text import           Foreign.C.Types import           Foreign.Marshal.Alloc         (alloca)@@ -30,37 +24,59 @@ import qualified System.IO                     as IO import qualified System.IO.Error               as IO -import qualified Control.Monad.Terminal.Input as T-import qualified Control.Monad.Terminal.Terminal as T+import           System.Terminal.MonadInput+import           System.Terminal.MonadScreen+import           System.Terminal.Terminal+import           System.Terminal.Decoder+import           System.Terminal.Encoder  #include "hs_terminal.h" -withTerminal :: (MonadIO m, MonadMask m) => (T.Terminal -> m a) -> m a+data LocalTerminal+    = LocalTerminal+    { localType              :: BS.ByteString+    , localEvent             :: STM Event+    , localInterrupt         :: STM Interrupt+    }++instance Terminal LocalTerminal where+    termType                = localType+    termEvent               = localEvent+    termInterrupt           = localInterrupt+    termCommand _ c         = putText (defaultEncode c)+    termFlush _             = pure ()+    termGetWindowSize _     = getConsoleWindowSize+    termGetCursorPosition _ = getConsoleCursorPosition++withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a withTerminal action = do-  mainThread     <- liftIO myThreadId-  interrupt      <- liftIO (newTVarIO False)-  events         <- liftIO newTChanIO-  output         <- liftIO newEmptyTMVarIO-  outputFlush    <- liftIO newEmptyTMVarIO-  screenSize     <- liftIO (newTVarIO =<< getConsoleScreenSize)-  withConsoleModes $-    withOutputProcessing mainThread output outputFlush $-      withInputProcessing mainThread interrupt events screenSize $ action $-        T.Terminal {-          T.termType           = "xterm" -- They claim it behaves like xterm although this is certainly a bit ambituous.-        , T.termInput          = readTChan  events-        , T.termOutput         = putTMVar   output-        , T.termInterrupt      = swapTVar   interrupt False >>= check-        , T.termFlush          = putTMVar   outputFlush ()-        , T.termScreenSize     = readTVar   screenSize-        , T.termSpecialChars   = \case-            '\r'   -> Just $ T.KeyEvent T.EnterKey mempty-            '\t'   -> Just $ T.KeyEvent T.TabKey mempty-            '\SP'  -> Just $ T.KeyEvent T.SpaceKey mempty-            '\b'   -> Just $ T.KeyEvent T.BackspaceKey mempty-            '\DEL' -> Just $ T.KeyEvent T.BackspaceKey mempty+    mainThread     <- liftIO myThreadId+    interrupt      <- liftIO (newTVarIO False)+    windowChanged  <- liftIO (newTVarIO False)+    events         <- liftIO newEmptyTMVarIO+    withConsoleModes $+        withInputProcessing mainThread interrupt windowChanged events $ action $ LocalTerminal+            { localType = "xterm" -- They claim it behaves like xterm although this is certainly a bit ambituous.+            , localInterrupt =+                swapTVar interrupt False >>= check >> pure Interrupt+            , localEvent = do+                changed <- swapTVar windowChanged False+                if changed+                    then pure (WindowEvent WindowSizeChanged)+                    else takeTMVar events+            }++decoder0 :: Decoder+decoder0 = defaultDecoder f+    where+        f mods = \case+            '\r'   -> Just $ KeyEvent EnterKey     mods+            '\n'   -> Just $ KeyEvent EnterKey     mods+            '\t'   -> Just $ KeyEvent TabKey       mods+            '\b'   -> Just $ KeyEvent BackspaceKey mods+            '\SP'  -> Just $ KeyEvent SpaceKey     mods+            '\DEL' -> Just $ KeyEvent BackspaceKey mods             _      -> Nothing-        }  withConsoleModes :: (MonadIO m, MonadMask m) => m a -> m a withConsoleModes = bracket before after . const@@ -102,31 +118,6 @@       when (r == 0) $ E.throwIO (IO.userError "getConsoleOutputMode: not a tty?")       peek ptr -withOutputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TMVar Text.Text -> TMVar () -> m a -> m a-withOutputProcessing mainThread output outputFlush ma = do-  terminate  <- liftIO (newTVarIO False)-  terminated <- liftIO (newTVarIO False)-  bracket_-    (liftIO $ forkIO $ run terminate terminated)-    (liftIO (atomically (writeTVar terminate True) >> atomically (readTVar terminated >>= check))) ma-  where-    run :: TVar Bool -> TVar Bool -> IO ()-    run terminate terminated =-      -- Synchronous exception will be rethrown to the main thread.-      -- Asynchronous exceptions (apart from `E.AsyncException` thrown by the RTS) won't occur.-      -- In all cases the thread finally writes `True` into the `terminated` variable.-      (loop `E.catch` (\e-> E.throwTo mainThread (e:: E.SomeException))) `E.finally` atomically (writeTVar terminated True)-      where-        loop :: IO ()-        loop = do-          x <- atomically $ (readTVar terminate >>= check >> pure Nothing)-                  `orElse` (Just . Just <$> takeTMVar output)-                  `orElse` (takeTMVar outputFlush >> pure (Just Nothing))-          case x of-            Nothing       -> pure ()-            Just Nothing  -> IO.hFlush IO.stdout >> loop-            Just (Just t) -> putText t >> loop- putText :: Text.Text -> IO () putText text = do   -- First, flush everything that is in the regular output buffer.@@ -152,8 +143,8 @@           written <- peek ptrWritten           when (written < len) (put (BS.drop (fromIntegral len * 2) bs) ptrWritten) -withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TChan T.Event -> TVar (Int,Int) -> m a -> m a-withInputProcessing mainThread interrupt events screenSize ma = do+withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TVar Bool -> TMVar Event -> m a -> m a+withInputProcessing mainThread interrupt windowChanged events ma = do   terminate  <- liftIO (newTVarIO False)   terminated <- liftIO (newTVarIO False)   bracket_@@ -166,89 +157,106 @@      run :: TVar Bool -> IO ()     run terminate = do-      latestScreenBufferInfo <- newTVarIO =<< getConsoleScreenBufferInfo-      latestCharacter        <- newTVarIO '\NUL'-      latestMouseButton      <- newTVarIO T.LeftMouseButton-      fix $ \continue-> tryGetConsoleInputEvent >>= \case-        -- `tryGetConsoleInputEvent` is a blocking system call. It cannot be interrupted, but-        -- is guaranteed to return after at most 100ms. In this case it is checked whether-        -- this thread shall either terminate or is allowed to continue.-        -- This is cooperative multitasking to circumvent the limitations of IO on Windows.-        Nothing -> do-          shallTerminate <- atomically (readTVar terminate)-          unless shallTerminate $ do-            -- The NUL character is a replacement for timing based-            -- escape sequence recognition and enables the escape sequence decoder-            -- to reliably distinguish real escape key presses and escape sequences-            -- from another. A NUL is added after each timeout potentially-            -- terminating any ambiguous (escape) sequences.-            atomically $ do-              latest <- readTVar latestCharacter-              when (latest /= '\NUL') $ do-                writeTVar latestCharacter '\NUL'-                writeTChan events (T.KeyEvent (T.CharKey '\NUL') mempty)-            continue-        Just ev -> (>> continue) $ case ev of-          KeyEvent { ceCharKey = c, ceKeyDown = d, ceKeyModifiers = mods }-            -- In virtual terminal mode, Windows actually sends Ctrl+C and there is no-            -- way a non-responsive application can be killed from keyboard.-            -- The solution is to catch this specific event and swap an STM interrupt flag.-            -- If the old value is found to be True then it must at least be the second-            -- time the user has pressed Ctrl+C _and_ the application was to busy to-            -- to reset the interrupt flag in the meantime. In this specific case-            -- an asynchronous `E.UserInterrupt` exception is thrown to the main thread-            -- and either terminates the application or at least the current computation.-            | c == '\ETX' &&     d -> do -                unhandledInterrupt <- atomically $ do-                  writeTVar latestCharacter '\ETX'-                  writeTChan events T.InterruptEvent-                  swapTVar interrupt True-                when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)-            -- When the character is ESC and the key is pressed down it might be-            -- that the key is hold pressed. In this case a NUL has to be emitted-            -- before emitting the ESC in order to signal that the previous ESC does-            -- not introduce a sequence.-            | c == '\ESC' &&     d -> atomically $ do-                readTVar latestCharacter >>= \case-                  '\ESC' -> writeTChan events (T.KeyEvent (T.CharKey '\NUL') mempty)-                  _      -> writeTVar  latestCharacter '\ESC'-                writeTChan events (T.KeyEvent (T.CharKey '\ESC') mempty)-            | d -> atomically $ do-                writeTVar latestCharacter c-                writeTChan events (T.KeyEvent (T.CharKey c) mods)-            | otherwise -> pure () -- All other key events shall be ignored.-          MouseEvent mouseEvent -> case mouseEvent of-            T.MouseButtonPressed (r,c) btn -> atomically $ do-              csbi <- readTVar latestScreenBufferInfo-              writeTChan events $ T.MouseEvent $ T.MouseButtonPressed (r - srWindowTop csbi, c - srWindowLeft csbi) btn-              writeTVar latestMouseButton btn-            T.MouseButtonReleased (r,c) _ -> atomically $ do-              csbi <- readTVar latestScreenBufferInfo-              btn <- readTVar latestMouseButton-              writeTChan events $ T.MouseEvent $ T.MouseButtonReleased (r - srWindowTop csbi, c - srWindowLeft csbi) btn-              writeTChan events $ T.MouseEvent $ T.MouseButtonClicked  (r - srWindowTop csbi, c - srWindowLeft csbi) btn-            T.MouseButtonClicked (r,c) btn -> atomically $ do-              csbi <- readTVar latestScreenBufferInfo-              writeTChan events $ T.MouseEvent $ T.MouseButtonClicked (r - srWindowTop csbi, c - srWindowLeft csbi) btn-            T.MouseWheeled (r,c) dir -> atomically $ do-              csbi <- readTVar latestScreenBufferInfo-              writeTChan events $ T.MouseEvent $ T.MouseWheeled (r - srWindowTop csbi, c - srWindowLeft csbi) dir-            T.MouseMoved (r,c) -> atomically $ do-              csbi <- readTVar latestScreenBufferInfo-              writeTChan events $ T.MouseEvent $ T.MouseMoved (r - srWindowTop csbi, c - srWindowLeft csbi)--          WindowEvent wev -> case wev of-            T.WindowSizeChanged _ -> do-              csbi <- getConsoleScreenBufferInfo-              atomically $ do-                writeTVar latestScreenBufferInfo csbi-                let sz = (srWindowBottom csbi - srWindowTop csbi + 1, srWindowRight csbi - srWindowLeft csbi + 1)-                sz' <- swapTVar screenSize sz-                -- Observation: Not every event is an actual change to the screen size.-                -- Only real changes shall be passed.-                when (sz /= sz') (writeTChan events $ T.WindowEvent $ T.WindowSizeChanged sz)-            _ -> atomically $ writeTChan events $ T.WindowEvent wev-          UnknownEvent x  -> atomically $ writeTChan events (T.OtherEvent $ "Unknown console input event " ++ show x ++ ".")+        latestScreenBufferInfo <- newTVarIO =<< getConsoleScreenBufferInfo+        latestCharacter        <- newTVarIO '\NUL'+        latestMouseButton      <- newTVarIO LeftMouseButton+        latestWindowSize       <- newTVarIO =<< getConsoleWindowSize+        let continue :: Decoder -> IO ()+            continue decoder = do+                shallTerminate <- readTVarIO terminate+                unless shallTerminate (waitForEvents decoder)+            pushEvent :: Event -> IO ()+            pushEvent ev = atomically do -- unblock when thread shall terminate+                putTMVar events ev <|> (readTVar terminate >>= check)+            waitForEvents :: Decoder -> IO ()+            waitForEvents decoder = tryGetConsoleInputEvent >>= \case+                -- `tryGetConsoleInputEvent` is a blocking system call. It cannot be interrupted, but+                -- is guaranteed to return after at most 100ms. In this case it is checked whether+                -- this thread shall either terminate or is allowed to continue.+                -- This is cooperative multitasking to circumvent the limitations of IO on Windows.+                Nothing ->+                    -- The NUL character is a replacement for timing based+                    -- escape sequence recognition and enables the escape sequence decoder+                    -- to reliably distinguish real escape key presses and escape sequences+                    -- from another. A NUL is added after each timeout potentially+                    -- terminating any ambiguous (escape) sequences.+                    case feedDecoder decoder mempty '\NUL' of+                        Left decoder' -> continue decoder'+                        Right evs     -> forM_ evs pushEvent >> continue decoder0+                Just ev -> case ev of+                    ConsoleKeyEvent { ceCharKey = c, ceKeyDown = d, ceKeyModifiers = mods }+                        -- In virtual terminal mode, Windows actually sends Ctrl+C and there is no+                        -- way a non-responsive application can be killed from keyboard.+                        -- The solution is to catch this specific event and swap an STM interrupt flag.+                        -- If the old value is found to be True then it must at least be the second+                        -- time the user has pressed Ctrl+C _and_ the application was to busy to+                        -- to reset the interrupt flag in the meantime. In this specific case+                        -- an asynchronous `E.UserInterrupt` exception is thrown to the main thread+                        -- and either terminates the application or at least the current computation.+                        | c == '\ETX' && d -> do +                            unhandledInterrupt <- atomically (swapTVar interrupt True)+                            when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)+                        -- When the character is ESC and the key is pressed down it might be+                        -- that the key is hold pressed. In this case a NUL has to be emitted+                        -- before emitting the ESC in order to signal that the previous ESC does+                        -- not introduce a sequence.+                        | c == '\ESC' && d -> do+                            latest <- readTVarIO latestCharacter+                            case feedDecoder decoder mods (if latest == '\ESC' then '\NUL' else '\ESC') of+                                Left decoder' -> continue decoder'+                                Right evs     -> forM_ evs pushEvent >> continue decoder0+                        | d -> do+                            atomically (writeTVar latestCharacter c)+                            case feedDecoder decoder mods c of+                                Left decoder' -> continue decoder'+                                Right evs     -> forM_ evs pushEvent >> continue decoder0+                        | otherwise -> continue decoder -- All other key events shall be ignored.+                    ConsoleMouseEvent mouseEvent -> case mouseEvent of+                        MouseButtonPressed (Position r c) btn -> do+                            csbi <- readTVarIO latestScreenBufferInfo+                            atomically (writeTVar latestMouseButton btn)+                            let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1)+                            pushEvent $ MouseEvent $ MouseButtonPressed pos btn+                            continue decoder+                        MouseButtonReleased (Position r c) _ -> do+                            csbi <- readTVarIO latestScreenBufferInfo+                            btn <- readTVarIO latestMouseButton+                            let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1)+                            pushEvent $ MouseEvent $ MouseButtonReleased pos btn+                            pushEvent $ MouseEvent $ MouseButtonClicked  pos btn+                            continue decoder+                        MouseButtonClicked (Position r c) btn -> do+                            csbi <- readTVarIO latestScreenBufferInfo+                            let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1)+                            pushEvent $ MouseEvent $ MouseButtonClicked pos btn+                            continue decoder+                        MouseWheeled (Position r c) dir -> do+                            csbi <- readTVarIO latestScreenBufferInfo+                            let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1)+                            pushEvent $ MouseEvent $ MouseWheeled pos dir+                            continue decoder+                        MouseMoved (Position r c) -> do+                            csbi <- readTVarIO latestScreenBufferInfo+                            let pos = Position (r - srWindowTop csbi - 1) (c - srWindowLeft csbi - 1)+                            pushEvent $ MouseEvent $ MouseMoved pos+                            continue decoder+                    ConsoleWindowEvent wev -> case wev of+                        WindowSizeChanged -> do+                            sz <- readTVarIO latestWindowSize+                            sz' <- getConsoleWindowSize+                            -- Observation: Far more events than actual changes to the window size are+                            -- reported when resizing the window. Only pass actual changes.+                            when (sz /= sz') $ atomically do+                                writeTVar latestWindowSize sz'+                                writeTVar windowChanged True+                            continue decoder+                        _ -> do+                            pushEvent (WindowEvent wev)+                            continue decoder+                    ConsoleUnknownEvent x  -> do+                        pushEvent (OtherEvent $ "Unknown console input event " ++ show x ++ ".")+                        continue decoder+        continue decoder0      timeoutMillis :: CULong     timeoutMillis = 100@@ -271,68 +279,75 @@     0 -> E.throwIO (IO.userError "getConsoleScreenBufferInfo: not a tty?")     _ -> peek ptr -getConsoleScreenSize :: IO (Int, Int)-getConsoleScreenSize = do+getConsoleWindowSize :: IO Size+getConsoleWindowSize = do   csbi <- getConsoleScreenBufferInfo-  pure (srWindowBottom csbi - srWindowTop csbi + 1, srWindowRight csbi - srWindowLeft csbi + 1)+  pure $ Size (srWindowBottom csbi - srWindowTop csbi + 1) (srWindowRight csbi - srWindowLeft csbi + 1) +getConsoleCursorPosition :: IO Position+getConsoleCursorPosition = do+  sbi <- getConsoleScreenBufferInfo+  pure $ Position (cpY sbi - srWindowTop sbi) (cpX sbi - srWindowLeft sbi)+ data ConsoleInputEvent-  = KeyEvent+  = ConsoleKeyEvent     { ceKeyDown            :: Bool     , ceCharKey            :: Char-    , ceKeyModifiers       :: T.Modifiers+    , ceKeyModifiers       :: Modifiers     }-  | MouseEvent  T.MouseEvent-  | WindowEvent T.WindowEvent-  | UnknownEvent WORD+  | ConsoleMouseEvent  MouseEvent+  | ConsoleWindowEvent WindowEvent+  | ConsoleUnknownEvent WORD   deriving (Eq, Ord, Show)  data ConsoleScreenBufferInfo   = ConsoleScreenBufferInfo-  { srWindowLeft   :: Int-  , srWindowTop    :: Int-  , srWindowRight  :: Int-  , srWindowBottom :: Int+  { srWindowLeft   :: !Int+  , srWindowTop    :: !Int+  , srWindowRight  :: !Int+  , srWindowBottom :: !Int+  , cpX            :: !Int+  , cpY            :: !Int   }   deriving (Eq, Ord, Show) -modifiersFromControlKeyState :: DWORD -> T.Modifiers+modifiersFromControlKeyState :: DWORD -> Modifiers modifiersFromControlKeyState dw = a $ b $ c $ d $ e mempty   where-    a = if (#const LEFT_ALT_PRESSED)   .&. dw == 0 then id else mappend T.altKey-    b = if (#const LEFT_CTRL_PRESSED)  .&. dw == 0 then id else mappend T.ctrlKey-    c = if (#const RIGHT_ALT_PRESSED)  .&. dw == 0 then id else mappend T.altKey-    d = if (#const RIGHT_CTRL_PRESSED) .&. dw == 0 then id else mappend T.ctrlKey-    e = if (#const SHIFT_PRESSED)      .&. dw == 0 then id else mappend T.shiftKey+    a = if (#const LEFT_ALT_PRESSED)   .&. dw == 0 then id else mappend altKey+    b = if (#const LEFT_CTRL_PRESSED)  .&. dw == 0 then id else mappend ctrlKey+    c = if (#const RIGHT_ALT_PRESSED)  .&. dw == 0 then id else mappend altKey+    d = if (#const RIGHT_CTRL_PRESSED) .&. dw == 0 then id else mappend ctrlKey+    e = if (#const SHIFT_PRESSED)      .&. dw == 0 then id else mappend shiftKey  instance Storable ConsoleInputEvent where   sizeOf    _ = (#size struct _INPUT_RECORD)   alignment _ = (#alignment struct _INPUT_RECORD)   peek ptr    = peekEventType >>= \case-    (#const KEY_EVENT) -> KeyEvent+    (#const KEY_EVENT) -> ConsoleKeyEvent       <$> (peek ptrKeyDown >>= \case { 0-> pure False; _-> pure True; })       <*> (toEnum . fromIntegral <$> peek ptrKeyUnicodeChar)       <*> (modifiersFromControlKeyState <$> peek ptrKeyControlKeyState)-    (#const MOUSE_EVENT) -> MouseEvent <$> do-      pos <- peek ptrMousePositionX >>= \x-> peek ptrMousePositionY >>= \y-> pure (fromIntegral y, fromIntegral x)+    (#const MOUSE_EVENT) -> ConsoleMouseEvent <$> do+      pos <- peek ptrMousePositionX >>= \x-> peek ptrMousePositionY >>= \y-> pure $ Position (fromIntegral y) (fromIntegral x)       btn <- peek ptrMouseButtonState       peek ptrMouseEventFlags >>= \case-        (#const MOUSE_MOVED)    -> pure (T.MouseMoved   pos)-        (#const MOUSE_WHEELED)  -> pure (T.MouseWheeled pos $ if btn .&. 0xff000000 > 0 then T.Downwards  else T.Upwards)-        (#const MOUSE_HWHEELED) -> pure (T.MouseWheeled pos $ if btn .&. 0xff000000 > 0 then T.Rightwards else T.Leftwards)+        (#const MOUSE_MOVED)    -> pure (MouseMoved   pos)+        (#const MOUSE_WHEELED)  -> pure (MouseWheeled pos $ if btn .&. 0xff000000 > 0 then Downwards  else Upwards)+        (#const MOUSE_HWHEELED) -> pure (MouseWheeled pos $ if btn .&. 0xff000000 > 0 then Rightwards else Leftwards)         _ -> case btn of-          (#const FROM_LEFT_1ST_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed  pos T.LeftMouseButton-          (#const FROM_LEFT_2ND_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed  pos T.OtherMouseButton-          (#const FROM_LEFT_3RD_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed  pos T.OtherMouseButton-          (#const FROM_LEFT_4TH_BUTTON_PRESSED) -> pure $ T.MouseButtonPressed  pos T.OtherMouseButton-          (#const RIGHTMOST_BUTTON_PRESSED)     -> pure $ T.MouseButtonPressed  pos T.RightMouseButton-          _                                     -> pure $ T.MouseButtonReleased pos T.OtherMouseButton+          (#const FROM_LEFT_1ST_BUTTON_PRESSED) -> pure $ MouseButtonPressed  pos LeftMouseButton+          (#const FROM_LEFT_2ND_BUTTON_PRESSED) -> pure $ MouseButtonPressed  pos OtherMouseButton+          (#const FROM_LEFT_3RD_BUTTON_PRESSED) -> pure $ MouseButtonPressed  pos OtherMouseButton+          (#const FROM_LEFT_4TH_BUTTON_PRESSED) -> pure $ MouseButtonPressed  pos OtherMouseButton+          (#const RIGHTMOST_BUTTON_PRESSED)     -> pure $ MouseButtonPressed  pos RightMouseButton+          _                                     -> pure $ MouseButtonReleased pos OtherMouseButton     (#const FOCUS_EVENT) -> peek ptrFocus >>= \case-      0 -> pure $ WindowEvent T.WindowLostFocus-      _ -> pure $ WindowEvent T.WindowGainedFocus+      0 -> pure $ ConsoleWindowEvent WindowLostFocus+      _ -> pure $ ConsoleWindowEvent WindowGainedFocus     (#const WINDOW_BUFFER_SIZE_EVENT) ->-      pure $ WindowEvent $ T.WindowSizeChanged (0,0)-    evt -> pure (UnknownEvent evt)+      pure $ ConsoleWindowEvent WindowSizeChanged+    evt -> pure (ConsoleUnknownEvent evt)     where       peekEventType         = (#peek struct _INPUT_RECORD, EventType) ptr                 :: IO WORD       ptrEvent              = castPtr $ (#ptr struct _INPUT_RECORD, Event) ptr            :: Ptr a@@ -355,13 +370,18 @@     <*> peek' ptrSrWindowTop     <*> peek' ptrSrWindowRight     <*> peek' ptrSrWindowBottom+    <*> peek' ptrDwCursorPositionX+    <*> peek' ptrDwCursorPositionY     where-      peek' x           = fromIntegral <$> peek x-      ptrSrWindow       = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, srWindow) ptr :: Ptr a-      ptrSrWindowLeft   = (#ptr struct _SMALL_RECT, Left)   ptrSrWindow           :: Ptr SHORT-      ptrSrWindowTop    = (#ptr struct _SMALL_RECT, Top)    ptrSrWindow           :: Ptr SHORT-      ptrSrWindowRight  = (#ptr struct _SMALL_RECT, Right)  ptrSrWindow           :: Ptr SHORT-      ptrSrWindowBottom = (#ptr struct _SMALL_RECT, Bottom) ptrSrWindow           :: Ptr SHORT+      peek' x                 = fromIntegral <$> peek x+      ptrSrWindow             = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, srWindow) ptr         :: Ptr a+      ptrSrWindowLeft         = (#ptr struct _SMALL_RECT, Left)   ptrSrWindow                   :: Ptr SHORT+      ptrSrWindowTop          = (#ptr struct _SMALL_RECT, Top)    ptrSrWindow                   :: Ptr SHORT+      ptrSrWindowRight        = (#ptr struct _SMALL_RECT, Right)  ptrSrWindow                   :: Ptr SHORT+      ptrSrWindowBottom       = (#ptr struct _SMALL_RECT, Bottom) ptrSrWindow                   :: Ptr SHORT+      ptrDwCursorPosition     = (#ptr struct _CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) ptr :: Ptr b+      ptrDwCursorPositionX    = (#ptr struct _COORD, X) ptrDwCursorPosition                     :: Ptr SHORT+      ptrDwCursorPositionY    = (#ptr struct _COORD, Y) ptrDwCursorPosition                     :: Ptr SHORT   poke = undefined  foreign import ccall "hs_wait_console_input"

@@ -1,63 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Control.Monad.Terminal-  ( -- * Getting started-    -- ** TerminalT-    TerminalT ()-  , runTerminalT-    -- * Printing & Screen Modification-    -- ** MonadPrinter-  , MonadPrinter (..)-    -- ** MonadPrettyPrinter-  , MonadPrettyPrinter (..)-  , pprint-    -- ** MonadFormatPrinter-  , MonadFormatPrinter (..)-    -- ** MonadColorPrinter-  , MonadColorPrinter (..)-  , dull-  , bright-  , BasicColor (..)-  , Color (..)-  , ColorMode (..)-    -- ** MonadTerminal-  , MonadTerminal (..)-    -- * Event Processing-    -- ** MonadInput-  , MonadInput (..)-    -- *** waitEvent-  , waitEvent-    -- *** waitEventOrElse-  , waitEventOrElse-    -- *** waitInterruptOrElse-  , waitInterruptOrElse-    -- ** Events-  , Event (..)-    -- *** Keys & Modifiers-  , Key (..)-  , Direction (..)-  , Modifiers ()-  , shiftKey-  , ctrlKey-  , altKey-  , metaKey-    -- *** Mouse Events-  , MouseEvent (..)-  , MouseButton (..)-    -- *** Window Events-  , WindowEvent (..)-    -- *** Device Events-  , DeviceEvent (..)-  -- * Low-Level-  -- ** Terminal-  , Terminal (..)-  -- ** Decoding-  , Decoder (..)-  , ansiDecoder-  ) where--import           Control.Monad.Terminal.Decoder-import           Control.Monad.Terminal.Input-import           Control.Monad.Terminal.Monad-import           Control.Monad.Terminal.Printer-import           Control.Monad.Terminal.Terminal-import           Control.Monad.Terminal.TerminalT

@@ -1,241 +0,0 @@-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-module Control.Monad.Terminal.Decoder where
-
-import           Data.Char
-import           Data.Monoid                  ((<>))
-
-import           Control.Monad.Terminal.Input
-
--- | The type `Decoder` represents a finite state transducer.
---
---   Values of this type can only be constructed by tying the knot
---   which causes the resulting transducer to have one entry point
---   but no exits. Intermediate state can be passed as closures.
---   See below for an example.
-newtype Decoder = Decoder { feedDecoder :: Modifiers -> Char -> ([Event], Decoder) }
-
-ansiDecoder :: (Char -> Maybe Event) -> Decoder
-ansiDecoder specialChars = defaultMode
-  where
-    -- Make a production and return to `defaultMode`.
-    produce   :: [Event] -> ([Event], Decoder)
-    produce es = (es, defaultMode)
-    -- Continue processing with the given decoder.
-    -- Shall be used for state/mode change.
-    continue  :: Decoder -> ([Event], Decoder)
-    continue d = ([], d)
-
-    -- The default mode is the decoder's entry point and is returned to
-    -- after each successful sequence decoding or as fail safe mode after
-    -- occurences of illegal state (this decoder shall skip errors and will
-    -- probably resynchronise on the input stream after a few characters).
-    defaultMode :: Decoder
-    defaultMode  = Decoder $ \mods c-> if
-        -- In normal mode a NUL is interpreted as a fill character and skipped.
-        | c == '\NUL' -> produce []
-        -- ESC might or might not introduce an escape sequence.
-        | c == '\ESC' -> continue escapeMode
-        -- All other C0 control codes are mapped to their corresponding ASCII character + CTRL modifier.
-        -- If the character is a special character, then two events are produced.
-        | c <= '\US'  -> produce $ KeyEvent (CharKey (toEnum $ (+64) $ fromEnum c)) (mods <> ctrlKey) : specialKey mods c
-        -- Space shall be interpreted as control code and translated to `SpaceKey` to be
-        -- consistent with the handling of `TabKey` and other whitespaces.
-        | c == '\SP'  -> produce [KeyEvent SpaceKey mods]
-        -- All remaning characters of the Latin-1 block are returned as is.
-        | c <  '\DEL' -> produce [KeyEvent (CharKey c) mods]
-        -- DEL is a very delicate case. It might be `KeyBackspace` or `KeyDelete`.
-        | c == '\DEL' -> produce $ KeyEvent (CharKey '?') (mods <> ctrlKey) : specialKey mods c
-        -- Skip all other C1 control codes excpect if they are special characters.
-        | c <  '\xA0' -> produce $ specialKey mods c
-        -- All other Unicode characters are returned as is.
-        | otherwise   -> produce $ KeyEvent (CharKey c) mods : specialKey mods c
-        where
-          specialKey mods c = case specialChars c of
-            Nothing -> []
-            Just ev -> case ev of
-              KeyEvent key m -> [KeyEvent key (mods <> m)]
-              _              -> [ev]
-
-    -- This function shall be called if an ESC has been read in default mode
-    -- and it is stil unclear whether this is the beginning of an escape sequence or not.
-    -- NOTE: This function is total and consumes at least one more character of input.
-    escapeMode :: Decoder
-    escapeMode  = Decoder $ \mods c-> if
-      -- Single escape key press is always followed by a NUL fill character
-      -- by design (instead of timing). This makes reasoning and testing much easier
-      -- and reliable.
-      | c == '\NUL' -> produce [KeyEvent (CharKey '[') (mods <> ctrlKey), KeyEvent EscapeKey mods]
-      | otherwise   -> continue (escapeSequenceMode c)
-
-    -- This function shall be called with the escape sequence introducer.
-    -- It needs to look at next character to decide whether this is
-    -- a CSI sequence or an ALT-modified key or illegal state.
-    escapeSequenceMode :: Char -> Decoder
-    escapeSequenceMode c = Decoder $ \mods d-> if
-      | d == '\NUL' && c > '\SP' && c <= '~' -> produce [KeyEvent (CharKey c) (mods <> altKey)]
-      | d == '\NUL' && c >= '\xa0'           -> produce [KeyEvent (CharKey c) (mods <> altKey)]
-      | d == '\NUL'                          -> produce $ case specialChars c of
-                                                  Nothing -> []
-                                                  Just ev -> case ev of
-                                                    KeyEvent key m -> [KeyEvent key (mods <> m <> altKey)]
-                                                    _              -> [ev]
-      | c == 'O'                             -> produce (ss3Mode mods d)
-      | c == '['                             -> csiMode d
-      | otherwise                            -> produce []
-
-    -- SS3 mode is another less well-known escape sequence mode.
-    -- It is introduced by `\\ESCO`. Some terminal emulators use it for
-    -- compatibility with veeery old terminals. SS3 mode only allows one
-    -- subsequent character. Interpretation has been determined empirically
-    -- and with reference to http://rtfm.etla.org/xterm/ctlseq.html
-    ss3Mode :: Modifiers -> Char -> [Event]
-    ss3Mode mods = \case
-      'P' -> [KeyEvent (FunctionKey  1) mods]
-      'Q' -> [KeyEvent (FunctionKey  2) mods]
-      'R' -> [KeyEvent (FunctionKey  3) mods]
-      'S' -> [KeyEvent (FunctionKey  4) mods]
-      _   -> []
-
-    -- ESC[ is followed by any number (including none) of parameter chars in the
-    -- range 0–9:;<=>?, then by any number of intermediate chars
-    -- in the range space and !"#$%&'()*+,-./, then finally by a single char in
-    -- the range @A–Z[\]^_`a–z{|}~.
-    -- For security reasons (untrusted input and denial of service) this parser
-    -- only accepts a very limited number of characters for both parameter and
-    -- intermediate chars.
-    -- Unknown (not illegal) sequences are dropped, but it is guaranteed that
-    -- they will be consumed completely and it is safe for the parser to
-    -- return to normal mode afterwards. Illegal sequences cause the parser
-    -- to consume the input up to the first violating character and then reject.
-    -- The parser might be out of sync afterwards, but this is a protocol
-    -- violation anyway. The parser's only job here is not to loop (consume
-    -- and drop the illegal input!) and then to stop and fail reliably.
-    csiMode :: Char -> ([Event], Decoder)
-    csiMode c
-      | c >= '0' && c <= '?' = continue $ f (charLimit - 1) [c]
-      | c >= '!' && c <= '/' = continue $ g (charLimit - 1) [] [c]
-      | c >= '@' && c <= '~' = produce $ interpretCSI [] [] c
-      | otherwise            = produce [] -- Illegal state. Return to default mode.
-      where
-        charLimit :: Int
-        charLimit  = 16
-        -- Note: The following functions use recursion, but recursion is
-        -- guaranteed to terminate and maximum recursion depth is only
-        -- dependant on the constant `charLimit`. In case of errors the decoder
-        -- will therefore recover to default mode after at most 32 characters.
-        f :: Int -> String -> Decoder
-        f 0 _  = defaultMode
-        f i ps = Decoder $ const $ \x-> if
-          | x >= '0' && x <= '?' -> continue $ f (i - 1) (x:ps)  -- More parameters.
-          | x >= '!' && x <= '/' -> continue $ g charLimit ps [] -- Start of intermediates.
-          | x >= '@' && x <= '~' -> produce $ interpretCSI (reverse ps) [] x
-          | otherwise            -> produce [] -- Illegal state. Return to default mode.
-        g :: Int -> String -> String -> Decoder
-        g 0 _  _  = defaultMode
-        g i ps is = Decoder $ const $ \x-> if
-          | x >= '!' && x <= '/' -> continue $ g (i - 1) ps (x:is) -- More intermediates.
-          | x >= '@' && x <= '~' -> produce $ interpretCSI (reverse ps) (reverse is) x
-          | otherwise            -> produce [] -- Illegal state. Return to default mode.
-
-interpretCSI :: String -> String -> Char -> [Event]
-interpretCSI params _intermediates = \case
-  '$'        -> [KeyEvent DeleteKey (altKey `mappend` shiftKey)]  -- urxvt, gnome-terminal
-  '@'        -> []
-  'A'        -> modified $ ArrowKey Upwards
-  'B'        -> modified $ ArrowKey Downwards
-  'C'        -> modified $ ArrowKey Rightwards
-  'D'        -> modified $ ArrowKey Leftwards
-  'E'        -> modified   BeginKey
-  'F'        -> modified   EndKey
-  'G'        -> []
-  'H'        -> modified   HomeKey
-  'I'        -> modified   TabKey
-  'J'        -> []
-  'K'        -> []
-  'L'        -> []
-  'M'        -> []
-  'N'        -> []
-  'O'        -> []
-  'P'        -> modified (FunctionKey  1)
-  'Q'        -> modified (FunctionKey  2)
-  -- This sequence is ambiguous. xterm and derivatives use this to encode a modified F3 key as
-  -- well as a cursor position report. There is no real solution to disambiguate these two
-  -- other than context of expectation (cursor position report has probably been requested).
-  -- This decoder shall simply emit both events and the user shall ignore unexpected events.
-  'R'        -> modified (FunctionKey  3) ++ [DeviceEvent $ CursorPositionReport (fstNumber 1 - 1, sndNumber 1 - 1)]
-  'S'        -> modified (FunctionKey  4)
-  'T'        -> []
-  'U'        -> []
-  'V'        -> []
-  'W'        -> []
-  'X'        -> []
-  'Y'        -> []
-  'Z'        -> [KeyEvent TabKey shiftKey]
-  '^'        -> case params of
-    "2"  -> [KeyEvent InsertKey        ctrlKey]
-    "3"  -> [KeyEvent DeleteKey        ctrlKey]
-    "4"  -> [KeyEvent PageUpKey        ctrlKey]
-    "7"  -> [KeyEvent PageDownKey      ctrlKey]
-    "5"  -> [KeyEvent HomeKey          ctrlKey]
-    "6"  -> [KeyEvent EndKey           ctrlKey]
-    "11" -> [KeyEvent (FunctionKey  1) ctrlKey]
-    "12" -> [KeyEvent (FunctionKey  2) ctrlKey]
-    "13" -> [KeyEvent (FunctionKey  3) ctrlKey]
-    "14" -> [KeyEvent (FunctionKey  4) ctrlKey]
-    "15" -> [KeyEvent (FunctionKey  5) ctrlKey]
-    "17" -> [KeyEvent (FunctionKey  6) ctrlKey]
-    "18" -> [KeyEvent (FunctionKey  7) ctrlKey]
-    "19" -> [KeyEvent (FunctionKey  8) ctrlKey]
-    "20" -> [KeyEvent (FunctionKey  9) ctrlKey]
-    "21" -> [KeyEvent (FunctionKey 10) ctrlKey]
-    "23" -> [KeyEvent (FunctionKey 11) ctrlKey]
-    "24" -> [KeyEvent (FunctionKey 12) ctrlKey]
-    _    -> []
-  'f' -> []
-  'i' -> [KeyEvent PrintKey mempty]
-  'm' -> []
-  '~' -> case fstParam of
-    "2"  -> modified InsertKey
-    "3"  -> modified DeleteKey
-    "5"  -> modified PageUpKey
-    "6"  -> modified PageDownKey
-    "9"  -> modified HomeKey
-    "10" -> modified EndKey
-    "11" -> modified (FunctionKey 1)
-    "12" -> modified (FunctionKey 2)
-    "13" -> modified (FunctionKey 3)
-    "14" -> modified (FunctionKey 4)
-    "15" -> modified (FunctionKey 5)
-    "17" -> modified (FunctionKey 6)
-    "18" -> modified (FunctionKey 7)
-    "19" -> modified (FunctionKey 8)
-    "20" -> modified (FunctionKey 9)
-    "21" -> modified (FunctionKey 10)
-    "23" -> modified (FunctionKey 11)
-    "24" -> modified (FunctionKey 12)
-    _    -> []
-  _ -> []
-  where
-    fstParam :: String
-    fstParam = takeWhile (/= ';') params
-    sndParam :: String
-    sndParam = takeWhile (/= ';') $ drop 1 $ dropWhile (/= ';') params
-    fstNumber :: Int -> Int
-    fstNumber i
-      | not (null fstParam) && all isDigit fstParam = read fstParam
-      | otherwise                                   = i
-    sndNumber :: Int -> Int
-    sndNumber i
-      | not (null sndParam) && all isDigit sndParam = read sndParam
-      | otherwise                                   = i
-    modified key = case sndParam of
-      ""  -> [KeyEvent key   mempty                       ]
-      "2" -> [KeyEvent key   shiftKey                     ]
-      "3" -> [KeyEvent key               altKey           ]
-      "4" -> [KeyEvent key $ shiftKey <> altKey           ]
-      "5" -> [KeyEvent key                         ctrlKey]
-      "6" -> [KeyEvent key $ shiftKey <>           ctrlKey]
-      "7" -> [KeyEvent key $             altKey <> ctrlKey]
-      "8" -> [KeyEvent key $ shiftKey <> altKey <> ctrlKey]
-      _   -> []

@@ -1,169 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-module Control.Monad.Terminal.Input where--import           Control.Monad.IO.Class-import           Control.Monad.STM-import           Data.Bits-import           Data.List---- | This monad describes an environment that maintains a stream of `Event`s---   and offers out-of-band signaling for interrupts.------     * An interrupt shall occur if the user either presses CTRL+C---       or any other mechanism the environment designates for that purpose.---     * Implementations shall maintain an interrupt flag that is set---       when an interrupt occurs. Computations in this monad shall check and---       reset this flag regularly. If the execution environment finds this---       flag still set when trying to signal another interrupt, it shall---       throw `Control.Exception.AsyncException.UserInterrupt` to the---       seemingly unresponsive computation.---     * When an interrupt is signaled through the flag, an `Event.InterruptEvent`---       must be added to the event stream in the same transaction.---       This allows to flush all unprocessed events from the stream that---       occured before the interrupt.-class (MonadIO m) => MonadInput m where-  -- | Wait for the next interrupt or the next event transformed by a given mapper.-  ---  --    * The first mapper parameter is a transaction that succeeds as-  --      soon as the interrupt flag gets set. Executing this transaction-  --      resets the interrupt flag. If the interrupt flag is not reset-  --      before a second interrupt occurs, the current thread shall-  --      receive an `Control.Exception.AsyncException.UserInterrupt`.-  --    * The second mapper parameter is a transaction that succeeds as-  --      as soon as the next event arrives and removes that event from the-  --      stream of events. It may be executed several times within the same-  --      transaction, but might not succeed every time.-  waitMapInterruptAndEvents :: (STM () -> STM Event -> STM a) -> m a---- | Wait for the next event.------    * Returns as soon as an event occurs.---    * This operation resets the interrupt flag it returns,---      signaling responsiveness to the execution environment.---    * `Event.InterruptEvent`s occur in the event stream at their correct---      position wrt to ordering of events. They are returned as regular---      events. This is eventually not desired when trying to handle interrupts---      with highest priority and `waitInterruptOrElse` should be considered then.-waitEvent :: MonadInput m => m Event-waitEvent = waitMapInterruptAndEvents $ \intr evs->-  (intr `orElse` pure ()) >> evs---- | Wait simultaneously for the next event or a given transaction.------    * Returns as soon as either an event occurs or the given transaction---      succeeds.---    * This operation resets the interrupt flag whenever it returns,---      signaling responsiveness to the execution environment.---    * `Event.InterruptEvent`s occur in the event stream at their correct---      position wrt to ordering of events. They are returned as regular---      events. This is eventually not desired when trying to handle interrupts---      with highest priority and `waitInterruptOrElse` should be considered then.-waitEventOrElse :: MonadInput m => STM a -> m (Either Event a)-waitEventOrElse stma = waitMapInterruptAndEvents $ \intr evs->-  (intr `orElse` pure ()) >> ((Prelude.Left <$> evs) `orElse` (Prelude.Right <$> stma))---- | Wait simultaneously for the next interrupt or a given transaction.------    * Returns `Nothing` on interrupt and `Just` when the supplied transaction---      succeeds first.---    * This operation resets the interrupt flag, signaling responsiveness---      to the execution environment.---    * All pending events up to and including the `InterruptEvent` are flushed---      from the event stream in case of an interrupt.-waitInterruptOrElse :: MonadInput m => STM a -> m (Maybe a)-waitInterruptOrElse stma = waitMapInterruptAndEvents $ \intr evs->-  (intr >> dropTillInterruptEvent evs >> pure Nothing) `orElse` (Just <$> stma)-  where-    dropTillInterruptEvent :: STM Event -> STM ()-    dropTillInterruptEvent evs = ((Just <$> evs) `orElse` pure Nothing) >>= \case-      Nothing             -> pure ()-      Just InterruptEvent -> pure ()-      _                   -> dropTillInterruptEvent evs--data Key-  = CharKey Char-  | TabKey-  | SpaceKey-  | BackspaceKey-  | EnterKey-  | InsertKey-  | DeleteKey-  | HomeKey      -- ^ Pos 1-  | BeginKey-  | EndKey-  | PageUpKey-  | PageDownKey-  | EscapeKey-  | PrintKey-  | PauseKey-  | ArrowKey Direction-  | FunctionKey Int-  deriving (Eq,Ord,Show)--newtype Modifiers = Modifiers Int-  deriving (Eq, Ord, Bits)--instance Semigroup Modifiers where-  Modifiers a <> Modifiers b = Modifiers (a .|. b)--instance Monoid Modifiers where-  mempty = Modifiers 0--instance Show Modifiers where-  show (Modifiers 0) = "mempty"-  show (Modifiers 1) = "shiftKey"-  show (Modifiers 2) = "ctrlKey"-  show (Modifiers 4) = "altKey"-  show (Modifiers 8) = "metaKey"-  show i = "(" ++ intercalate " <> " ls ++ ")"-    where-      ls = foldl (\acc x-> if x .&. i /= mempty then show x:acc else acc) []-                 [metaKey, altKey, ctrlKey, shiftKey]--shiftKey, ctrlKey, altKey, metaKey :: Modifiers-shiftKey = Modifiers 1-ctrlKey  = Modifiers 2-altKey   = Modifiers 4-metaKey  = Modifiers 8--data Event-  = KeyEvent Key Modifiers-  | MouseEvent MouseEvent-  | WindowEvent WindowEvent-  | DeviceEvent DeviceEvent-  | InterruptEvent-  | OtherEvent String-  deriving (Eq,Ord,Show)--data MouseEvent-  = MouseMoved          (Int,Int)-  | MouseButtonPressed  (Int,Int) MouseButton-  | MouseButtonReleased (Int,Int) MouseButton-  | MouseButtonClicked  (Int,Int) MouseButton-  | MouseWheeled        (Int,Int) Direction-  deriving (Eq,Ord,Show)--data MouseButton-  = LeftMouseButton-  | RightMouseButton-  | OtherMouseButton-  deriving (Eq,Ord,Show)--data Direction-  = Upwards-  | Downwards-  | Leftwards-  | Rightwards-  deriving (Eq,Ord,Show)--data WindowEvent-  = WindowLostFocus-  | WindowGainedFocus-  | WindowSizeChanged (Int,Int)-  deriving (Eq, Ord, Show)--data DeviceEvent-  = DeviceAttributesReport String-  | CursorPositionReport (Int,Int)-  deriving (Eq, Ord, Show)

@@ -1,62 +0,0 @@-module Control.Monad.Terminal.Monad where
-
-import           Control.Monad.Terminal.Input
-import           Control.Monad.Terminal.Printer
-
-class (MonadInput m, MonadPrettyPrinter m, MonadFormatPrinter m, MonadColorPrinter m) => MonadTerminal m where
-  -- | Move the cursor `n` lines up. Do not change column.
-  moveCursorUp                :: Int -> m ()
-  -- | Move the cursor `n` lines down. Do not change column.
-  moveCursorDown              :: Int -> m ()
-  -- | Move the cursor `n` columns to the left. Do not change line.
-  moveCursorLeft              :: Int -> m ()
-  -- | Move the cursor `n` columns to the right. Do not change line.
-  moveCursorRight             :: Int -> m ()
-  -- | Get the current cursor position. `(0,0) is the upper left of the screen.
-  getCursorPosition           :: m (Int, Int)
-  -- | Set the cursor position. `(0,0)` is the upper left of the screen.
-  setCursorPosition           :: (Int,Int) -> m ()
-  -- | Set the vertical cursor position to the `n`th line. Do not change column.
-  setCursorPositionVertical   :: Int -> m ()
-  -- | Set the horizontal cursor position to the `n`th column. Do not change line.
-  setCursorPositionHorizontal :: Int -> m ()
-  -- | Save the current cursor position to be restored later by `restoreCursorPosition`.
-  saveCursorPosition          :: m ()
-  -- | Restore cursor to position previously saved by `saveCursorPosition`.
-  restoreCursorPosition       :: m ()
-  -- | Show the cursor.
-  showCursor                  :: m ()
-  -- | Hide the cursor.
-  hideCursor                  :: m ()
-
-  -- | Clear the entire line containing the cursor.
-  clearLine                   :: m ()
-  -- | Clear the line from cursor left.
-  clearLineLeft               :: m ()
-  -- | Clear the line from cursor right.
-  clearLineRight              :: m ()
-  -- | Clear the entire screen.
-  clearScreen                 :: m ()
-  -- | Clear the screen above the cursor.
-  clearScreenAbove            :: m ()
-  -- | Clear the screen below the cursor.
-  clearScreenBelow            :: m ()
-
-  getScreenSize               :: m (Int,Int)
-  -- | Whether or not to use the alternate screen buffer.
-  --
-  --   - The main screen buffer content is preserved and restored
-  --     when leaving the alternate screen screen buffer.
-  --   - The dimensions of the alternate screen buffer are
-  --     exactly those of the screen.
-  useAlternateScreenBuffer    :: Bool -> m ()
-
--- http://www.noah.org/python/pexpect/ANSI-X3.64.htm
--- Erasing parts of the display (EL and ED) in the VT100 is performed thus:
---
---  Erase from cursor to end of line           Esc [ 0 K    or Esc [ K
---  Erase from beginning of line to cursor     Esc [ 1 K
---  Erase line containing cursor               Esc [ 2 K
---  Erase from cursor to end of screen         Esc [ 0 J    or Esc [ J
---  Erase from beginning of screen to cursor   Esc [ 1 J
---  Erase entire screen                        Esc [ 2 J

@@ -1,192 +0,0 @@-{-# LANGUAGE TypeFamilies #-}
-module Control.Monad.Terminal.Printer where
-
-import           Data.Text
-import           Data.Text.Prettyprint.Doc
-
-import           Prelude                   hiding (putChar)
-
--- | This class describes an environment that Unicode text can be printed to.
---   This might either be file or a terminal.
---
---    * Instances shall implement the concept of lines and line width.
---    * Instances shall implement the concept of a carriage that can be
---      set to the beginning of the next line.
---    * It is assumed that the carriage automatically moves to the beginning
---      of the next line if the end of the current line is reached.
---    * Instances shall be Unicode aware or must at least be able to print
---      a replacement character.
---    * Implementations must be aware of infinite lazy `Prelude.String`s and
---      long `Data.Text.Text`s. `String`s should be printed character wise as
---      evaluating them might trigger exceptions at any point. Long text should
---      be printed chunk wise in order to stay interruptible.
---    * Implementations must not use an unbounded output buffer. Print operations
---      shall block and be interruptible when the output buffer is full.
---    * Instances shall not interpret any control characters but
---      \\n (new line, as generated by `putLn`, and \\t (horizontal tabulator).
---    * Especially escape sequences shall be filtered or at least defused
---      by removing the leading \\ESC. Text formatting shall be done with the
---      designated classes like `MonadPrettyPrinter`, `MonadFormatPrinter`
---      and `MonadColorPrinter`. Allowing control sequences would cause a
---      dependency on certain terminal types, but might also be an underrated
---      security risk as modern terminals are highly programmable and should
---      not be fed with untrusted input.
-class Monad m => MonadPrinter m where
-  -- | Move the carriage to the beginning of the next line.
-  putLn              :: m ()
-  putLn               = putChar '\n'
-  -- | Print a single printable character or one of the allowed control characters.
-  putChar            :: Char -> m ()
-  -- | Print a `String`.
-  putString          :: String -> m ()
-  putString           = mapM_ putChar
-  -- | Print a `String` and an additional newline.
-  putStringLn        :: String -> m ()
-  putStringLn s       = putString s >> putLn
-  -- | Print a `Text`.
-  putText            :: Text -> m ()
-  putText             = putString . Data.Text.unpack
-  -- | Print a `Text` and an additional newline.
-  putTextLn          :: Text -> m ()
-  putTextLn           = putStringLn . Data.Text.unpack
-  -- | Flush the output buffer and make the all previous output actually
-  --   visible after a reasonably short amount of time.
-  --
-  --    * The operation may return before the buffer has actually been flushed.
-  flush              :: m ()
-  flush               = pure ()
-  -- | Get the current line width.
-  --
-  --    * The operation may return the last known line width and may not be
-  --      completely precise when I/O is asynchronous.
-  --    * This operations shall not block too long and rather be called more
-  --      often in order to adapt to changes in line width.
-  getLineWidth       :: m Int
-  {-# MINIMAL putChar, getLineWidth #-}
-
--- | This class is the foundation for all environments that allow
---   annotated text and `Doc`uments to be printed to.
---
---    * Prefer using the `Data.Text.Prettyprint.Doc` module and the
---      `putDoc` operation whenever trying to print structured or
---      formatted text as it automatically deals with nested annotations
---      and the current line width.
-class MonadPrinter m => MonadPrettyPrinter m where
-  -- | This associated type represents all possible annotations that are available
-  --   in the current environment.
-  --
-  --   When writing polymorphic code against these monadic interfaces
-  --   the concrete instantiation of this type is usually unknown and class
-  --   instances are generally advised to not expose value constructors for
-  --   this type.
-  --
-  --   Instead, subclasses like `MonadFormatPrinter` and `MonadColorPrinter`
-  --   offer abstract value constructors like `bold`, `underlined`, `inverted`
-  --   which are then given meaning by the concrete class instance. The
-  --   environment `Control.Monad.Terminal.Ansi.AnsiTerminalT` for example
-  --   implements all of these classes.
-  data Annotation m
-  -- | Print an annotated `Doc`.
-  --
-  --   * This operation performs `resetAnnotations` on entry and on exit.
-  --   * This operation can deal with nested annotations (see example).
-  --
-  -- Example:
-  --
-  -- @
-  -- {-# LANGUAGE OverloadedStrings #-}
-  -- import Control.Monad.Terminal
-  -- import Data.Text.Prettyprint.Doc
-  --
-  -- printer :: (`MonadFormatPrinter` m, `MonadColorPrinter` m) => m ()
-  -- printer = `putDoc` $ `annotate` (foreground $ `bright` `Blue`) "This is blue!" <> `line`
-  --                 <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again")
-  --
-  -- otherDoc :: (`MonadColorPrinter` m, `Annotation` m ~ ann) => `Doc` ann
-  -- otherDoc = `annotate` (`background` $ `dull` `Red`) " BOLD ON RED BACKGROUND "
-  -- @
-  --
-  -- Note the necessary unification of `Annotation` `m` and `ann` in the definition of `otherDoc`!
-  putDoc           :: Doc (Annotation m) -> m ()
-  -- | Like `putDoc` but adds an additional newline.
-  putDocLn         :: Doc (Annotation m) -> m ()
-  putDocLn doc      = putDoc doc >> putLn
-  -- | Set an annotation so that it affects subsequent output.
-  setAnnotation    :: Annotation m -> m ()
-  setAnnotation _   = pure ()
-  -- | Reset an annotation so that it does no longer affect subsequent output.
-  --
-  -- * Binary attributes like `bold` or `underlined` shall just be reset to their opposite.
-  --
-  -- * For non-binary attributes like colors all of their possible values shall be treated
-  --   as equal, so that
-  --
-  --   @
-  --   `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`foreground` $ `dull` `Red`)
-  --   @
-  --
-  --   results in the foreground color attribute reset afterwards whereas after
-  --
-  --   @
-  --   `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`background` $ `dull` `Red`)
-  --   @
-  --
-  --   the foreground color is still set as `bright` `Blue`.
-  --
-  resetAnnotation  :: Annotation m -> m ()
-  resetAnnotation _ = pure ()
-  -- | Reset all annotations to their default.
-  resetAnnotations :: m ()
-  resetAnnotations  = pure ()
-  {-# MINIMAL putDoc, setAnnotation, resetAnnotation, resetAnnotations #-}
-
-pprint :: (MonadPrettyPrinter m, Pretty a) => a -> m ()
-pprint  = putDocLn . pretty
-
--- | This class offers abstract constructors for text formatting
---   annotations.
-class MonadPrettyPrinter m => MonadFormatPrinter m where
-  -- | This annotation makes text appear __bold__.
-  bold            :: Annotation m
-  -- | This annotation makes text appear /italic/.
-  italic          :: Annotation m
-  -- | This annotation makes text appear underlined.
-  underlined      :: Annotation m
-
--- | This class offers abstract value constructors for
---   foreground and background coloring.
-class MonadPrettyPrinter m => MonadColorPrinter m where
-  -- | This annotation swaps foreground and background color.
-  --
-  --   * This operation is idempotent: Applying the annotation a second time
-  --     won't swap it back. Use `resetAnnotation` instead.
-  inverted        :: Annotation m
-  -- | This annotation sets the __foreground__ color (the text color).
-  foreground      :: Color -> Annotation m
-  -- | This annotation sets the __background__ color.
-  background      :: Color -> Annotation m
-
-data Color = Color ColorMode BasicColor
-  deriving (Eq, Ord, Show)
-
-data ColorMode
-  = Dull
-  | Bright
-  deriving (Eq, Ord, Show)
-
-data BasicColor
-  = Black
-  | Red
-  | Green
-  | Yellow
-  | Blue
-  | Magenta
-  | Cyan
-  | White
-  deriving (Eq, Ord, Show)
-
-dull :: BasicColor -> Color
-dull = Color Dull
-
-bright :: BasicColor -> Color
-bright = Color Bright

@@ -1,55 +0,0 @@-module Control.Monad.Terminal.Terminal where
-
-import           Control.Monad.STM
-import           Data.ByteString
-import           Data.Text
-
-import           Control.Monad.Terminal.Input
-
-data Terminal
-  = Terminal
-  { -- | The terminal identification string usually extracted from the
-    --   environment variable `TERM`. Should contain values like `xterm`
-    --   or `rxvt-unicode`.
-    termType         :: ByteString
-    -- | A stream of input events. The transaction will succeed as soon as the
-    --   next input event becomes available.
-    --
-    --   Note: Trying to read more than one event within the same transaction
-    --   might be successfull, but might also lead to undesired behaviour as
-    --   the transaction will block until all of its preconditions are fulfilled.
-    --   Some form of `orElse` needs to be used in a correct way for reading
-    --   several events at once.
-  , termInput        :: STM Event
-    -- | This transaction appends a piece of `Data.Text.Text` to the output buffer.
-    --   It shall block when the buffer exeeded its capacity
-    --   and unblock as soon as space becomes available again.
-    --
-    --   Note: All implementations must limit the size of the output buffer or
-    --   the application is at risk of running out of memory when writing much
-    --   faster than the terminal can read. Using a `Control.Concurrent.STM.TMVar.TMVar`
-    --   as a buffer of size 1 is perfectly fine here.
-  , termOutput       :: Text -> STM ()
-    -- | This transaction succeeds as soon as an interrupt event occurs.
-    --   Executing the transaction shall reset an interrupt flag maintained
-    --   by a supervising background thread.
-    --
-    --   It is mandatory to regularly check this transaction in order to signal
-    --   responsiveness to the background thread. The supervisor is otherwise
-    --   advised to terminate the program as soon as a second interrupt arrives.
-    --
-    --   Note: This is a very low-level operation. Operations like `waitEvent`,
-    --   `waitEventOrElse` or `waitInterruptOrElse` are more convenient and do
-    --   this automatically.
-  , termInterrupt    :: STM ()
-    -- | This operations flushes the output buffer. Whether it blocks or
-    --   not until the buffer has actually been flushed shall be undefined
-    --   (there might be other buffers involved that cannot be force-flushed
-    --   so it is probably better to not give any guarantees here).
-  , termFlush        :: STM ()
-    -- | This transaction shall return the latest known screen size without
-    --   blocking. The first parameter denotes the number of rows and the
-    --   one the number of columns.
-  , termScreenSize   :: STM (Int, Int)
-  , termSpecialChars :: Char -> Maybe Event
-  }

@@ -1,255 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TypeFamilies               #-}
-module Control.Monad.Terminal.TerminalT
-  ( TerminalT ()
-  , runTerminalT
-  )
-where
-
-import           Control.Concurrent.STM.TChan
-import           Control.Concurrent.STM.TVar
-import qualified Control.Exception               as E
-import           Control.Monad                   (when)
-import           Control.Monad.Catch
-import           Control.Monad.IO.Class
-import           Control.Monad.STM
-import           Control.Monad.Trans.Class
-import           Control.Monad.Trans.Reader
-import           Data.Foldable                   (forM_)
-import qualified Data.Text                       as Text
-import qualified Data.Text.Prettyprint.Doc       as PP
-
-import qualified Control.Monad.Terminal.Decoder  as T
-import qualified Control.Monad.Terminal.Input    as T
-import qualified Control.Monad.Terminal.Monad    as T
-import qualified Control.Monad.Terminal.Printer  as T
-import qualified Control.Monad.Terminal.Terminal as T
-
-newtype TerminalT m a
-  = TerminalT (ReaderT T.Terminal m a)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
-
-runTerminalT :: (MonadIO m, MonadMask m) => TerminalT m a -> T.Terminal -> m a
-runTerminalT (TerminalT action) ansi = do
-  eventsChan <- liftIO newTChanIO
-  decoderVar <- liftIO $ newTVarIO $ T.ansiDecoder $ T.termSpecialChars ansi
-  runReaderT action ansi { T.termInput = nextEvent eventsChan decoderVar }
-  where
-    -- This function transforms the incoming raw event stream and sends
-    -- parts of it (all plain characters) through the ANSI decoder.
-    -- It does this in a transactional way whereas it is important that
-    -- each input event creates _at least one_ immediate output event.
-    -- This means: When feeding input characters to the decoder it
-    -- is necessary to emit one intermediate event after each character that
-    -- has been fed into the decoder. Otherwise the transaction
-    -- will fail and the actual modification to the decoder won't happen.
-    nextEvent eventsChan decoderVar = do
-      processRawEvent `orElse` pure () -- Even without a new raw event there might be events pending.
-      readTChan eventsChan
-      where
-        processRawEvent = T.termInput ansi >>= \case
-            T.KeyEvent (T.CharKey c) mods -> do
-              -- NB: This event is essential as it guarantees the whole transaction
-              -- to succeed by having at least one event in the `events` channel.
-              -- This information is also quite nice for debbuging.
-              writeTChan eventsChan (T.OtherEvent $ "ANSI decoder: Feeding character " ++ show c ++ ", modifiers " ++ show mods ++ ".")
-              -- Feed the decoder, save its new state and write its output to the
-              -- events chan (if any).
-              decoder <- readTVar decoderVar
-              let (ansiEvents, decoder') = T.feedDecoder decoder mods c
-              writeTVar decoderVar decoder'
-              forM_ ansiEvents (writeTChan eventsChan)
-            event -> writeTChan eventsChan event
-
-instance MonadTrans TerminalT where
-  lift = TerminalT . lift
-
-instance (MonadIO m) => T.MonadInput (TerminalT m) where
-  waitMapInterruptAndEvents f = TerminalT $ do
-    ansi <- ask
-    liftIO $ atomically $ f (T.termInterrupt ansi) (T.termInput ansi)
-
-instance (MonadIO m, MonadThrow m) => T.MonadPrinter (TerminalT m) where
-  putChar c = TerminalT $ do
-    ansi <- ask
-    when (safeChar c) $
-      liftIO $ atomically $ T.termOutput ansi $! Text.singleton c
-  putString cs = TerminalT $ do
-    ansi <- ask
-    liftIO $ forM_ (filter safeChar cs) $ \c->
-      atomically $ T.termOutput ansi $! Text.singleton c
-  putText t = TerminalT $ do
-    ansi <- ask
-    liftIO $ loop (atomically . T.termOutput ansi) (Text.filter safeChar t)
-    where
-      loop out t0
-        | Text.null t0 = pure ()
-        | otherwise    = let (t1,t2) = Text.splitAt 80 t0
-                         in  out t1 >> loop out t2
-  flush = TerminalT $ do
-    ansi <- ask
-    liftIO  $ atomically $ T.termFlush ansi
-  getLineWidth = snd <$> T.getScreenSize
-
-instance (MonadIO m, MonadThrow m) => T.MonadPrettyPrinter (TerminalT m) where
-  data Annotation (TerminalT m)
-    = Bold
-    | Italic
-    | Underlined
-    | Inverted
-    | Foreground T.Color
-    | Background T.Color deriving (Eq, Ord, Show)
-  putDocLn doc = T.putDoc doc >> T.putLn
-  putDoc doc = do
-    w <- T.getLineWidth
-    T.resetAnnotations
-    render [] (sdoc w)
-    T.resetAnnotations
-    T.flush
-    where
-      options w   = PP.defaultLayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine w 1.0 }
-      sdoc w      = PP.layoutSmart (options w) doc
-      oldFG []               = Nothing
-      oldFG (Foreground c:_) = Just c
-      oldFG (_:xs)           = oldFG xs
-      oldBG []               = Nothing
-      oldBG (Background c:_) = Just c
-      oldBG (_:xs)           = oldBG xs
-      render anns = \case
-        PP.SFail           -> pure ()
-        PP.SEmpty          -> pure ()
-        PP.SChar c ss      -> T.putChar c >> render anns ss
-        PP.SText _ t ss    -> T.putText t >> render anns ss
-        PP.SLine n ss      -> T.putLn >> T.putText (Text.replicate n " ") >> render anns ss
-        PP.SAnnPush ann ss -> T.setAnnotation ann >> render (ann:anns) ss
-        PP.SAnnPop ss      -> case anns of
-          []                     -> render [] ss
-          (Bold         :anns')
-            | Bold       `elem` anns' -> pure ()
-            | otherwise               -> T.resetAnnotation Bold       >> render anns' ss
-          (Italic       :anns')
-            | Italic     `elem` anns' -> pure ()
-            | otherwise               -> T.resetAnnotation Italic     >> render anns' ss
-          (Underlined   :anns')
-            | Underlined `elem` anns' -> pure ()
-            | otherwise               -> T.resetAnnotation Underlined >> render anns' ss
-          (Inverted     :anns')
-            | Inverted   `elem` anns' -> pure ()
-            | otherwise               -> T.resetAnnotation Inverted   >> render anns' ss
-          (Foreground c :anns') -> case oldFG anns' of
-            Just d  -> T.setAnnotation   (Foreground d) >> render anns' ss
-            Nothing -> T.resetAnnotation (Foreground c) >> render anns' ss
-          (Background c :anns') -> case oldBG anns' of
-            Just d  -> T.setAnnotation   (Background d) >> render anns' ss
-            Nothing -> T.resetAnnotation (Background c) >> render anns' ss
-
-  setAnnotation Bold                                      = write "\ESC[1m"
-  setAnnotation Italic                                    = pure ()
-  setAnnotation Underlined                                = write "\ESC[4m"
-  setAnnotation Inverted                                  = write "\ESC[7m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Black  )) = write "\ESC[30m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Red    )) = write "\ESC[31m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Green  )) = write "\ESC[32m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Yellow )) = write "\ESC[33m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Blue   )) = write "\ESC[34m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Magenta)) = write "\ESC[35m"
-  setAnnotation (Foreground (T.Color T.Dull   T.Cyan   )) = write "\ESC[36m"
-  setAnnotation (Foreground (T.Color T.Dull   T.White  )) = write "\ESC[37m"
-  setAnnotation (Foreground (T.Color T.Bright T.Black  )) = write "\ESC[90m"
-  setAnnotation (Foreground (T.Color T.Bright T.Red    )) = write "\ESC[91m"
-  setAnnotation (Foreground (T.Color T.Bright T.Green  )) = write "\ESC[92m"
-  setAnnotation (Foreground (T.Color T.Bright T.Yellow )) = write "\ESC[93m"
-  setAnnotation (Foreground (T.Color T.Bright T.Blue   )) = write "\ESC[94m"
-  setAnnotation (Foreground (T.Color T.Bright T.Magenta)) = write "\ESC[95m"
-  setAnnotation (Foreground (T.Color T.Bright T.Cyan   )) = write "\ESC[96m"
-  setAnnotation (Foreground (T.Color T.Bright T.White  )) = write "\ESC[97m"
-  setAnnotation (Background (T.Color T.Dull   T.Black  )) = write "\ESC[40m"
-  setAnnotation (Background (T.Color T.Dull   T.Red    )) = write "\ESC[41m"
-  setAnnotation (Background (T.Color T.Dull   T.Green  )) = write "\ESC[42m"
-  setAnnotation (Background (T.Color T.Dull   T.Yellow )) = write "\ESC[43m"
-  setAnnotation (Background (T.Color T.Dull   T.Blue   )) = write "\ESC[44m"
-  setAnnotation (Background (T.Color T.Dull   T.Magenta)) = write "\ESC[45m"
-  setAnnotation (Background (T.Color T.Dull   T.Cyan   )) = write "\ESC[46m"
-  setAnnotation (Background (T.Color T.Dull   T.White  )) = write "\ESC[47m"
-  setAnnotation (Background (T.Color T.Bright T.Black  )) = write "\ESC[100m"
-  setAnnotation (Background (T.Color T.Bright T.Red    )) = write "\ESC[101m"
-  setAnnotation (Background (T.Color T.Bright T.Green  )) = write "\ESC[102m"
-  setAnnotation (Background (T.Color T.Bright T.Yellow )) = write "\ESC[103m"
-  setAnnotation (Background (T.Color T.Bright T.Blue   )) = write "\ESC[104m"
-  setAnnotation (Background (T.Color T.Bright T.Magenta)) = write "\ESC[105m"
-  setAnnotation (Background (T.Color T.Bright T.Cyan   )) = write "\ESC[106m"
-  setAnnotation (Background (T.Color T.Bright T.White  )) = write "\ESC[107m"
-  resetAnnotation Bold           = write "\ESC[22m"
-  resetAnnotation Italic         = pure ()
-  resetAnnotation Underlined     = write "\ESC[24m"
-  resetAnnotation Inverted       = write "\ESC[27m"
-  resetAnnotation (Foreground _) = write "\ESC[39m"
-  resetAnnotation (Background _) = write "\ESC[49m"
-  resetAnnotations               = write "\ESC[m"
-
-instance (MonadIO m, MonadThrow m) => T.MonadFormatPrinter (TerminalT m) where
-  bold       = Bold
-  italic     = Italic
-  underlined = Underlined
-
-instance (MonadIO m, MonadThrow m) => T.MonadColorPrinter (TerminalT m) where
-  inverted   = Inverted
-  foreground = Foreground
-  background = Background
-
-instance (MonadIO m, MonadThrow m) => T.MonadTerminal (TerminalT m) where
-  moveCursorUp i                         = write $ "\ESC[" <> Text.pack (show i) <> "A"
-  moveCursorDown i                       = write $ "\ESC[" <> Text.pack (show i) <> "B"
-  moveCursorLeft i                       = write $ "\ESC[" <> Text.pack (show i) <> "D"
-  moveCursorRight i                      = write $ "\ESC[" <> Text.pack (show i) <> "C"
-  getCursorPosition = do
-    write "\ESC[6n"
-    T.flush
-    waitForCursorPositionReport
-    where
-      -- Swallow all incoming events until either a cursor position report
-      -- arrives or an Interrupt event occurs.
-      -- An interrupt event will cause an `E.UserInterrupt` exception to be thrown.
-      waitForCursorPositionReport = T.waitEvent >>= \case
-        T.InterruptEvent                           -> throwM E.UserInterrupt
-        T.DeviceEvent (T.CursorPositionReport pos) -> pure pos
-        _ -> waitForCursorPositionReport
-  setCursorPosition (x,y)                = write $ "\ESC[" <> Text.pack (show $ x + 1) <> ";" <> Text.pack (show $ y + 1) <> "H"
-  setCursorPositionVertical i            = write $ "\ESC[" <> Text.pack (show $ i + 1) <> "d"
-  setCursorPositionHorizontal i          = write $ "\ESC[" <> Text.pack (show $ i + 1) <> "G"
-  saveCursorPosition                     = write "\ESC7"
-  restoreCursorPosition                  = write "\ESC8"
-  showCursor                             = write "\ESC[?25h"
-  hideCursor                             = write "\ESC[?25l"
-
-  clearLine                              = write "\ESC[2K"
-  clearLineLeft                          = write "\ESC[1K"
-  clearLineRight                         = write "\ESC[0K"
-  clearScreen                            = write "\ESC[2J"
-  clearScreenAbove                       = write "\ESC[1J"
-  clearScreenBelow                       = write "\ESC[0J"
-
-  getScreenSize = TerminalT $ do
-    ansi <- ask
-    liftIO $ atomically $ T.termScreenSize ansi
-
-  useAlternateScreenBuffer          True = write "\ESC[?1049h"
-  useAlternateScreenBuffer         False = write "\ESC[?1049l"
-
--- | See https://en.wikipedia.org/wiki/List_of_Unicode_characters
-safeChar :: Char -> Bool
-safeChar c
-  | c == '\n'   = True  -- Newline
-  | c == '\t'   = True  -- Horizontal tab
-  | c  < '\SP'  = False -- All other C0 control characters.
-  | c  < '\DEL' = True  -- Printable remainder of ASCII. Start of C1.
-  | c  < '\xa0' = False -- C1 up to start of Latin-1.
-  | otherwise   = True
-
-write :: (MonadIO m) => Text.Text -> TerminalT m ()
-write t = TerminalT $ do
-  ansi <- ask
-  liftIO $ atomically $ T.termOutput ansi t

@@ -1,14 +1,81 @@ module System.Terminal-  ( Terminal (..)-  , withTerminal+  ( -- * Getting started+    -- ** withTerminal+    withTerminal+    -- ** TerminalT+  , runTerminalT+  , TerminalT ()+    -- * Printing & Screen Modification+    -- ** MonadPrinter+  , MonadPrinter (..)+    -- *** MonadMarkupPrinter+  , MonadMarkupPrinter (..)+    -- *** MonadFormattingPrinter+  , MonadFormattingPrinter (..)+    -- *** MonadColorPrinter+  , MonadColorPrinter (..)+    -- *** Pretty Printing+  , putDoc+  , putDocLn+  , putPretty+  , putPrettyLn+  , putSimpleDocStream+    -- ** MonadScreen+  , MonadScreen (..)+  , Size (..)+  , Position (..)+  , EraseMode (..)+    -- ** MonadTerminal+  , MonadTerminal+    -- * Event Processing+  , MonadInput (..)+    -- *** awaitEvent+  , awaitEvent+    -- *** checkInterrupt+  , checkInterrupt+    -- ** Events+  , Event (..)+  , Interrupt (..)+    -- *** Keys & Modifiers+  , Key (..)+  , Modifiers ()+  , shiftKey+  , ctrlKey+  , altKey+  , metaKey+  , Direction (..)+    -- *** Mouse Events+  , MouseEvent (..)+  , MouseButton (..)+    -- *** Window Events+  , WindowEvent (..)+    -- *** Device Events+  , DeviceEvent (..)   ) where -import           Control.Monad.Catch      (MonadMask)-import           Control.Monad.IO.Class   (MonadIO)+import           Control.Monad.Catch+import           Control.Monad.IO.Class -import           Control.Monad.Terminal-import qualified System.Terminal.Platform as Platform+import           System.Terminal.MonadInput+import           System.Terminal.MonadPrinter+import           System.Terminal.MonadScreen+import           System.Terminal.MonadTerminal+import           System.Terminal.Pretty+import           System.Terminal.TerminalT+import qualified System.Terminal.Platform --- | (Indirection just for upcoming documentation).-withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a-withTerminal  = Platform.withTerminal+-- | Run the given handler with the locally connected terminal (`System.IO.stdin` / `System.IO.stdout`).+--+-- @+-- import System.Terminal+--+-- main :: IO ()+-- main = withTerminal $ `runTerminalT` do+--     `putTextLn` "Hello there, please press a button!"+--     `flush`+--     ev <- `waitEvent`+--     `putStringLn` $ "Event was " ++ show ev+--     `flush`+-- @+withTerminal :: (MonadIO m, MonadMask m) => (System.Terminal.Platform.LocalTerminal -> m a) -> m a+withTerminal = System.Terminal.Platform.withTerminal

@@ -0,0 +1,218 @@+module System.Terminal.Decoder where
+
+import           Data.Char
+import           Data.Monoid                  ((<>))
+
+import           System.Terminal.MonadInput
+import           System.Terminal.MonadScreen (Position (..))
+
+-- | The type `Decoder` is a finite state transducer.
+--
+--   Intermediate state can be passed as closure.
+--   See below for an example.
+newtype Decoder = Decoder { feedDecoder :: Modifiers -> Char -> Either Decoder [Event] }
+
+defaultDecoder :: (Modifiers -> Char -> Maybe Event) -> Decoder
+defaultDecoder specialChar = defaultMode
+  where
+    -- The default mode is the decoder's entry point.
+    defaultMode :: Decoder
+    defaultMode  = Decoder $ \mods c-> if
+        -- In normal mode a NUL is interpreted as a fill character and skipped.
+        | c == '\NUL' -> Right []
+        -- ESC might or might not introduce an escape sequence.
+        | c == '\ESC' -> Left escapeMode
+        -- All other C0 control codes are mapped to their corresponding ASCII character + CTRL modifier.
+        -- If the character is a special character, then two events are produced.
+        | c <= '\US'  -> Right $ [KeyEvent (CharKey (toEnum $ (+64) $ fromEnum c)) (mods <> ctrlKey)] ++ f mods c
+        -- All remaning characters of the Latin-1 block are returned as is.
+        | c <  '\DEL' -> Right $ [KeyEvent (CharKey c) mods] ++ f mods c
+        -- Skip all other C1 control codes and DEL unless they have special meaning configured.
+        | c <  '\xA0' -> Right $ f mods c
+        -- All other Unicode characters are returned as is.
+        | otherwise   -> Right [KeyEvent (CharKey c) mods]
+        where
+            f mods c = maybe [] pure (specialChar mods c)
+
+    -- This function shall be called if an ESC has been read in default mode
+    -- and it is stil unclear whether this is the beginning of an escape sequence or not.
+    -- NOTE: This function is total and consumes at least one more character of input.
+    escapeMode :: Decoder
+    escapeMode  = Decoder $ \mods c-> if
+      -- Single escape key press is always followed by a NUL fill character
+      -- by design (instead of timing). This makes reasoning and testing much easier
+      -- and reliable.
+      | c == '\NUL' -> Right [KeyEvent (CharKey '[') (mods <> ctrlKey), KeyEvent EscapeKey mods]
+      | otherwise   -> Left (escapeSequenceMode c)
+
+    -- This function shall be called with the escape sequence introducer.
+    -- It needs to look at next character to decide whether this is
+    -- a CSI sequence or an ALT-modified key or illegal state.
+    escapeSequenceMode :: Char -> Decoder
+    escapeSequenceMode c = Decoder $ \mods d-> if
+      | d == '\NUL' && c > '\SP' && c <= '~' -> Right [KeyEvent (CharKey c) (mods <> altKey)]
+      | d == '\NUL' && c >= '\xa0'           -> Right [KeyEvent (CharKey c) (mods <> altKey)]
+      | d == '\NUL'                          -> Right $ case specialChar mods c of
+                                                  Nothing -> []
+                                                  Just ev -> case ev of
+                                                    KeyEvent key m -> [KeyEvent key (mods <> m <> altKey)]
+                                                    _              -> [ev]
+      | c == 'O'                             -> Right (ss3Mode mods d)
+      | c == '['                             -> csiMode d
+      | otherwise                            -> Right []
+
+    -- SS3 mode is another less well-known escape sequence mode.
+    -- It is introduced by `\\ESCO`. Some terminal emulators use it for
+    -- compatibility with veeery old terminals. SS3 mode only allows one
+    -- subsequent character. Interpretation has been determined empirically
+    -- and with reference to http://rtfm.etla.org/xterm/ctlseq.html
+    ss3Mode :: Modifiers -> Char -> [Event]
+    ss3Mode mods = \case
+      'P' -> [KeyEvent (FunctionKey  1) mods]
+      'Q' -> [KeyEvent (FunctionKey  2) mods]
+      'R' -> [KeyEvent (FunctionKey  3) mods]
+      'S' -> [KeyEvent (FunctionKey  4) mods]
+      _   -> []
+
+    -- ESC[ is followed by any number (including none) of parameter chars in the
+    -- range 0–9:;<=>?, then by any number of intermediate chars
+    -- in the range space and !"#$%&'()*+,-./, then finally by a single char in
+    -- the range @A–Z[\]^_`a–z{|}~.
+    -- For security reasons (untrusted input and denial of service) this parser
+    -- only accepts a very limited number of characters for both parameter and
+    -- intermediate chars.
+    -- Unknown (not illegal) sequences are dropped, but it is guaranteed that
+    -- they will be consumed completely and it is safe for the parser to
+    -- return to normal mode afterwards. Illegal sequences cause the parser
+    -- to consume the input up to the first violating character and then reject.
+    -- The parser might be out of sync afterwards, but this is a protocol
+    -- violation anyway. The parser's only job here is not to loop (consume
+    -- and drop the illegal input!) and then to stop and fail reliably.
+    csiMode :: Char -> Either Decoder [Event]
+    csiMode c
+      | c >= '0' && c <= '?' = Left $ f (charLimit - 1) [c]
+      | c >= '!' && c <= '/' = Left $ g (charLimit - 1) [] [c]
+      | c >= '@' && c <= '~' = Right $ interpretCSI [] [] c
+      | otherwise            = Right [] -- Illegal state. Return to default mode.
+      where
+        charLimit :: Int
+        charLimit  = 16
+        -- Note: The following functions use recursion, but recursion is
+        -- guaranteed to terminate and maximum recursion depth is only
+        -- dependant on the constant `charLimit`. In case of errors the decoder
+        -- will therefore recover to default mode after at most 32 characters.
+        f :: Int -> String -> Decoder
+        f 0 _  = defaultMode
+        f i ps = Decoder $ const $ \x-> if
+          | x >= '0' && x <= '?' -> Left $ f (i - 1) (x:ps)  -- More parameters.
+          | x >= '!' && x <= '/' -> Left $ g charLimit ps [] -- Start of intermediates.
+          | x >= '@' && x <= '~' -> Right $ interpretCSI (reverse ps) [] x
+          | otherwise            -> Right [] -- Illegal state. Return to default mode.
+        g :: Int -> String -> String -> Decoder
+        g 0 _  _  = defaultMode
+        g i ps is = Decoder $ const $ \x-> if
+          | x >= '!' && x <= '/' -> Left $ g (i - 1) ps (x:is) -- More intermediates.
+          | x >= '@' && x <= '~' -> Right $ interpretCSI (reverse ps) (reverse is) x
+          | otherwise            -> Right [] -- Illegal state. Return to default mode.
+
+interpretCSI :: String -> String -> Char -> [Event]
+interpretCSI params _intermediates = \case
+  '$'        -> [KeyEvent DeleteKey (altKey `mappend` shiftKey)]  -- urxvt, gnome-terminal
+  '@'        -> []
+  'A'        -> modified $ ArrowKey Upwards
+  'B'        -> modified $ ArrowKey Downwards
+  'C'        -> modified $ ArrowKey Rightwards
+  'D'        -> modified $ ArrowKey Leftwards
+  'E'        -> modified   BeginKey
+  'F'        -> modified   EndKey
+  'G'        -> []
+  'H'        -> modified   HomeKey
+  'I'        -> modified   TabKey
+  'J'        -> []
+  'K'        -> []
+  'L'        -> []
+  'M'        -> []
+  'N'        -> []
+  'O'        -> []
+  'P'        -> modified (FunctionKey  1)
+  'Q'        -> modified (FunctionKey  2)
+  -- This sequence is ambiguous. xterm and derivatives use this to encode a modified F3 key as
+  -- well as a cursor position report. There is no real solution to disambiguate these two
+  -- other than context of expectation (cursor position report has probably been requested).
+  -- This decoder shall simply emit both events and the user shall ignore unexpected events.
+  'R'        -> modified (FunctionKey  3) ++ [DeviceEvent $ CursorPositionReport $ Position (fstNumber 1 - 1) (sndNumber 1 - 1)]
+  'S'        -> modified (FunctionKey  4)
+  'T'        -> []
+  'U'        -> []
+  'V'        -> []
+  'W'        -> []
+  'X'        -> []
+  'Y'        -> []
+  'Z'        -> [KeyEvent TabKey shiftKey]
+  '^'        -> case params of
+    "2"  -> [KeyEvent InsertKey        ctrlKey]
+    "3"  -> [KeyEvent DeleteKey        ctrlKey]
+    "4"  -> [KeyEvent PageUpKey        ctrlKey]
+    "7"  -> [KeyEvent PageDownKey      ctrlKey]
+    "5"  -> [KeyEvent HomeKey          ctrlKey]
+    "6"  -> [KeyEvent EndKey           ctrlKey]
+    "11" -> [KeyEvent (FunctionKey  1) ctrlKey]
+    "12" -> [KeyEvent (FunctionKey  2) ctrlKey]
+    "13" -> [KeyEvent (FunctionKey  3) ctrlKey]
+    "14" -> [KeyEvent (FunctionKey  4) ctrlKey]
+    "15" -> [KeyEvent (FunctionKey  5) ctrlKey]
+    "17" -> [KeyEvent (FunctionKey  6) ctrlKey]
+    "18" -> [KeyEvent (FunctionKey  7) ctrlKey]
+    "19" -> [KeyEvent (FunctionKey  8) ctrlKey]
+    "20" -> [KeyEvent (FunctionKey  9) ctrlKey]
+    "21" -> [KeyEvent (FunctionKey 10) ctrlKey]
+    "23" -> [KeyEvent (FunctionKey 11) ctrlKey]
+    "24" -> [KeyEvent (FunctionKey 12) ctrlKey]
+    _    -> []
+  'f' -> []
+  'i' -> [KeyEvent PrintKey mempty]
+  'm' -> []
+  '~' -> case fstParam of
+    "2"  -> modified InsertKey
+    "3"  -> modified DeleteKey
+    "5"  -> modified PageUpKey
+    "6"  -> modified PageDownKey
+    "9"  -> modified HomeKey
+    "10" -> modified EndKey
+    "11" -> modified (FunctionKey 1)
+    "12" -> modified (FunctionKey 2)
+    "13" -> modified (FunctionKey 3)
+    "14" -> modified (FunctionKey 4)
+    "15" -> modified (FunctionKey 5)
+    "17" -> modified (FunctionKey 6)
+    "18" -> modified (FunctionKey 7)
+    "19" -> modified (FunctionKey 8)
+    "20" -> modified (FunctionKey 9)
+    "21" -> modified (FunctionKey 10)
+    "23" -> modified (FunctionKey 11)
+    "24" -> modified (FunctionKey 12)
+    _    -> []
+  _ -> []
+  where
+    fstParam :: String
+    fstParam = takeWhile (/= ';') params
+    sndParam :: String
+    sndParam = takeWhile (/= ';') $ drop 1 $ dropWhile (/= ';') params
+    fstNumber :: Int -> Int
+    fstNumber i
+      | not (null fstParam) && all isDigit fstParam = read fstParam
+      | otherwise                                   = i
+    sndNumber :: Int -> Int
+    sndNumber i
+      | not (null sndParam) && all isDigit sndParam = read sndParam
+      | otherwise                                   = i
+    modified key = case sndParam of
+      ""  -> [KeyEvent key   mempty                       ]
+      "2" -> [KeyEvent key   shiftKey                     ]
+      "3" -> [KeyEvent key               altKey           ]
+      "4" -> [KeyEvent key $ shiftKey <> altKey           ]
+      "5" -> [KeyEvent key                         ctrlKey]
+      "6" -> [KeyEvent key $ shiftKey <>           ctrlKey]
+      "7" -> [KeyEvent key $             altKey <> ctrlKey]
+      "8" -> [KeyEvent key $ shiftKey <> altKey <> ctrlKey]
+      _   -> []

@@ -0,0 +1,128 @@+module System.Terminal.Encoder where++import qualified Data.Text as T++import           System.Terminal.Terminal+import           System.Terminal.MonadScreen++-- | See https://en.wikipedia.org/wiki/List_of_Unicode_characters+safeChar :: Char -> Bool+safeChar c+  | c  < '\SP'  = False -- All other C0 control characters.+  | c  < '\DEL' = True  -- Printable remainder of ASCII. Start of C1.+  | c  < '\xa0' = False -- C1 up to start of Latin-1.+  | otherwise   = True+{-# INLINE safeChar #-}++sanitizeChar :: Char -> Char+sanitizeChar c = if safeChar c then c else '�'+{-# INLINE sanitizeChar #-}++sanitizeText :: T.Text -> T.Text+sanitizeText t+    | T.any (not . safeChar) t = T.map sanitizeChar t+    | otherwise                = t+{-# INLINE sanitizeText #-}++defaultEncode :: Command -> T.Text+defaultEncode = \case+    PutLn                                    -> "\n"+    PutText t                                -> sanitizeText t+    SetAttribute Bold                        -> "\ESC[1m"+    SetAttribute Italic                      -> ""+    SetAttribute Underlined                  -> "\ESC[4m"+    SetAttribute Inverted                    -> "\ESC[7m"+    SetAttribute (Foreground       Black  )  -> "\ESC[30m"+    SetAttribute (Foreground       Red    )  -> "\ESC[31m"+    SetAttribute (Foreground       Green  )  -> "\ESC[32m"+    SetAttribute (Foreground       Yellow )  -> "\ESC[33m"+    SetAttribute (Foreground       Blue   )  -> "\ESC[34m"+    SetAttribute (Foreground       Magenta)  -> "\ESC[35m"+    SetAttribute (Foreground       Cyan   )  -> "\ESC[36m"+    SetAttribute (Foreground       White  )  -> "\ESC[37m"+    SetAttribute (Foreground BrightBlack  )  -> "\ESC[90m"+    SetAttribute (Foreground BrightRed    )  -> "\ESC[91m"+    SetAttribute (Foreground BrightGreen  )  -> "\ESC[92m"+    SetAttribute (Foreground BrightYellow )  -> "\ESC[93m"+    SetAttribute (Foreground BrightBlue   )  -> "\ESC[94m"+    SetAttribute (Foreground BrightMagenta)  -> "\ESC[95m"+    SetAttribute (Foreground BrightCyan   )  -> "\ESC[96m"+    SetAttribute (Foreground BrightWhite  )  -> "\ESC[97m"+    SetAttribute (Background       Black  )  -> "\ESC[40m"+    SetAttribute (Background       Red    )  -> "\ESC[41m"+    SetAttribute (Background       Green  )  -> "\ESC[42m"+    SetAttribute (Background       Yellow )  -> "\ESC[43m"+    SetAttribute (Background       Blue   )  -> "\ESC[44m"+    SetAttribute (Background       Magenta)  -> "\ESC[45m"+    SetAttribute (Background       Cyan   )  -> "\ESC[46m"+    SetAttribute (Background       White  )  -> "\ESC[47m"+    SetAttribute (Background BrightBlack  )  -> "\ESC[100m"+    SetAttribute (Background BrightRed    )  -> "\ESC[101m"+    SetAttribute (Background BrightGreen  )  -> "\ESC[102m"+    SetAttribute (Background BrightYellow )  -> "\ESC[103m"+    SetAttribute (Background BrightBlue   )  -> "\ESC[104m"+    SetAttribute (Background BrightMagenta)  -> "\ESC[105m"+    SetAttribute (Background BrightCyan   )  -> "\ESC[106m"+    SetAttribute (Background BrightWhite  )  -> "\ESC[107m"+    ResetAttribute Bold                      -> "\ESC[22m"+    ResetAttribute Italic                    -> ""+    ResetAttribute Underlined                -> "\ESC[24m"+    ResetAttribute Inverted                  -> "\ESC[27m"+    ResetAttribute (Foreground _)            -> "\ESC[39m"+    ResetAttribute (Background _)            -> "\ESC[49m"+    ResetAttributes                          -> "\ESC[m"+    ShowCursor                               -> "\ESC[?25h"+    HideCursor                               -> "\ESC[?25l"+    SaveCursor                               -> "\ESC7"+    RestoreCursor                            -> "\ESC8"+    MoveCursorUp          i | i <= 0         -> ""+                            | i == 0         -> "\ESC[A"+                            | otherwise      -> "\ESC[" <> T.pack (show i) <> "A"+    MoveCursorDown        i | i <= 0         -> ""+                            | i == 0         -> "\ESC[B"+                            | otherwise      -> "\ESC[" <> T.pack (show i) <> "B"+    MoveCursorForward     i | i <= 0         -> ""+                            | i == 0         -> "\ESC[C"+                            | otherwise      -> "\ESC[" <> T.pack (show i) <> "C"+    MoveCursorBackward    i | i <= 0         -> ""+                            | i == 0         -> "\ESC[D"+                            | otherwise      -> "\ESC[" <> T.pack (show i) <> "D"+    GetCursorPosition                        -> "\ESC[6n"+    SetCursorPosition (Position x y)         -> "\ESC[" <> T.pack (show $ x + 1) <> ";" <> T.pack (show $ y + 1) <> "H"+    SetCursorRow      i                      -> "\ESC[" <> T.pack (show $ i + 1) <> "d"+    SetCursorColumn   i                      -> "\ESC[" <> T.pack (show $ i + 1) <> "G"+    InsertChars i   | i <= 0                 -> ""+                    | i == 1                 -> "\ESC[@"+                    | otherwise              -> "\ESC[" <> T.pack (show i) <> "@"+    DeleteChars i   | i <= 0                 -> ""+                    | i == 1                 -> "\ESC[P"+                    | otherwise              -> "\ESC[" <> T.pack (show i) <> "P"+    EraseChars  i   | i <= 0                 -> ""+                    | i == 1                 -> "\ESC[X"+                    | otherwise              -> "\ESC[" <> T.pack (show i) <> "X"+    InsertLines i   | i <= 0                 -> ""+                    | i == 1                 -> "\ESC[L"+                    | otherwise              -> "\ESC[" <> T.pack (show i) <> "L"+    DeleteLines i   | i <= 0                 -> ""+                    | i == 1                 -> "\ESC[M"+                    | otherwise              -> "\ESC[" <> T.pack (show i) <> "M"+    EraseInLine     EraseForward             -> "\ESC[0K"+    EraseInLine     EraseBackward            -> "\ESC[1K"+    EraseInLine     EraseAll                 -> "\ESC[2K"+    EraseInDisplay  EraseForward             -> "\ESC[0J"+    EraseInDisplay  EraseBackward            -> "\ESC[1J"+    EraseInDisplay  EraseAll                 -> "\ESC[2J"+    SetAutoWrap True                         -> "\ESC[?7h"+    SetAutoWrap False                        -> "\ESC[?7l"+    SetAlternateScreenBuffer True            -> "\ESC[?1049h"+    SetAlternateScreenBuffer False           -> "\ESC[?1049l"++-- http://www.noah.org/python/pexpect/ANSI-X3.64.htm+-- Erasing parts of the display (EL and ED) in the VT100 is performed thus:+--+--  Erase from cursor to end of line           Esc [ 0 K    or Esc [ K+--  Erase from beginning of line to cursor     Esc [ 1 K+--  Erase line containing cursor               Esc [ 2 K+--  Erase from cursor to end of screen         Esc [ 0 J    or Esc [ J+--  Erase from beginning of screen to cursor   Esc [ 1 J+--  Erase entire screen                        Esc [ 2 J

@@ -0,0 +1,22 @@+module System.Terminal.Internal (+    -- ** Terminal+      Terminal (..)+    , Command (..)+    , Attribute (..)+    , Color (..)+    , Decoder (..)+    , defaultDecoder+    , defaultEncode+      -- ** LocalTerminal+    , System.Terminal.Platform.LocalTerminal ()+      -- ** VirtualTerminal (for testing)+    , VirtualTerminal (..)+    , VirtualTerminalSettings (..)+    , withVirtualTerminal+    ) where++import System.Terminal.Decoder+import System.Terminal.Encoder+import System.Terminal.Terminal+import System.Terminal.Platform+import System.Terminal.Virtual

@@ -0,0 +1,167 @@+module System.Terminal.MonadInput where++import           Control.Applicative ((<|>))+import           Control.Monad.IO.Class+import           Control.Monad.STM+import           Data.Bits+import           Data.List++import           System.Terminal.MonadScreen++-- | This monad describes an environment that maintains a stream of `Event`s+--   and offers out-of-band signaling for interrupts.+--+--  * An interrupt shall occur if the user either presses CTRL+C+--    or any other mechanism the environment designates for that purpose.+--  * Implementations shall maintain an interrupt flag that is set+--    when an interrupt occurs. Computations in this monad shall check and+--    reset this flag regularly. If the execution environment finds this+--    flag still set when trying to signal another interrupt, it shall+--    throw `Control.Exception.AsyncException.UserInterrupt` to the+--    seemingly unresponsive computation.+class (MonadIO m) => MonadInput m where+    -- | Wait for the next interrupt or next event transformed by a given mapper.+    --+    -- * The first mapper parameter is a transaction that succeeds as+    --   soon as an interrupt occurs. Executing this transaction+    --   resets the interrupt flag. When a second interrupt occurs before+    --   the interrupt flag has been reset, the current thread shall+    --   receive an `Control.Exception.AsyncException.UserInterrupt`.+    -- * The second mapper parameter is a transaction that succeeds as+    --   as soon as the next event arrives and removes that event from the+    --   stream of events. It shall be executed at most once within a single+    --   transaction or the transaction would block until the requested number+    --   of events is available.+    -- * The mapper may also be used in order to additionally wait on external+    --   events (like an `Control.Monad.Async.Async` to complete).+    awaitWith :: (STM Interrupt -> STM Event -> STM a) -> m a++-- | Wait for the next event.+--+-- * Returns as soon as an interrupt or a regular event occurs.+-- * This operation resets the interrupt flag, signaling responsiveness to+--   the execution environment.+awaitEvent :: MonadInput m => m (Either Interrupt Event)+awaitEvent = awaitWith$ \intr ev ->+    (Left <$> intr) <|> (Right <$> ev)++-- | Check whether an interrupt is pending.+--+-- * This operation resets the interrupt flag, signaling responsiveness+--   to the execution environment.+checkInterrupt :: MonadInput m => m Bool+checkInterrupt = awaitWith $ \intr _ ->+    (intr >> pure True) <|> pure False++-- | Events emitted by the terminal.+--+-- * Event decoding might be ambique. In case of ambiqueness all+--   possible meaning shall be emitted. The user is advised to only+--   match on events expected in a certain context and ignore all+--   others.+-- * Key events are highly ambique: I.e. when the user presses @space@+--   it might either be meant as a regular text element (like @a@,@b@,@c@)+--   or the focus is on the key itself (like in "Press space to continue...").+-- * The story is even more complicated: Depending on terminal type and+--   @termios@ settings, certain control codes have special meaning or not+--   (@Ctrl+C@ sometimes means interrupt, but not if the environment supports+--   delivering it as a signal). Don't wait for @Ctrl+C@ when you mean `Interrupt`!+--   Example: The tab key will likely emit @KeyEvent (CharKey 'I') ctrlKey@ and+--   @KeyEvent TabKey mempty@ in most settings.+data Event+    = KeyEvent Key Modifiers+    | MouseEvent MouseEvent+    | WindowEvent WindowEvent+    | DeviceEvent DeviceEvent+    | OtherEvent String+    deriving (Eq,Ord,Show)++-- | Events triggered by key press.+data Key+    = CharKey Char+    | TabKey+    | SpaceKey+    | BackspaceKey+    | EnterKey+    | InsertKey+    | DeleteKey+    | HomeKey+    | BeginKey+    | EndKey+    | PageUpKey+    | PageDownKey+    | EscapeKey+    | PrintKey+    | PauseKey+    | ArrowKey Direction+    | FunctionKey Int+    deriving (Eq,Ord,Show)++-- | Modifier keys.+newtype Modifiers = Modifiers Int+    deriving (Eq, Ord, Bits)++instance Semigroup Modifiers where+    Modifiers a <> Modifiers b = Modifiers (a .|. b)++instance Monoid Modifiers where+    mempty = Modifiers 0++instance Show Modifiers where+    show (Modifiers 0) = "mempty"+    show (Modifiers 1) = "shiftKey"+    show (Modifiers 2) = "ctrlKey"+    show (Modifiers 4) = "altKey"+    show (Modifiers 8) = "metaKey"+    show i = "(" ++ intercalate " <> " ls ++ ")"+        where+        ls = foldl (\acc x-> if x .&. i /= mempty then show x:acc else acc) []+                    [metaKey, altKey, ctrlKey, shiftKey]++shiftKey, ctrlKey, altKey, metaKey :: Modifiers+shiftKey = Modifiers 1+ctrlKey  = Modifiers 2+altKey   = Modifiers 4+metaKey  = Modifiers 8++-- | Events triggered by mouse action.+--+-- * Mouse event reporting must be activated before (TODO).+data MouseEvent+    = MouseMoved          Position+    | MouseButtonPressed  Position MouseButton+    | MouseButtonReleased Position MouseButton+    | MouseButtonClicked  Position MouseButton+    | MouseWheeled        Position Direction+    deriving (Eq,Ord,Show)++data MouseButton+    = LeftMouseButton+    | RightMouseButton+    | OtherMouseButton+    deriving (Eq,Ord,Show)++data Direction+    = Upwards+    | Downwards+    | Leftwards+    | Rightwards+    deriving (Eq,Ord,Show)++data WindowEvent+    = WindowLostFocus+    | WindowGainedFocus+    | WindowSizeChanged+    deriving (Eq, Ord, Show)++data DeviceEvent+    = DeviceAttributesReport String+    | CursorPositionReport Position+    deriving (Eq, Ord, Show)++-- | Interrupt is a special type of event that needs+--   to be treated with priority. It is therefor not+--   included in the regular event stream.+data Interrupt+    = Interrupt+    deriving (Eq, Ord, Show)

@@ -0,0 +1,138 @@+{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE FlexibleContexts #-}+module System.Terminal.MonadPrinter where++import           Data.Text                     as T+import           Prelude                   hiding (putChar)++-- | This class describes an environment that Unicode text can be printed to.+--   This might either be file or a terminal.+--+--    * Instances shall implement the concept of lines and line width.+--    * Instances shall implement the concept of a carriage that can be+--      set to the beginning of the next line.+--    * It is assumed that the carriage automatically moves to the beginning+--      of the next line if the end of the current line is reached.+--    * Instances shall be Unicode aware or must at least be able to print+--      a replacement character.+--    * Implementations must be aware of infinite lazy `Prelude.String`s and+--      long `Data.Text.Text`s. `String`s should be printed character wise as+--      evaluating them might trigger exceptions at any point. Long text should+--      be printed chunk wise in order to stay interruptible.+--    * Implementations must not use an unbounded output buffer. Print operations+--      shall block and be interruptible when the output buffer is full.+--    * Instances shall not pass control characters in text to the printer (not even line break).+--      Control characters shall be replaced with �. Text formatting shall be done+--      with the designated classes extending `MonadMarkupPrinter`.+--      Allowing control sequences would cause a dependency on certain terminal+--      types, but also pose an underrated security risk as modern terminals are+--      highly programmable and should not be fed with untrusted input.+class Monad m => MonadPrinter m where+    -- | Move the carriage to the beginning of the next line.+    putLn              :: m ()+    -- | Print a single character.+    putChar            :: Char -> m ()+    -- | Print a `String`.+    putString          :: String -> m ()+    putString           = mapM_ putChar+    -- | Print a `String` and an additional newline.+    putStringLn        :: String -> m ()+    putStringLn s       = putString s >> putLn+    -- | Print a `Text`.+    putText            :: Text -> m ()+    putText             = putString . T.unpack+    -- | Print a `Text` and an additional newline.+    putTextLn          :: Text -> m ()+    putTextLn           = putStringLn . T.unpack+    -- | Flush the output buffer and make the all previous output actually+    --   visible after a reasonably short amount of time.+    --+    --    * The operation may return before the buffer has actually been flushed.+    flush              :: m ()+    flush               = pure ()+    -- | Get the current line width.+    --+    --    * The operation may return the last known line width and may not be+    --      completely precise when I/O is asynchronous.+    --    * This operations shall not block too long and rather be called more+    --      often in order to adapt to changes in line width.+    getLineWidth       :: m Int+    {-# MINIMAL putLn, putChar, putText, getLineWidth #-}++-- | This class introduces abstract constructors for text markup.+class MonadPrinter m => MonadMarkupPrinter m where+    -- | This associated type represents all possible attributes that are+    --   available in the current environment.+    --+    --   When writing polymorphic code against these monadic interfaces+    --   the concrete instantiation of this type is usually unknown and class+    --   instances are generally advised to not expose value constructors for+    --   this type.+    --+    --   Instead, subclasses like `MonadFormattingPrinter` and `MonadColorPrinter`+    --   offer abstract value constructors like `bold`, `underlined`, `inverted`+    --   which are then given meaning by the concrete class instance.+    data Attribute m+    setAttribute :: Attribute m -> m ()+    setAttribute _ = pure ()+    -- | Reset an attribute so that it does no longer affect subsequent output.+    --+    -- * Binary attributes like `bold` or `underlined` shall just be reset to their opposite.+    --+    -- * For non-binary attributes like colors all of their possible values shall be treated+    --   as equal, so that+    --+    --   @+    --   `setAttribute` (`foreground` $ `bright` `blue`) >> `resetAttribute` (`foreground` `red`)+    --   @+    --+    --   results in the foreground color attribute reset afterwards whereas after+    --+    --   @+    --   `setAttribute` (`foreground` $ `bright` `blue`) >> `resetAttribute` (`background` `red`)+    --   @+    --+    --   the foreground color is still set as `bright` `blue`.+    --+    resetAttribute  :: Attribute m -> m ()+    -- | Reset all attributes to their default.+    resetAttributes :: m ()+    -- | Shall determine wheter two attribute values would override each other+    --   or can be applied independently.+    --+    -- * Shall obey the laws of equivalence.+    resetsAttribute :: Attribute m -> Attribute m -> Bool++class MonadMarkupPrinter m => MonadFormattingPrinter m where+    -- | This attribute makes text appear __bold__.+    bold            :: Attribute m+    -- | This attribute makes text appear /italic/.+    italic          :: Attribute m+    -- | This attribute makes text appear underlined.+    underlined      :: Attribute m+    -- | This attribute swaps foreground and background (color).+    --+    --   * This operation is idempotent: Applying the attribute a second time+    --     won't swap it back. Use `resetAttribute` instead.+    inverted        :: Attribute m++-- | This class offers abstract value constructors for+--   foreground and background coloring.+class MonadMarkupPrinter m => MonadColorPrinter m where+    data Color m++    black      :: Color m+    red        :: Color m+    green      :: Color m+    yellow     :: Color m+    blue       :: Color m+    magenta    :: Color m+    cyan       :: Color m+    white      :: Color m++    bright     :: Color m -> Color m++    -- | This attribute sets the __foreground__ color (the text color).+    foreground :: Color m -> Attribute m+    -- | This attribute sets the __background__ color.+    background :: Color m -> Attribute m

@@ -0,0 +1,94 @@+module System.Terminal.MonadScreen where++import           System.Terminal.MonadPrinter++data Size = Size+    { height :: {-# UNPACK #-} !Int+    , width  :: {-# UNPACK #-} !Int+    } deriving (Eq, Ord, Show)++data Position = Position+    { row    :: {-# UNPACK #-} !Int+    , col    :: {-# UNPACK #-} !Int+    } deriving (Eq, Ord, Show)++data EraseMode+    = EraseBackward  -- ^ Erase left of/above current cursor position.+    | EraseForward   -- ^ Erase right of/below current cursor position.+    | EraseAll       -- ^ Erase whole line/screen.+    deriving (Eq, Ord, Show)++class (MonadPrinter m) => MonadScreen m where+    -- | Get the dimensions of the visible window.+    getWindowSize               :: m Size+    -- | Move the cursor `n` lines up. Do not change column.+    moveCursorUp                :: Int -> m ()+    -- | Move the cursor `n` lines down. Do not change column.+    moveCursorDown              :: Int -> m ()+    -- | Move the cursor `n` columns to the right. Do not change line.+    moveCursorForward           :: Int -> m ()+    -- | Move the cursor `n` columns to the left. Do not change line.+    moveCursorBackward          :: Int -> m ()+    -- | Get the current cursor position as reported by the terminal.+    --+    -- * @Position 0 0@ is the upper left of the window.+    -- * The cursor is always within window bounds.+    -- * This operation causes a round-trip to the terminal and+    --   shall be used sparely (e.g. on window size change).+    getCursorPosition           :: m Position+    -- | Set the cursor position.+    --+    -- * @Position 0 0@ is the upper left of the window.+    -- * The resulting cursor position is undefined when it is outside+    --   the window bounds.+    setCursorPosition           :: Position -> m ()+    -- | Set the cursor row.+    --+    -- * @0@ is the topmost row.+    setCursorRow                :: Int -> m ()+    -- | Set the cursor column.+    --+    -- * @0@ is the leftmost column.+    setCursorColumn             :: Int -> m ()+    -- | Save cursor position and attributes.+    saveCursor                  :: m ()+    -- | Restore cursor position and attributes.+    --+    -- * Restores the cursor as previously saved by `saveCursor`.+    -- * The cursor position is strictly relative to the visible+    --   window and does not take eventual scrolling into account.+    --   The advantage of this operation is that it does not require+    --   transmission of coordinates and attributes to the terminal+    --   and is therefor slightly more efficient than all other alternatives.+    -- * Only use this when auto-wrap is disabled, alternate screen+    --   buffer is enabled or you can otherwise guarantee that the+    --   window does not scroll between `saveCursor` and `restoreCursor`!+    restoreCursor               :: m ()+    -- | Insert whitespace at the cursor position and+    --   shift existing characters to the right.+    insertChars                 :: Int -> m ()+    -- | Delete characters and shift existing characters from the right.+    deleteChars                 :: Int -> m ()+    -- | Replace characters with whitespace.+    eraseChars                  :: Int -> m ()+    -- | Insert lines and shift existing lines downwards.+    insertLines                 :: Int -> m ()+    -- | Delete lines and shift up existing lines from below.+    deleteLines                 :: Int -> m ()+    -- | Clears characters in the current line.+    eraseInLine                 :: EraseMode -> m ()+    -- | Clears lines above/below the current line.+    eraseInDisplay              :: EraseMode -> m ()+    -- | Show the cursor.+    showCursor                  :: m ()+    -- | Hide the cursor.+    hideCursor                  :: m ()+    -- | Whether or not to automatically wrap on line ends.+    setAutoWrap                 :: Bool -> m ()+    -- | Whether or not to use the alternate screen buffer.+    --+    --   - The main screen buffer content is preserved and restored+    --     when leaving the alternate screen screen buffer.+    --   - The dimensions of the alternate screen buffer are+    --     exactly those of the screen.+    setAlternateScreenBuffer    :: Bool -> m ()

@@ -0,0 +1,8 @@+module System.Terminal.MonadTerminal where++import           System.Terminal.MonadInput+import           System.Terminal.MonadPrinter+import           System.Terminal.MonadScreen++-- | This is a convenience class combining all other terminal related classes.+class (MonadInput m, MonadFormattingPrinter m, MonadColorPrinter m, MonadScreen m) => MonadTerminal m where

@@ -0,0 +1,61 @@+module System.Terminal.Pretty where++import           Data.Text                     as T+import           Data.Text.Prettyprint.Doc+import           Prelude                   hiding (putChar)++import           System.Terminal.MonadPrinter++-- | Print an annotated `Doc`.+--+-- Example:+--+-- @+-- import System.Terminal+-- import Data.Text.Prettyprint.Doc+--+-- printer :: (`MonadFormatingPrinter` m, `MonadColorPrinter` m) => m ()+-- printer = `putDoc` $ `annotate` (foreground $ `bright` `blue`) "This is blue!" <> `line`+--                 <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again")+--+-- otherDoc :: (`MonadColorPrinter` m, `Attribute` m ~ ann) => `Doc` ann+-- otherDoc = `annotate` (`background` `red`) " BOLD ON RED BACKGROUND "+-- @+--+-- Note the necessary unification of `Attribute` `m` and `ann` in the definition of `otherDoc`!+putDoc :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m ()+putDoc doc = do+    w <- getLineWidth+    putSimpleDocStream (sdoc w)+    where+        options w = defaultLayoutOptions { layoutPageWidth = AvailablePerLine w 1.0 }+        sdoc w    = layoutSmart (options w) doc++-- | Like `putDoc` but adds an additional newline.+putDocLn :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m ()+putDocLn doc = putDoc doc >> putLn++-- | Prints types instantiating the `Pretty` class.+putPretty :: (MonadMarkupPrinter m, Pretty a) => a -> m ()+putPretty a = putDoc (pretty a)++-- | Prints types instantiating the `Pretty` class and adds an additional newline.+putPrettyLn :: (MonadMarkupPrinter m, Pretty a) => a -> m ()+putPrettyLn a = putPretty a >> putLn++-- | Prints `SimpleDocStream`s (rather internal and not for the average user).+putSimpleDocStream :: (MonadMarkupPrinter m) => SimpleDocStream (Attribute m) -> m ()+putSimpleDocStream sdoc = do+    resetAttributes+    f [] sdoc+    where+        f _       SFail          = pure ()+        f _       SEmpty         = pure ()+        f    aa  (SChar c    xx) = putChar c                             >> f    aa  xx+        f    aa  (SText _ t  xx) = putText t                             >> f    aa  xx+        f    aa  (SLine i    xx) = putLn >> putText (T.replicate i " ")  >> f    aa  xx+        f    aa  (SAnnPush a xx) = setAttribute a                        >> f (a:aa) xx+        f    []  (SAnnPop    xx) =                                          f    []  xx+        f (a:aa) (SAnnPop    xx) = case Prelude.filter (resetsAttribute a) aa of+            []    -> resetAttribute a >> f aa xx+            (e:_) -> setAttribute   e >> f aa xx

@@ -0,0 +1,123 @@+module System.Terminal.Terminal where++import           Control.Monad.STM+import           Data.ByteString+import           Data.Text++import           System.Terminal.MonadInput+import           System.Terminal.MonadScreen (Size (..), Position (..), EraseMode (..))++-- | Types that represent terminals need to implement this class in order+--   to be driven by this library.+--+-- This library ships with two instances:+--+-- * `System.Terminal.Platform.LocalTerminal` represents the local+--   terminal wired to the process.+-- * `System.Terminal.Virtual.VirtualTerminal` is a minimal in-process+--   terminal emulator designed to be used for unit-testing terminal applications. +class Terminal t where+  -- | The terminal identification string usually extracted from the+  --   environment variable @TERM@. Should contain values like @xterm@+  --   or @rxvt-unicode@.+  termType              :: t -> ByteString+  -- | A stream of input events. The transaction will succeed as soon as the+  --   next input event becomes available.+  --+  --   Note: Trying to read more than one event within the same transaction+  --   might be successfull, but might also lead to undesired behaviour as+  --   the transaction will block until all of its preconditions are fulfilled.+  termEvent             :: t -> STM Event+  -- | This transaction succeeds as soon as an interrupt occurs.+  --   Executing the transaction shall reset an interrupt flag maintained+  --   by a supervising background thread.+  --+  --   It is mandatory to regularly check this transaction in order to signal+  --   responsiveness to the background thread. The execution environment is otherwise+  --   advised to throw an `System.IO.Error.UserInterrupt` exception as soon as a+  --   second interrupt arrives and it sees a previous one unhandled.+  termInterrupt         :: t -> STM Interrupt+  -- | This operation shall send a command to the terminal.+  --   It shall block when the buffer exeeded its capacity+  --   and unblock as soon as space becomes available again.+  --+  --   Note: All implementations must limit the size of the output buffer or+  --   the application is at risk of running out of memory when writing much+  --   faster than the terminal can read.+  termCommand           :: t -> Command -> IO ()+  -- | This operations flushes the output buffer. Whether it blocks or+  --   not until the buffer has actually been flushed shall be undefined+  --   (there might be other buffers involved that cannot be force-flushed+  --   so it is probably better to not give any guarantees here).+  termFlush             :: t -> IO ()+  -- | This operation shall return the latest known window size without+  --   blocking.+  termGetWindowSize     :: t -> IO Size+  -- | This operation shall return the current cursor position.+  --   It may block as depending on implementation it usually requires an+  --   in-band roundtrip to the terminal. Use it wisely.+  termGetCursorPosition :: t -> IO Position++-- | The commands every terminal needs to understand.+--+-- This shall only be extended when something is missing+-- that all terminals understand. Otherwise portability will+-- be lost.+data Command+  = PutLn+  | PutText                  Text+  | SetAttribute             Attribute+  | ResetAttribute           Attribute+  | ResetAttributes+  | MoveCursorUp             Int+  | MoveCursorDown           Int+  | MoveCursorForward        Int+  | MoveCursorBackward       Int+  | ShowCursor+  | HideCursor+  | SaveCursor+  | RestoreCursor+  | GetCursorPosition+  | SetCursorPosition        Position+  | SetCursorRow             Int+  | SetCursorColumn          Int+  | InsertChars              Int+  | DeleteChars              Int+  | EraseChars               Int+  | InsertLines              Int+  | DeleteLines              Int+  | EraseInLine              EraseMode+  | EraseInDisplay           EraseMode+  | SetAutoWrap              Bool+  | SetAlternateScreenBuffer Bool+  deriving (Eq, Ord, Show)++-- | ANSI text attributes.+data Attribute+  = Bold+  | Italic+  | Underlined+  | Inverted+  | Foreground Color+  | Background Color+  deriving (Eq, Ord, Show)++-- | ANSI colors.+data Color+  = Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | BrightBlack+  | BrightRed+  | BrightGreen+  | BrightYellow+  | BrightBlue+  | BrightMagenta+  | BrightCyan+  | BrightWhite+  deriving (Eq, Ord, Show)

@@ -0,0 +1,185 @@+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+module System.Terminal.TerminalT+  ( TerminalT ()+  , runTerminalT+  )+where++import           Control.Monad.Catch+import           Control.Monad.IO.Class+import           Control.Monad.STM+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Data.Foldable                      (forM_)+import qualified Data.Text                       as Text+import           Prelude                     hiding (putChar)++import           System.Terminal.MonadInput+import           System.Terminal.MonadPrinter+import           System.Terminal.MonadScreen+import           System.Terminal.MonadTerminal+import qualified System.Terminal.Terminal        as T++-- | This monad transformer represents terminal applications.+--+-- It implements all classes in this module and should serve as a good+-- foundation for most use cases.+--+-- Note that it is not necessary nor recommended to have this type in+-- every signature. Keep your application abstract and mention `TerminalT`+-- only once at the top level.+--+-- Example:+--+-- @+-- main :: IO ()+-- main = `withTerminal` (`runTerminalT` myApplication)+--+-- myApplication :: (`MonadPrinter` m) => m ()+-- myApplication = do+--     `putTextLn` "Hello world!"+--     `flush`+-- @+newtype TerminalT t m a+    = TerminalT (ReaderT t m a)+    deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)++-- | Run a `TerminalT` application on the given terminal.+runTerminalT :: (MonadIO m, MonadMask m, T.Terminal t) => TerminalT t m a -> t -> m a+runTerminalT tma t = runReaderT ma t+    where+        TerminalT ma = tma++instance MonadTrans (TerminalT t) where+    lift = TerminalT . lift++instance (MonadIO m, T.Terminal t) => MonadInput (TerminalT t m) where+    awaitWith f = TerminalT do+        t <- ask+        liftIO $ atomically $ f (T.termInterrupt t) (T.termEvent t)++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadPrinter (TerminalT t m) where+    putLn =+        command T.PutLn+    putChar c =+        command (T.PutText $ Text.singleton c)+    putString cs =+        forM_ cs (command . T.PutText . Text.singleton)+    putText t = +        command (T.PutText t)+    flush = TerminalT do+        t <- ask+        liftIO $ T.termFlush t+    getLineWidth = TerminalT do+        t <- ask+        liftIO (width <$> T.termGetWindowSize t)++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadMarkupPrinter (TerminalT t m) where+    data Attribute (TerminalT t m) = AttributeT T.Attribute deriving (Eq, Ord, Show)+    setAttribute   (AttributeT a)  = command (T.SetAttribute   a)+    resetAttribute (AttributeT a)  = command (T.ResetAttribute a)+    resetAttributes                = command T.ResetAttributes+    resetsAttribute (AttributeT T.Bold       {}) (AttributeT T.Bold       {}) = True+    resetsAttribute (AttributeT T.Italic     {}) (AttributeT T.Italic     {}) = True+    resetsAttribute (AttributeT T.Underlined {}) (AttributeT T.Underlined {}) = True+    resetsAttribute (AttributeT T.Inverted   {}) (AttributeT T.Inverted   {}) = True+    resetsAttribute (AttributeT T.Foreground {}) (AttributeT T.Foreground {}) = True+    resetsAttribute (AttributeT T.Foreground {}) (AttributeT T.Background {}) = True+    resetsAttribute _                            _                            = False ++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadFormattingPrinter (TerminalT t m) where+    bold       = AttributeT T.Bold+    italic     = AttributeT T.Italic+    underlined = AttributeT T.Underlined+    inverted   = AttributeT T.Inverted++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadColorPrinter (TerminalT t m) where+    data Color (TerminalT t m) = ColorT T.Color deriving (Eq, Ord, Show)+    black                      = ColorT T.Black+    red                        = ColorT T.Red+    green                      = ColorT T.Green+    yellow                     = ColorT T.Yellow+    blue                       = ColorT T.Blue+    magenta                    = ColorT T.Magenta+    cyan                       = ColorT T.Cyan+    white                      = ColorT T.White+    bright (ColorT T.Black  )  = ColorT T.BrightBlack+    bright (ColorT T.Red    )  = ColorT T.BrightRed+    bright (ColorT T.Green  )  = ColorT T.BrightGreen+    bright (ColorT T.Yellow )  = ColorT T.BrightYellow+    bright (ColorT T.Blue   )  = ColorT T.BrightBlue+    bright (ColorT T.Magenta)  = ColorT T.BrightMagenta+    bright (ColorT T.Cyan   )  = ColorT T.BrightCyan+    bright (ColorT T.White  )  = ColorT T.BrightWhite+    bright (ColorT c        )  = ColorT c+    foreground (ColorT c)      = AttributeT (T.Foreground c)+    background (ColorT c)      = AttributeT (T.Background c)++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadScreen (TerminalT t m) where+    getWindowSize =+        TerminalT (liftIO . T.termGetWindowSize =<< ask)++    moveCursorUp i+        | i > 0     = command (T.MoveCursorUp i)+        | i < 0     = moveCursorDown i+        | otherwise = pure ()+    moveCursorDown i+        | i > 0     = command (T.MoveCursorDown i)+        | i < 0     = moveCursorUp i+        | otherwise = pure ()+    moveCursorForward i+        | i > 0     = command (T.MoveCursorForward i)+        | i < 0     = moveCursorBackward i+        | otherwise = pure ()+    moveCursorBackward i+        | i > 0     = command (T.MoveCursorBackward i)+        | i < 0     = moveCursorForward i+        | otherwise = pure ()++    getCursorPosition =+        TerminalT (liftIO . T.termGetCursorPosition =<< ask)+    setCursorPosition pos =+        command (T.SetCursorPosition pos)+    setCursorRow i =+        command (T.SetCursorRow i)+    setCursorColumn i =+        command (T.SetCursorColumn i)++    saveCursor =+        command T.SaveCursor+    restoreCursor =+        command T.RestoreCursor++    insertChars i = do+        command (T.InsertChars i)+    deleteChars i = do+        command (T.DeleteChars i)+    eraseChars  i = do+        command (T.EraseChars  i)+    insertLines i = do+        command (T.InsertLines i)+    deleteLines i = do+        command (T.DeleteLines i)++    eraseInLine =+        command . T.EraseInLine+    eraseInDisplay =+        command . T.EraseInDisplay++    showCursor =+        command T.ShowCursor+    hideCursor =+        command T.HideCursor++    setAutoWrap x =+        command (T.SetAutoWrap x)+    setAlternateScreenBuffer x =+        command (T.SetAlternateScreenBuffer x)++instance (MonadIO m, MonadThrow m, T.Terminal t) => MonadTerminal (TerminalT t m) where++command :: (MonadIO m, MonadThrow m, T.Terminal t) => T.Command -> TerminalT t m ()+command c = TerminalT do+  t <- ask+  liftIO $ T.termCommand t c

@@ -0,0 +1,240 @@+module System.Terminal.Virtual where++import           Control.Monad.STM+import           Control.Concurrent.STM.TVar+import           Control.Monad.IO.Class+import qualified Data.ByteString   as BS+import qualified Data.Text         as T++import           System.Terminal.MonadInput+import           System.Terminal.MonadScreen (Size (..), Position (..), EraseMode (..))+import           System.Terminal.Terminal++data VirtualTerminal+    = VirtualTerminal+    { virtualSettings              :: VirtualTerminalSettings+    , virtualCursor                :: TVar Position+    , virtualWindow                :: TVar [String]+    , virtualAutoWrap              :: TVar Bool+    , virtualAlternateScreenBuffer :: TVar Bool+    }++data VirtualTerminalSettings+    = VirtualTerminalSettings+    { virtualType              :: BS.ByteString+    , virtualWindowSize        :: STM Size+    , virtualEvent             :: STM Event+    , virtualInterrupt         :: STM Interrupt+    }++instance Terminal VirtualTerminal where+    termType              = virtualType      . virtualSettings+    termEvent             = virtualEvent     . virtualSettings+    termInterrupt         = virtualInterrupt . virtualSettings+    termCommand t c       = atomically (command t c)+    termFlush _           = pure ()+    termGetWindowSize     = atomically . virtualWindowSize . virtualSettings+    termGetCursorPosition = readTVarIO . virtualCursor++withVirtualTerminal :: (MonadIO m) => VirtualTerminalSettings -> (VirtualTerminal -> m a) -> m a+withVirtualTerminal settings handler = do+    size <- liftIO $ atomically $ virtualWindowSize settings+    term <- liftIO $ atomically $ VirtualTerminal settings+        <$> newTVar (Position 0 0)+        <*> newTVar (replicate (height size) (replicate (width size) ' '))+        <*> newTVar True+        <*> newTVar False+    handler term++command :: VirtualTerminal -> Command -> STM ()+command t = \case+    PutLn                         -> putLn t+    PutText s                     -> putString t (T.unpack s)+    SetAttribute _                -> pure ()+    ResetAttribute _              -> pure ()+    ResetAttributes               -> pure ()+    MoveCursorUp i                -> moveCursorVertical   t (negate i)+    MoveCursorDown i              -> moveCursorVertical   t i+    MoveCursorForward i           -> moveCursorHorizontal t i+    MoveCursorBackward i          -> moveCursorHorizontal t (negate i)+    ShowCursor                    -> pure ()+    HideCursor                    -> pure ()+    SaveCursor                    -> pure ()+    RestoreCursor                 -> pure ()+    GetCursorPosition             -> getCursorPosition t+    SetCursorPosition pos         -> setCursorPosition t pos+    SetCursorRow r                -> setCursorRow t r+    SetCursorColumn c             -> setCursorColumn t c+    InsertChars i                 -> insertChars       t i+    DeleteChars i                 -> deleteChars       t i+    EraseChars  i                 -> eraseChars        t i+    InsertLines i                 -> insertLines       t i+    DeleteLines i                 -> deleteLines       t i+    EraseInLine m                 -> eraseInLine       t m+    EraseInDisplay m              -> eraseInDisplay    t m+    SetAutoWrap b                 -> setAutoWrap       t b+    SetAlternateScreenBuffer b    -> setAlternateScreenBuffer t b++scrollDown :: Int -> [String] -> [String]+scrollDown w window =+    drop 1 window ++ [replicate w ' ']++putLn :: VirtualTerminal -> STM ()+putLn t = do+    Size h w <- virtualWindowSize (virtualSettings t)+    Position r _ <- readTVar (virtualCursor t)+    window <- readTVar (virtualWindow t)+    if r + 1 == h+        then do+            writeTVar (virtualCursor t) $ Position r 0+            writeTVar (virtualWindow t) (scrollDown w window)+        else do+            writeTVar (virtualCursor t) $ Position (r + 1) 0++putString :: VirtualTerminal -> String -> STM ()+putString t s = do+    Size h w <- virtualWindowSize (virtualSettings t)+    autoWrap <- readTVar (virtualAutoWrap t)+    Position r c <- readTVar (virtualCursor t)+    wndw <- readTVar (virtualWindow t)+    let cl = w - c -- space in cursor line+        f "" ls     = ls+        f x  []     = let k = (take w x) in (k <> replicate (w - length k) ' ') : f (drop w x) []+        f x  (l:ls) = let k = (take w x) in (k <> drop (length k) l)            : f (drop w x) ls+        w1 = take r wndw+        w2 = [take c l <> k <> drop (c + length k) l]+            where+                k = take cl s+                l = wndw !! r+        w3  | autoWrap  = f (drop cl s) $ drop (r + 1) wndw+            | otherwise =                 drop (r + 1) wndw+        w4 = w1 <> w2 <> w3+    writeTVar (virtualWindow t) (reverse $ take h $ reverse w4)+    if autoWrap+        then do+            let (r',c') = quotRem (r * w + c + length s) w+            writeTVar (virtualCursor t) $ Position (min r' (h - 1)) c'+        else do+            let (r', c') = (r, min (w - 1) (c + length s))+            writeTVar (virtualCursor t) $ Position r' c'++moveCursorHorizontal :: VirtualTerminal -> Int -> STM ()+moveCursorHorizontal t i = do+    Size _ w <- virtualWindowSize (virtualSettings t)+    Position r c <- readTVar (virtualCursor t)+    writeTVar (virtualCursor t) $ Position r (max 0 $ min (w - 1) $ c + i)++moveCursorVertical :: VirtualTerminal -> Int -> STM ()+moveCursorVertical t i = do+    Size h _ <- virtualWindowSize (virtualSettings t)+    Position r c <- readTVar (virtualCursor t)+    writeTVar (virtualCursor t) $ Position (max 0 $ min (h - 1) $ r + i) c++getCursorPosition :: VirtualTerminal -> STM ()+getCursorPosition _ = pure ()++setCursorPosition :: VirtualTerminal -> Position -> STM ()+setCursorPosition t (Position r c) = do+    Size h w <- virtualWindowSize (virtualSettings t)+    writeTVar (virtualCursor t) $ Position (max 0 (min (h - 1) r)) (max 0 (min (w - 1) c))++setCursorRow :: VirtualTerminal -> Int -> STM ()+setCursorRow t r = do+    Size h _ <- virtualWindowSize (virtualSettings t)+    Position _ c <- readTVar (virtualCursor t)+    writeTVar (virtualCursor t) $ Position (max 0 (min (h - 1) r)) c++setCursorColumn :: VirtualTerminal -> Int -> STM ()+setCursorColumn t c = do+    Size _ w <- virtualWindowSize (virtualSettings t)+    Position r _ <- readTVar (virtualCursor t)+    writeTVar (virtualCursor t) $ Position r (max 0 (min (w - 1) c))++insertChars :: VirtualTerminal -> Int -> STM ()+insertChars t i = do+    Size _ w <- virtualWindowSize (virtualSettings t)+    Position r c <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let l  = wndw !! r+        w1 = take r wndw+        w2 = [take w $ take c l <> replicate i ' ' <> drop c l]+        w3 = drop (r + 1) wndw+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++deleteChars :: VirtualTerminal -> Int -> STM ()+deleteChars t i = do+    Position r c <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let l  = wndw !! r+        w1 = take r wndw+        w2 = [take c l <> drop (c + i) l <> replicate i ' ']+        w3 = drop (r + 1) wndw+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++eraseChars :: VirtualTerminal -> Int -> STM ()+eraseChars t i = do+    Position r c <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let l  = wndw !! r+        w1 = take r wndw+        w2 = [take c l <> replicate i ' ' <> drop (c + i) l]+        w3 = drop (r + 1) wndw+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++insertLines :: VirtualTerminal -> Int -> STM ()+insertLines t i = do+    Size h w <- virtualWindowSize (virtualSettings t)+    Position r _ <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let w1 = take r wndw+        w2 = replicate i (replicate w ' ')+        w3 = take (h - r - i) $ drop r wndw+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++deleteLines :: VirtualTerminal -> Int -> STM ()+deleteLines t i = do+    Size h w <- virtualWindowSize (virtualSettings t)+    Position r _ <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let w1 = take r wndw+        w2 = take (h - r - i) $ drop r wndw+        w3 = replicate i (replicate w ' ')+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++eraseInLine :: VirtualTerminal -> EraseMode -> STM ()+eraseInLine t m = do+    Size _ w <- virtualWindowSize (virtualSettings t)+    Position r c <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let l  = wndw !! r+        w1 = take r wndw+        w2 = case m of+                EraseBackward -> [replicate (c + 1) ' ' <> drop (c + 1) l]+                EraseForward  -> [take c l <> replicate (w - c) ' ']+                EraseAll      -> [replicate w ' ']+        w3 = drop (r + 1) wndw+    writeTVar (virtualWindow t) (w1 <> w2 <> w3)++eraseInDisplay :: VirtualTerminal -> EraseMode -> STM ()+eraseInDisplay t m = do+    Size h w <- virtualWindowSize (virtualSettings t)+    Position r _ <- readTVar (virtualCursor t)+    wndw  <- readTVar (virtualWindow t)+    let w1  = take r wndw+        w1E = replicate r (replicate w ' ') +        w2  = [wndw !! r]+        w2E = [replicate w ' ']+        w3  = drop (r + 1) wndw+        w3E = replicate (h - r - 1) (replicate w ' ')+    writeTVar (virtualWindow t) $ case m of+        EraseBackward -> w1E <> w2  <> w3+        EraseForward  -> w1  <> w2  <> w3E+        EraseAll      -> w1E <> w2E <> w3E++setAutoWrap :: VirtualTerminal -> Bool -> STM ()+setAutoWrap t b = do+    writeTVar (virtualAutoWrap t) b++setAlternateScreenBuffer :: VirtualTerminal -> Bool -> STM ()+setAlternateScreenBuffer t b = do+    writeTVar (virtualAlternateScreenBuffer t) b

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d91d510e786ae40879fb10b28886159723665030111771a9d1c4da45720ffb86+-- hash: 7730a811f80e3894006e167e612c4bcbb50b5fb0a6dd2bd8a56f92c0ebf941a5  name:           terminal-version:        0.1.0.0+version:        0.2.0.0 synopsis:       Portable terminal interaction library description:    Please see the README on Github at <https://github.com/lpeterse/haskell-terminal#readme> category:       Terminal@@ -35,30 +35,36 @@  library   exposed-modules:-      Control.Monad.Terminal       System.Terminal+      System.Terminal.Internal   other-modules:-      Control.Monad.Terminal.Decoder-      Control.Monad.Terminal.Input-      Control.Monad.Terminal.Monad-      Control.Monad.Terminal.Printer-      Control.Monad.Terminal.Terminal-      Control.Monad.Terminal.TerminalT+      System.Terminal.Decoder+      System.Terminal.Encoder+      System.Terminal.MonadInput+      System.Terminal.MonadPrinter+      System.Terminal.MonadScreen+      System.Terminal.MonadTerminal+      System.Terminal.Pretty+      System.Terminal.Terminal+      System.Terminal.TerminalT       System.Terminal.Platform+      System.Terminal.Virtual   hs-source-dirs:       src+  default-extensions: LambdaCase MultiWayIf BlockArguments OverloadedStrings GeneralizedNewtypeDeriving TupleSections   ghc-options: -Wall -fwarn-incomplete-patterns   build-depends:       async     , base >=4.7 && <5     , bytestring-    , exceptions+    , exceptions >=0.10.0     , prettyprinter     , stm     , text     , transformers   if os(windows)     hs-source-dirs:+        src         platform/windows/src     include-dirs:         platform/windows/include@@ -66,6 +72,7 @@         platform/windows/cbits/hs_terminal.c   else     hs-source-dirs:+        src         platform/posix/src     include-dirs:         platform/posix/include@@ -77,15 +84,18 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Spec.Decoder+      Spec.Virtual       Paths_terminal   hs-source-dirs:       test+  default-extensions: LambdaCase MultiWayIf BlockArguments OverloadedStrings GeneralizedNewtypeDeriving TupleSections   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       async     , base >=4.7 && <5     , bytestring-    , exceptions+    , exceptions >=0.10.0     , prettyprinter     , stm     , tasty

@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-} module Main where  import           Data.Monoid@@ -7,133 +5,11 @@ import           Test.Tasty import           Test.Tasty.HUnit -import           Control.Monad.Terminal+import qualified Spec.Decoder+import qualified Spec.Virtual  main :: IO () main = defaultMain $ testGroup "Control.Monad.Terminal"-  [ testDecoder-  ]--testDecoder :: TestTree-testDecoder = testGroup "ansiDecoder"-  [ testDecoderGeneric-  , testDecoderWindowsConsole-  , testDecoderXterm-  , testDecoderGnomeTerminal-  , testDecoderRxvtUnicode-  ]--testDecoderGeneric :: TestTree-testDecoderGeneric = testGroup "Generic Ansi"-  [ testCase "NUL is skipped" $ f mempty "\NUL" [[]]-  , testCase "SOH is ctrl+A" $ f mempty "\SOH" [[KeyEvent (CharKey 'A') ctrlKey]]-  , testCase "STX is ctrl+B" $ f mempty "\STX" [[KeyEvent (CharKey 'B') ctrlKey]]-  , testCase "ETX is ctrl+C" $ f mempty "\ETX" [[KeyEvent (CharKey 'C') ctrlKey]]-  , testCase "EOT is ctrl+D" $ f mempty "\EOT" [[KeyEvent (CharKey 'D') ctrlKey]]-  , testCase "ENQ is ctrl+E" $ f mempty "\ENQ" [[KeyEvent (CharKey 'E') ctrlKey]]-  , testCase "ACK is ctrl+F" $ f mempty "\ACK" [[KeyEvent (CharKey 'F') ctrlKey]]-  , testCase "\\a is ctrl+G" $ f mempty "\a"   [[KeyEvent (CharKey 'G') ctrlKey]]-  , testCase "\\b is ctrl+H" $ f mempty "\b"   [[KeyEvent (CharKey 'H') ctrlKey]]-  , testCase "\\t is ctrl+I" $ f mempty "\t"   [[KeyEvent (CharKey 'I') ctrlKey]]-  , testCase "\\n is ctrl+J" $ f mempty "\n"   [[KeyEvent (CharKey 'J') ctrlKey]]-  , testCase "\\v is ctrl+K" $ f mempty "\v"   [[KeyEvent (CharKey 'K') ctrlKey]]-  , testCase "\\f is ctrl+L" $ f mempty "\f"   [[KeyEvent (CharKey 'L') ctrlKey]]-  , testCase "\\r is ctrl+M" $ f mempty "\r"   [[KeyEvent (CharKey 'M') ctrlKey]]-  , testCase "SO  is ctrl+N" $ f mempty "\SO"  [[KeyEvent (CharKey 'N') ctrlKey]]-  , testCase "SI  is ctrl+O" $ f mempty "\SI"  [[KeyEvent (CharKey 'O') ctrlKey]]-  , testCase "DLE is ctrl+P" $ f mempty "\DLE" [[KeyEvent (CharKey 'P') ctrlKey]]-  , testCase "DC1 is ctrl+Q" $ f mempty "\DC1" [[KeyEvent (CharKey 'Q') ctrlKey]]-  , testCase "DC2 is ctrl+R" $ f mempty "\DC2" [[KeyEvent (CharKey 'R') ctrlKey]]-  , testCase "DC3 is ctrl+S" $ f mempty "\DC3" [[KeyEvent (CharKey 'S') ctrlKey]]-  , testCase "DC4 is ctrl+T" $ f mempty "\DC4" [[KeyEvent (CharKey 'T') ctrlKey]]-  , testCase "NAK is ctrl+U" $ f mempty "\NAK" [[KeyEvent (CharKey 'U') ctrlKey]]-  , testCase "SYN is ctrl+V" $ f mempty "\SYN" [[KeyEvent (CharKey 'V') ctrlKey]]-  , testCase "ETB is ctrl+W" $ f mempty "\ETB" [[KeyEvent (CharKey 'W') ctrlKey]]-  , testCase "CAN is ctrl+X" $ f mempty "\CAN" [[KeyEvent (CharKey 'X') ctrlKey]]-  , testCase "EM  is ctrl+Y" $ f mempty "\EM"  [[KeyEvent (CharKey 'Y') ctrlKey]]-  , testCase "SUB is ctrl+Z" $ f mempty "\SUB" [[KeyEvent (CharKey 'Z') ctrlKey]]-  , testCase "ESC cannot be decided" $ f mempty "\ESC" [[]]-  , testCase "ESC+NUL is ctrl+[ and escape key" $ f mempty "\ESC\NUL" [[],[KeyEvent (CharKey '[') ctrlKey, KeyEvent EscapeKey mempty]]-  , testCase "FS  is ctrl+\\" $ f mempty "\FS"  [[KeyEvent (CharKey '\\') ctrlKey]]-  , testCase "GS  is ctrl+]" $ f mempty "\GS"  [[KeyEvent (CharKey ']') ctrlKey]]-  , testCase "RS  is ctrl+^" $ f mempty "\RS"  [[KeyEvent (CharKey '^') ctrlKey]]-  , testCase "US  is ctrl+_" $ f mempty "\US"  [[KeyEvent (CharKey '_') ctrlKey]]-  , testCase "SP  is space key" $ f mempty "\SP" [[KeyEvent SpaceKey mempty]]-  , testCase "'a' is character key 'a''" $ f mempty "a" [[KeyEvent (CharKey 'a') mempty]]-  ]-  where-    f = assertDecoding (const Nothing)---- | Only change these tests after having validated the behavior---   with the actual terminal emulator! This is the primary reason---   for having duplicate tests for different terminal emulators.-testDecoderWindowsConsole :: TestTree-testDecoderWindowsConsole = testGroup "Windows Console"-  [ testCase "tab key"                            $ f mempty "\t"          [[KeyEvent (CharKey 'I') ctrlKey, KeyEvent TabKey mempty]]-  , testCase "enter key"                          $ f mempty "\r"          [[KeyEvent (CharKey 'M') ctrlKey, KeyEvent EnterKey mempty]]-  , testCase "enter key (when pressed with ctrl)" $ f ctrlKey "\n"         [[KeyEvent (CharKey 'J') ctrlKey, KeyEvent EnterKey ctrlKey]]-  , testCase "delete key"                         $ f mempty "\ESC[3~"     [[],[],[],[KeyEvent DeleteKey mempty]]-  , testCase "space key"                          $ f mempty   "\SP"       [[KeyEvent SpaceKey mempty]]-  , testCase "space key, shift"                   $ f shiftKey "\SP"       [[KeyEvent SpaceKey shiftKey]]-  , testCase "backspace key"                      $ f mempty "\DEL"        [[KeyEvent (CharKey '?') ctrlKey, KeyEvent BackspaceKey mempty]]-  , testCase "backspace key, alt"                 $ f mempty "\ESC\b\NUL"  [[],[],[KeyEvent BackspaceKey altKey]]-  , testCase "function key 1"                     $ f mempty "\ESCOP"      [[],[],[KeyEvent (FunctionKey 1) mempty]]-  , testCase "function key 2"                     $ f mempty "\ESCOQ"      [[],[],[KeyEvent (FunctionKey 2) mempty]]-  , testCase "function key 3"                     $ f mempty "\ESCOR"      [[],[],[KeyEvent (FunctionKey 3) mempty]]-  , testCase "function key 4"                     $ f mempty "\ESCOS"      [[],[],[KeyEvent (FunctionKey 4) mempty]]-  , testCase "function key 5"                     $ f mempty "\ESC[15~"    [[],[],[],[],[KeyEvent (FunctionKey 5) mempty]]-  , testCase "function key 6"                     $ f mempty "\ESC[17~"    [[],[],[],[],[KeyEvent (FunctionKey 6) mempty]]-  , testCase "function key 7"                     $ f mempty "\ESC[18~"    [[],[],[],[],[KeyEvent (FunctionKey 7) mempty]]-  , testCase "function key 8"                     $ f mempty "\ESC[19~"    [[],[],[],[],[KeyEvent (FunctionKey 8) mempty]]-  , testCase "function key 9"                     $ f mempty "\ESC[20~"    [[],[],[],[],[KeyEvent (FunctionKey 9) mempty]]-  , testCase "function key 10"                    $ f mempty "\ESC[21~"    [[],[],[],[],[KeyEvent (FunctionKey 10) mempty]]-  , testCase "function key 11"                    $ f mempty "\ESC[23~"    [[],[],[],[],[KeyEvent (FunctionKey 11) mempty]]-  , testCase "function key 12"                    $ f mempty "\ESC[24~"    [[],[],[],[],[KeyEvent (FunctionKey 12) mempty]]-  , testCase "function key 12, shift"             $ f mempty "\ESC[24;2~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) shiftKey]]-  , testCase "function key 12, alt"               $ f mempty "\ESC[24;3~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) altKey]]-  , testCase "function key 12, shift+alt"         $ f mempty "\ESC[24;4~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> altKey)]]-  , testCase "function key 12, ctrl"              $ f mempty "\ESC[24;5~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) ctrlKey]]-  , testCase "function key 12, shift+ctrl"        $ f mempty "\ESC[24;6~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> ctrlKey)]]-  , testCase "function key 12, alt+ctrl"          $ f mempty "\ESC[24;7~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (altKey <> ctrlKey)]]-  , testCase "function key 12, shift+alt+ctrl"    $ f mempty "\ESC[24;8~"  [[],[],[],[],[],[],[KeyEvent (FunctionKey 12) (shiftKey <> altKey <> ctrlKey)]]+  [ Spec.Decoder.tests+  , Spec.Virtual.tests   ]-  where-    -- The special chars are assumed to be constant on Windows.-    f = assertDecoding $ \case-      '\t'   -> Just $ KeyEvent TabKey mempty-      '\r'   -> Just $ KeyEvent EnterKey mempty-      '\n'   -> Just $ KeyEvent EnterKey mempty -- when pressed with ctrl-      '\b'   -> Just $ KeyEvent BackspaceKey mempty -- when pressed with alt-      '\DEL' -> Just $ KeyEvent BackspaceKey mempty-      _      -> Nothing---- | Only change these tests after having validated the behavior---   with the actual terminal emulator! This is the primary reason---   for having duplicate tests for different terminal emulators.-testDecoderXterm :: TestTree-testDecoderXterm = testGroup "Xterm"-  []---- | Only change these tests after having validated the behavior---   with the actual terminal emulator! This is the primary reason---   for having duplicate tests for different terminal emulators.-testDecoderGnomeTerminal :: TestTree-testDecoderGnomeTerminal = testGroup "Gnome Terminal"-  []---- | Only change these tests after having validated the behavior---   with the actual terminal emulator! This is the primary reason---   for having duplicate tests for different terminal emulators.-testDecoderRxvtUnicode :: TestTree-testDecoderRxvtUnicode = testGroup "Rxvt Unicode"-  []--assertDecoding :: (Char -> Maybe Event) -> Modifiers -> String -> [[Event]] -> Assertion-assertDecoding specialChars mods input expected-  = expected @=? decode (ansiDecoder specialChars) input-  where-    decode :: Decoder -> String -> [[Event]]-    decode decoder = \case-      [] -> []-      (x:xs) ->  let (events, decoder') = feedDecoder decoder mods x-                 in events : decode decoder' xs

@@ -0,0 +1,133 @@+module Spec.Decoder where++import Test.Tasty+import Test.Tasty.HUnit++import System.Terminal+import System.Terminal.Internal++tests :: TestTree+tests = testGroup "System.Terminal.Decoder"+  [ testDecoderGeneric+  , testDecoderWindowsConsole+  , testDecoderXterm+  , testDecoderGnomeTerminal+  , testDecoderRxvtUnicode+  ]++testDecoderGeneric :: TestTree+testDecoderGeneric = testGroup "Generic Ansi"+  [ testCase "NUL is skipped" $ f mempty "\NUL" []+  , testCase "SOH is ctrl+A" $ f mempty "\SOH" [KeyEvent (CharKey 'A') ctrlKey]+  , testCase "STX is ctrl+B" $ f mempty "\STX" [KeyEvent (CharKey 'B') ctrlKey]+  , testCase "ETX is ctrl+C" $ f mempty "\ETX" [KeyEvent (CharKey 'C') ctrlKey]+  , testCase "EOT is ctrl+D" $ f mempty "\EOT" [KeyEvent (CharKey 'D') ctrlKey]+  , testCase "ENQ is ctrl+E" $ f mempty "\ENQ" [KeyEvent (CharKey 'E') ctrlKey]+  , testCase "ACK is ctrl+F" $ f mempty "\ACK" [KeyEvent (CharKey 'F') ctrlKey]+  , testCase "\\a is ctrl+G" $ f mempty "\a"   [KeyEvent (CharKey 'G') ctrlKey]+  , testCase "\\b is ctrl+H" $ f mempty "\b"   [KeyEvent (CharKey 'H') ctrlKey]+  , testCase "\\t is ctrl+I" $ f mempty "\t"   [KeyEvent (CharKey 'I') ctrlKey]+  , testCase "\\n is ctrl+J" $ f mempty "\n"   [KeyEvent (CharKey 'J') ctrlKey]+  , testCase "\\v is ctrl+K" $ f mempty "\v"   [KeyEvent (CharKey 'K') ctrlKey]+  , testCase "\\f is ctrl+L" $ f mempty "\f"   [KeyEvent (CharKey 'L') ctrlKey]+  , testCase "\\r is ctrl+M" $ f mempty "\r"   [KeyEvent (CharKey 'M') ctrlKey]+  , testCase "SO  is ctrl+N" $ f mempty "\SO"  [KeyEvent (CharKey 'N') ctrlKey]+  , testCase "SI  is ctrl+O" $ f mempty "\SI"  [KeyEvent (CharKey 'O') ctrlKey]+  , testCase "DLE is ctrl+P" $ f mempty "\DLE" [KeyEvent (CharKey 'P') ctrlKey]+  , testCase "DC1 is ctrl+Q" $ f mempty "\DC1" [KeyEvent (CharKey 'Q') ctrlKey]+  , testCase "DC2 is ctrl+R" $ f mempty "\DC2" [KeyEvent (CharKey 'R') ctrlKey]+  , testCase "DC3 is ctrl+S" $ f mempty "\DC3" [KeyEvent (CharKey 'S') ctrlKey]+  , testCase "DC4 is ctrl+T" $ f mempty "\DC4" [KeyEvent (CharKey 'T') ctrlKey]+  , testCase "NAK is ctrl+U" $ f mempty "\NAK" [KeyEvent (CharKey 'U') ctrlKey]+  , testCase "SYN is ctrl+V" $ f mempty "\SYN" [KeyEvent (CharKey 'V') ctrlKey]+  , testCase "ETB is ctrl+W" $ f mempty "\ETB" [KeyEvent (CharKey 'W') ctrlKey]+  , testCase "CAN is ctrl+X" $ f mempty "\CAN" [KeyEvent (CharKey 'X') ctrlKey]+  , testCase "EM  is ctrl+Y" $ f mempty "\EM"  [KeyEvent (CharKey 'Y') ctrlKey]+  , testCase "SUB is ctrl+Z" $ f mempty "\SUB" [KeyEvent (CharKey 'Z') ctrlKey]+  , testCase "ESC cannot be decided" $ f mempty "\ESC" []+  , testCase "ESC+NUL is ctrl+[ and escape key" $ f mempty "\ESC\NUL" [KeyEvent (CharKey '[') ctrlKey, KeyEvent EscapeKey mempty]+  , testCase "FS  is ctrl+\\" $ f mempty "\FS"  [KeyEvent (CharKey '\\') ctrlKey]+  , testCase "GS  is ctrl+]" $ f mempty "\GS"  [KeyEvent (CharKey ']') ctrlKey]+  , testCase "RS  is ctrl+^" $ f mempty "\RS"  [KeyEvent (CharKey '^') ctrlKey]+  , testCase "US  is ctrl+_" $ f mempty "\US"  [KeyEvent (CharKey '_') ctrlKey]+  , testCase "'a' is character key 'a''" $ f mempty "a" [KeyEvent (CharKey 'a') mempty]+  ]+  where+    f = assertDecoding (\_ _ -> Nothing)++-- | Only change these tests after having validated the behavior+--   with the actual terminal emulator! This is the primary reason+--   for having duplicate tests for different terminal emulators.+testDecoderWindowsConsole :: TestTree+testDecoderWindowsConsole = testGroup "Windows Console"+  [ testCase "tab key"                            $ f mempty "\t"          [KeyEvent (CharKey 'I') ctrlKey, KeyEvent TabKey mempty]+  , testCase "enter key"                          $ f mempty "\r"          [KeyEvent (CharKey 'M') ctrlKey, KeyEvent EnterKey mempty]+  , testCase "enter key (when pressed with ctrl)" $ f ctrlKey "\n"         [KeyEvent (CharKey 'J') ctrlKey, KeyEvent EnterKey ctrlKey]+  , testCase "delete key"                         $ f mempty "\ESC[3~"     [KeyEvent DeleteKey mempty]+  , testCase "space key"                          $ f mempty   "\SP"       [KeyEvent (CharKey ' ') mempty, KeyEvent SpaceKey mempty]+  , testCase "space key, shift"                   $ f shiftKey "\SP"       [KeyEvent (CharKey ' ') shiftKey, KeyEvent SpaceKey shiftKey]+  , testCase "backspace key"                      $ f mempty "\DEL"        [KeyEvent BackspaceKey mempty]+  , testCase "backspace key, alt"                 $ f mempty "\ESC\b\NUL"  [KeyEvent BackspaceKey altKey]+  , testCase "function key 1"                     $ f mempty "\ESCOP"      [KeyEvent (FunctionKey 1) mempty]+  , testCase "function key 2"                     $ f mempty "\ESCOQ"      [KeyEvent (FunctionKey 2) mempty]+  , testCase "function key 3"                     $ f mempty "\ESCOR"      [KeyEvent (FunctionKey 3) mempty]+  , testCase "function key 4"                     $ f mempty "\ESCOS"      [KeyEvent (FunctionKey 4) mempty]+  , testCase "function key 5"                     $ f mempty "\ESC[15~"    [KeyEvent (FunctionKey 5) mempty]+  , testCase "function key 6"                     $ f mempty "\ESC[17~"    [KeyEvent (FunctionKey 6) mempty]+  , testCase "function key 7"                     $ f mempty "\ESC[18~"    [KeyEvent (FunctionKey 7) mempty]+  , testCase "function key 8"                     $ f mempty "\ESC[19~"    [KeyEvent (FunctionKey 8) mempty]+  , testCase "function key 9"                     $ f mempty "\ESC[20~"    [KeyEvent (FunctionKey 9) mempty]+  , testCase "function key 10"                    $ f mempty "\ESC[21~"    [KeyEvent (FunctionKey 10) mempty]+  , testCase "function key 11"                    $ f mempty "\ESC[23~"    [KeyEvent (FunctionKey 11) mempty]+  , testCase "function key 12"                    $ f mempty "\ESC[24~"    [KeyEvent (FunctionKey 12) mempty]+  , testCase "function key 12, shift"             $ f mempty "\ESC[24;2~"  [KeyEvent (FunctionKey 12) shiftKey]+  , testCase "function key 12, alt"               $ f mempty "\ESC[24;3~"  [KeyEvent (FunctionKey 12) altKey]+  , testCase "function key 12, shift+alt"         $ f mempty "\ESC[24;4~"  [KeyEvent (FunctionKey 12) (shiftKey <> altKey)]+  , testCase "function key 12, ctrl"              $ f mempty "\ESC[24;5~"  [KeyEvent (FunctionKey 12) ctrlKey]+  , testCase "function key 12, shift+ctrl"        $ f mempty "\ESC[24;6~"  [KeyEvent (FunctionKey 12) (shiftKey <> ctrlKey)]+  , testCase "function key 12, alt+ctrl"          $ f mempty "\ESC[24;7~"  [KeyEvent (FunctionKey 12) (altKey <> ctrlKey)]+  , testCase "function key 12, shift+alt+ctrl"    $ f mempty "\ESC[24;8~"  [KeyEvent (FunctionKey 12) (shiftKey <> altKey <> ctrlKey)]+  ]+  where+    -- The special chars are assumed to be constant on Windows.+    f = assertDecoding sk+    sk mods = \case+        '\r'   -> Just $ KeyEvent EnterKey     mods+        '\n'   -> Just $ KeyEvent EnterKey     mods+        '\t'   -> Just $ KeyEvent TabKey       mods+        '\b'   -> Just $ KeyEvent BackspaceKey mods+        '\SP'  -> Just $ KeyEvent SpaceKey     mods+        '\DEL' -> Just $ KeyEvent BackspaceKey mods+        _      -> Nothing++-- | Only change these tests after having validated the behavior+--   with the actual terminal emulator! This is the primary reason+--   for having duplicate tests for different terminal emulators.+testDecoderXterm :: TestTree+testDecoderXterm = testGroup "Xterm"+  []++-- | Only change these tests after having validated the behavior+--   with the actual terminal emulator! This is the primary reason+--   for having duplicate tests for different terminal emulators.+testDecoderGnomeTerminal :: TestTree+testDecoderGnomeTerminal = testGroup "Gnome Terminal"+  []++-- | Only change these tests after having validated the behavior+--   with the actual terminal emulator! This is the primary reason+--   for having duplicate tests for different terminal emulators.+testDecoderRxvtUnicode :: TestTree+testDecoderRxvtUnicode = testGroup "Rxvt Unicode"+  []++assertDecoding :: (Modifiers -> Char -> Maybe Event) -> Modifiers -> String -> [Event] -> Assertion+assertDecoding specialChars mods input expected+  = expected @=? decode (defaultDecoder specialChars) input+  where+    decode :: Decoder -> String -> [Event]+    decode decoder = \case+        [] -> []+        (x:xs) ->  case feedDecoder decoder mods x of+            Left decoder' -> decode decoder' xs+            Right evs     -> evs

@@ -0,0 +1,695 @@+module Spec.Virtual (tests) where++import           Control.Monad+import           Control.Monad.STM+import           Control.Concurrent.STM.TVar+import           Data.Monoid++import           Test.Tasty+import           Test.Tasty.HUnit++import           System.Terminal+import           System.Terminal.Internal++tests :: TestTree+tests = testGroup "System.Terminal.Virtual"+    [ testGroup "withVirtualTerminal"+        [ testWithVirtualTerminal01+        ]+    , testGroup "PutLn"+        [ testPutLn01+        , testPutLn02+        , testPutLn03+        ]+    , testGroup "PutText"+        [ testPutText01+        , testPutText02+        , testPutText03+        , testPutText04+        ]+    , testGroup "MoveCursor*"+        [ testMoveCursor01+        , testMoveCursor02+        , testMoveCursor03+        , testMoveCursor04+        ]+    , testGroup "GetCursorPosition"+        [ testGetCursorPosition01+        ]+    , testGroup "SetCursorPosition"+        [ testSetCursorPosition01+        , testSetCursorPosition02+        , testSetCursorPosition03+        , testSetCursorPosition04+        , testSetCursorPosition05+        ]+    , testGroup "SetCursorRow"+        [ testSetCursorRow01+        ]+    , testGroup "SetCursorColumn" +        [ testSetCursorColumn+        ]+    , testGroup "InsertChars"+        [ testInsertChars01+        ]+    , testGroup "DeleteChars"+        [ testDeleteChars01+        ]+    , testGroup "EraseChars"+        [ testEraseChars01+        ]+    , testGroup "InsertLines"+        [ testInsertLines01+        ]+    , testGroup "DeleteLines"+        [ testDeleteLines01+        ]+    , testGroup "EraseInLine"+        [ testEraseInLine01+        , testEraseInLine02+        , testEraseInLine03+        ]+    , testGroup "EraseInDisplay"+        [ testEraseInDisplay01+        , testEraseInDisplay02+        , testEraseInDisplay03+        ]+    ]++defaultSettings :: VirtualTerminalSettings+defaultSettings = VirtualTerminalSettings+    { virtualType         = "xterm"+    , virtualWindowSize   = pure (Size 4 10)+    , virtualEvent        = retry+    , virtualInterrupt    = retry+    }++testWithVirtualTerminal01 :: TestTree+testWithVirtualTerminal01 =+    testCase "shall yield empty window and cursor on home position" do+        t <- withVirtualTerminal settings pure+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 0 0+        expWindow =+            [ "          "+            , "          "+            , "          " ]++testPutLn01 :: TestTree+testPutLn01 =+    testCase "shall set cursor to next line" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t PutLn+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 0+        expWindow =+            [ "          "+            , "          "+            , "          " ]++testPutLn02 :: TestTree+testPutLn02 =+    testCase "shall not exceed bottom margin" do+        t <- withVirtualTerminal settings $ \t -> do+            replicateM_ 6 (termCommand t PutLn)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 0+        expWindow =+            [ "          "+            , "          "+            , "          " ]++testPutLn03 :: TestTree+testPutLn03 =+    testCase "shall scroll when reaching bottom margin" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "ABC")+            termCommand t PutLn+            termCommand t (PutText "123")+            termCommand t PutLn+            termCommand t PutLn+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 0+        expWindow =+            [ "123       "+            , "          "+            , "          " ]++testPutText01 :: TestTree+testPutText01 =+    testCase "shall put text in first line" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "ABC")+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 0 3+        expWindow =+            [ "ABC       "+            , "          "+            , "          " ]++testPutText02 :: TestTree+testPutText02 =+    testCase "shall wrap text around (when autoWrap is on)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (SetAutoWrap True)+            termCommand t (PutText "ABC")+            termCommand t (PutText "123456789")+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 2+        expWindow =+            [ "ABC1234567"+            , "89        "+            , "          " ]++testPutText03 :: TestTree+testPutText03 =+    testCase "shall not wrap text around (when autoWrap is off)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (SetAutoWrap False)+            termCommand t (PutText "ABC")+            termCommand t (PutText "123456789")+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 0 9+        expWindow =+            [ "ABC1234567"+            , "          "+            , "          " ]++testPutText04 :: TestTree+testPutText04 =+    testCase "shall scroll when reaching bottom margin" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890ABCDEFGHIJabcdefghijX")+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 1+        expWindow =+            [ "ABCDEFGHIJ"+            , "abcdefghij"+            , "X         " ]++testMoveCursor01 :: TestTree+testMoveCursor01 =+    testCase "shall move up" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (MoveCursorUp 1)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 0 5+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testMoveCursor02 :: TestTree+testMoveCursor02 =+    testCase "shall move down" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (MoveCursorDown 1)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 5+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testMoveCursor03 :: TestTree+testMoveCursor03 =+    testCase "shall move forward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (MoveCursorForward 2)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 7+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testMoveCursor04 :: TestTree+testMoveCursor04 =+    testCase "shall move backward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (MoveCursorBackward 2)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 3+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testGetCursorPosition01 :: TestTree+testGetCursorPosition01 =+    testCase "shall return cursor position" do+        pos <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termGetCursorPosition t+        assertEqual "cursor" expCursor pos+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 5++testSetCursorPosition01 :: TestTree+testSetCursorPosition01 =+    testCase "shall set cursor position" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorPosition (Position 2 8))+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 8+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorPosition02 :: TestTree+testSetCursorPosition02 =+    testCase "shall set cursor position (limit top margin)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorPosition $ Position (-1) 8)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 0 8+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorPosition03 :: TestTree+testSetCursorPosition03 =+    testCase "shall set cursor position (limit bottom margin)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorPosition (Position 5 8))+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 8+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorPosition04 :: TestTree+testSetCursorPosition04 =+    testCase "shall set cursor position (limit left margin)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorPosition $ Position 1 (-1))+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 0+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorPosition05 :: TestTree+testSetCursorPosition05 =+    testCase "shall set cursor position (limit right margin)" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorPosition (Position 1 11))+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 9+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorRow01 :: TestTree+testSetCursorRow01 =+    testCase "shall set vertical cursor position" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorRow 2)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 2 5+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testSetCursorColumn :: TestTree+testSetCursorColumn =+    testCase "shall set horizontal cursor position" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "123456789012345")+            termCommand t (SetCursorColumn 8)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = Position 1 8+        expWindow =+            [ "1234567890"+            , "12345     "+            , "          " ]++testInsertChars01 :: TestTree+testInsertChars01 =+    testCase "shall insert space and shift out existing chars" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 0 4))+            termCommand t (InsertChars 3)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 0 4)+        expWindow =+            [ "1234   567"+            , "          "+            , "          " ]++testDeleteChars01 :: TestTree+testDeleteChars01 =+    testCase "shall shift chars from right and fill with whitespace" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 0 4))+            termCommand t (DeleteChars 3)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 0 4)+        expWindow =+            [ "1234890   "+            , "          "+            , "          " ]++testEraseChars01 :: TestTree+testEraseChars01 =+    testCase "shall override chars with spaces" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 0 4))+            termCommand t (EraseChars 3)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 0 4)+        expWindow =+            [ "1234   890"+            , "          "+            , "          " ]++testInsertLines01 :: TestTree+testInsertLines01 =+    testCase "shall shift lines cursor and below downwards" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "ABCDEFGHIJ")+            termCommand t (PutText "QRSTUVWXYZ")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (InsertLines 1)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure (Size 4 10)+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "          "+            , "ABCDEFGHIJ"+            , "QRSTUVWXYZ" ]++testDeleteLines01 :: TestTree+testDeleteLines01 =+    testCase "shall shift chars from right and fill with whitespace" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "ABCDEFGHIJ")+            termCommand t (PutText "QRSTUVWXYZ")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (InsertLines 1)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure (Size 4 10)+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "          "+            , "ABCDEFGHIJ"+            , "QRSTUVWXYZ" ]++testEraseInLine01 :: TestTree+testEraseInLine01 =+    testCase "shall erase left with EraseBackward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInLine EraseBackward)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "     67890"+            , "1234567890" ]++testEraseInLine02 :: TestTree+testEraseInLine02 =+    testCase "shall erase right with EraseForward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInLine EraseForward)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "1234      "+            , "1234567890" ]++testEraseInLine03 :: TestTree+testEraseInLine03 =+    testCase "shall erase whole line with EraseAll" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInLine EraseAll)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "          "+            , "1234567890" ]++testEraseInDisplay01 :: TestTree+testEraseInDisplay01 =+    testCase "shall erase left with EraseBackward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInDisplay EraseBackward)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "          "+            , "1234567890"+            , "1234567890" ]++testEraseInDisplay02 :: TestTree+testEraseInDisplay02 =+    testCase "shall erase right with EraseForward" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInDisplay EraseForward)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "1234567890"+            , "1234567890"+            , "          " ]++testEraseInDisplay03 :: TestTree+testEraseInDisplay03 =+    testCase "shall erase whole line with EraseAll" do+        t <- withVirtualTerminal settings $ \t -> do+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (PutText "1234567890")+            termCommand t (SetCursorPosition (Position 1 4))+            termCommand t (EraseInDisplay EraseAll)+            pure t+        assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)+        assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)+    where+        settings = defaultSettings+            { virtualWindowSize = pure $ Size 3 10+            }+        expCursor = (Position 1 4)+        expWindow =+            [ "          "+            , "          "+            , "          " ]