summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2019-08-19 13:00:05 +0200
committertomsmeding <tom.smeding@gmail.com>2019-08-19 13:17:48 +0200
commit4e5590d148a7f2b517dce18c231b9d4cb0b1d19f (patch)
treedd04cecda1525f826f06752102ea2a58754fdbf7 /src
Import of source files
Diffstat (limited to 'src')
-rw-r--r--src/Numeric/InfInt.hs60
-rw-r--r--src/System/IO/Terminal.hs31
-rw-r--r--src/System/IO/Terminal/Characters.hs140
-rw-r--r--src/System/IO/Terminal/IO.hs57
-rw-r--r--src/System/IO/Terminal/Input.hs129
-rw-r--r--src/System/IO/Terminal/Input/Key.hs27
-rw-r--r--src/System/IO/Terminal/Input/Posix.hs187
-rw-r--r--src/System/IO/Terminal/Input/SeqParser.hs49
-rw-r--r--src/System/IO/Terminal/Input/Windows.hs80
-rw-r--r--src/System/IO/Terminal/Render.hs312
-rw-r--r--src/Utils/Monad.hs26
-rw-r--r--src/Utils/Time.hs43
12 files changed, 1141 insertions, 0 deletions
diff --git a/src/Numeric/InfInt.hs b/src/Numeric/InfInt.hs
new file mode 100644
index 0000000..871e5eb
--- /dev/null
+++ b/src/Numeric/InfInt.hs
@@ -0,0 +1,60 @@
+{-|
+Module : Numeric.InfInt
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+-}
+module Numeric.InfInt where
+
+
+-- | The integers with ±∞ added. This is not a full ring ('∞ + -∞' is
+-- undefined, for instance), but it works well enough.
+data InfInt = MInfinity | Finite Int | Infinity
+ deriving (Show, Eq, Ord)
+
+instance Num InfInt where
+ Infinity + MInfinity = undefined
+ Infinity + _ = Infinity
+ MInfinity + Infinity = undefined
+ MInfinity + _ = MInfinity
+ Finite n + Finite m = Finite (n + m)
+ Finite _ + Infinity = Infinity
+ Finite _ + MInfinity = MInfinity
+
+ Finite n * Finite m = Finite (n * m)
+ Finite 0 * _ = undefined
+ Finite n * Infinity = if n < 0 then MInfinity else Infinity
+ Finite n * MInfinity = if n < 0 then Infinity else MInfinity
+ Infinity * Finite m = Finite m * Infinity
+ Infinity * Infinity = Infinity
+ Infinity * MInfinity = MInfinity
+ MInfinity * Finite m = Finite m * MInfinity
+ MInfinity * Infinity = MInfinity
+ MInfinity * MInfinity = Infinity
+
+ abs (Finite n) = Finite (abs n)
+ abs _ = Infinity
+
+ signum (Finite n) = Finite (signum n)
+ signum MInfinity = (-1)
+ signum Infinity = 1
+
+ fromInteger n = Finite (fromInteger n)
+
+ negate (Finite n) = Finite (-n)
+ negate Infinity = MInfinity
+ negate MInfinity = Infinity
+
+
+-- | If the number is finite, return the finite component.
+toFinite :: InfInt -> Maybe Int
+toFinite (Finite n) = Just n
+toFinite Infinity = Nothing
+toFinite MInfinity = Nothing
+
+-- | @isFinite = isJust . toFinite@
+isFinite :: InfInt -> Bool
+isFinite (Finite _) = True
+isFinite _ = False
diff --git a/src/System/IO/Terminal.hs b/src/System/IO/Terminal.hs
new file mode 100644
index 0000000..0846d9f
--- /dev/null
+++ b/src/System/IO/Terminal.hs
@@ -0,0 +1,31 @@
+{-|
+Module : System.IO.Terminal
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Top-level module for building an application using terminal I/O.
+
+The library is loosely modelled after the [termio](https://github.com/tomsmeding/termio)
+library for C. See the documentation of the re-exported modules for more
+information.
+-}
+module System.IO.Terminal
+ (module System.IO.Terminal.Input
+ ,module System.IO.Terminal.Render
+ ,TUI, withTUI)
+ where
+
+import Control.Monad.Trans
+import System.IO.Terminal.Input
+import System.IO.Terminal.Render
+
+
+-- | The monad for doing terminal I/O operations.
+type TUI = RenderT Input
+
+-- | Run a 'TUI' computation in the 'IO' monad.
+withTUI :: TUI a -> IO a
+withTUI = withInput . withRender
diff --git a/src/System/IO/Terminal/Characters.hs b/src/System/IO/Terminal/Characters.hs
new file mode 100644
index 0000000..85f8b5f
--- /dev/null
+++ b/src/System/IO/Terminal/Characters.hs
@@ -0,0 +1,140 @@
+{-|
+Module : System.IO.Terminal.Characters
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Access to a small database of box-drawing characters.
+-}
+module System.IO.Terminal.Characters
+ (boxChar, BoxChar, BoxWeight(..))
+ where
+
+import qualified Data.Map.Strict as Map
+
+
+-- | Description of a box-drawing character: (up, right, down, left)
+type BoxChar = (BoxWeight, BoxWeight, BoxWeight, BoxWeight)
+
+-- | Description of one arm of a box-drawing character.
+data BoxWeight = BoxNone | BoxSingle | BoxHeavy | BoxDouble
+ deriving (Eq, Ord, Show)
+
+-- | Look up a box drawing character in the unicode table. Note that not
+-- all combinations are valid; currently, the function throws an error if
+-- the character doesn't exist.
+boxChar :: BoxChar -> Char
+boxChar tup = mapping Map.! tup
+ where
+ mapping = Map.fromList
+ [((BoxNone, BoxNone, BoxNone, BoxSingle), '╴')
+ ,((BoxNone, BoxNone, BoxNone, BoxHeavy), '╸')
+ ,((BoxSingle, BoxNone, BoxNone, BoxNone), '╵')
+ ,((BoxHeavy, BoxNone, BoxNone, BoxNone), '╹')
+ ,((BoxNone, BoxSingle, BoxNone, BoxNone), '╶')
+ ,((BoxNone, BoxHeavy, BoxNone, BoxNone), '╺')
+ ,((BoxNone, BoxNone, BoxSingle, BoxNone), '╷')
+ ,((BoxNone, BoxNone, BoxHeavy, BoxNone), '╻')
+ ,((BoxNone, BoxSingle, BoxNone, BoxSingle), '─')
+ ,((BoxNone, BoxHeavy, BoxNone, BoxHeavy), '━')
+ ,((BoxNone, BoxHeavy, BoxNone, BoxSingle), '╼')
+ ,((BoxNone, BoxSingle, BoxNone, BoxHeavy), '╾')
+ ,((BoxSingle, BoxNone, BoxSingle, BoxNone), '│')
+ ,((BoxHeavy, BoxNone, BoxHeavy, BoxNone), '┃')
+ ,((BoxSingle, BoxNone, BoxHeavy, BoxNone), '╽')
+ ,((BoxHeavy, BoxNone, BoxSingle, BoxNone), '╿')
+ ,((BoxNone, BoxSingle, BoxSingle, BoxNone), '┌')
+ ,((BoxNone, BoxHeavy, BoxSingle, BoxNone), '┍')
+ ,((BoxNone, BoxSingle, BoxHeavy, BoxNone), '┎')
+ ,((BoxNone, BoxHeavy, BoxHeavy, BoxNone), '┏')
+ ,((BoxNone, BoxNone, BoxSingle, BoxSingle), '┐')
+ ,((BoxNone, BoxNone, BoxSingle, BoxHeavy), '┑')
+ ,((BoxNone, BoxNone, BoxHeavy, BoxSingle), '┒')
+ ,((BoxNone, BoxNone, BoxHeavy, BoxHeavy), '┓')
+ ,((BoxSingle, BoxSingle, BoxNone, BoxNone), '└')
+ ,((BoxSingle, BoxHeavy, BoxNone, BoxNone), '┕')
+ ,((BoxHeavy, BoxSingle, BoxNone, BoxNone), '┖')
+ ,((BoxHeavy, BoxHeavy, BoxNone, BoxNone), '┗')
+ ,((BoxSingle, BoxNone, BoxNone, BoxSingle), '┘')
+ ,((BoxSingle, BoxNone, BoxNone, BoxHeavy), '┙')
+ ,((BoxHeavy, BoxNone, BoxNone, BoxSingle), '┚')
+ ,((BoxHeavy, BoxNone, BoxNone, BoxHeavy), '┛')
+ ,((BoxSingle, BoxSingle, BoxSingle, BoxNone), '├')
+ ,((BoxSingle, BoxHeavy, BoxSingle, BoxNone), '┝')
+ ,((BoxHeavy, BoxSingle, BoxSingle, BoxNone), '┞')
+ ,((BoxSingle, BoxSingle, BoxHeavy, BoxNone), '┟')
+ ,((BoxHeavy, BoxSingle, BoxHeavy, BoxNone), '┠')
+ ,((BoxHeavy, BoxHeavy, BoxSingle, BoxNone), '┡')
+ ,((BoxSingle, BoxHeavy, BoxHeavy, BoxNone), '┢')
+ ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxNone), '┣')
+ ,((BoxSingle, BoxNone, BoxSingle, BoxSingle), '┤')
+ ,((BoxSingle, BoxNone, BoxSingle, BoxHeavy), '┥')
+ ,((BoxHeavy, BoxNone, BoxSingle, BoxSingle), '┦')
+ ,((BoxSingle, BoxNone, BoxHeavy, BoxSingle), '┧')
+ ,((BoxHeavy, BoxNone, BoxHeavy, BoxSingle), '┨')
+ ,((BoxHeavy, BoxNone, BoxSingle, BoxHeavy), '┩')
+ ,((BoxSingle, BoxNone, BoxHeavy, BoxHeavy), '┪')
+ ,((BoxHeavy, BoxNone, BoxHeavy, BoxHeavy), '┫')
+ ,((BoxNone, BoxSingle, BoxSingle, BoxSingle), '┬')
+ ,((BoxNone, BoxSingle, BoxSingle, BoxHeavy), '┭')
+ ,((BoxNone, BoxHeavy, BoxSingle, BoxSingle), '┮')
+ ,((BoxNone, BoxHeavy, BoxSingle, BoxHeavy), '┯')
+ ,((BoxNone, BoxSingle, BoxHeavy, BoxSingle), '┰')
+ ,((BoxNone, BoxSingle, BoxHeavy, BoxHeavy), '┱')
+ ,((BoxNone, BoxHeavy, BoxHeavy, BoxSingle), '┲')
+ ,((BoxNone, BoxHeavy, BoxHeavy, BoxHeavy), '┳')
+ ,((BoxSingle, BoxSingle, BoxNone, BoxSingle), '┴')
+ ,((BoxSingle, BoxSingle, BoxNone, BoxHeavy), '┵')
+ ,((BoxSingle, BoxHeavy, BoxNone, BoxSingle), '┶')
+ ,((BoxSingle, BoxHeavy, BoxNone, BoxHeavy), '┷')
+ ,((BoxHeavy, BoxSingle, BoxNone, BoxSingle), '┸')
+ ,((BoxHeavy, BoxSingle, BoxNone, BoxHeavy), '┹')
+ ,((BoxHeavy, BoxHeavy, BoxNone, BoxSingle), '┺')
+ ,((BoxHeavy, BoxHeavy, BoxNone, BoxHeavy), '┻')
+ ,((BoxSingle, BoxSingle, BoxSingle, BoxSingle), '┼')
+ ,((BoxSingle, BoxSingle, BoxSingle, BoxHeavy), '┽')
+ ,((BoxSingle, BoxHeavy, BoxSingle, BoxSingle), '┾')
+ ,((BoxSingle, BoxHeavy, BoxSingle, BoxHeavy), '┿')
+ ,((BoxHeavy, BoxSingle, BoxSingle, BoxSingle), '╀')
+ ,((BoxSingle, BoxSingle, BoxHeavy, BoxSingle), '╁')
+ ,((BoxHeavy, BoxSingle, BoxHeavy, BoxSingle), '╂')
+ ,((BoxHeavy, BoxSingle, BoxSingle, BoxHeavy), '╃')
+ ,((BoxHeavy, BoxHeavy, BoxSingle, BoxSingle), '╄')
+ ,((BoxSingle, BoxSingle, BoxHeavy, BoxHeavy), '╅')
+ ,((BoxSingle, BoxHeavy, BoxHeavy, BoxSingle), '╆')
+ ,((BoxHeavy, BoxHeavy, BoxSingle, BoxHeavy), '╇')
+ ,((BoxSingle, BoxHeavy, BoxHeavy, BoxHeavy), '╈')
+ ,((BoxHeavy, BoxSingle, BoxHeavy, BoxHeavy), '╉')
+ ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxSingle), '╊')
+ ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxHeavy), '╋')
+ ,((BoxNone, BoxDouble, BoxNone, BoxDouble), '═')
+ ,((BoxDouble, BoxNone, BoxDouble, BoxNone), '║')
+ ,((BoxNone, BoxDouble, BoxSingle, BoxNone), '╒')
+ ,((BoxNone, BoxSingle, BoxDouble, BoxNone), '╓')
+ ,((BoxNone, BoxDouble, BoxDouble, BoxNone), '╔')
+ ,((BoxNone, BoxNone, BoxSingle, BoxDouble), '╕')
+ ,((BoxNone, BoxNone, BoxDouble, BoxSingle), '╖')
+ ,((BoxNone, BoxNone, BoxDouble, BoxDouble), '╗')
+ ,((BoxSingle, BoxDouble, BoxNone, BoxNone), '╘')
+ ,((BoxDouble, BoxSingle, BoxNone, BoxNone), '╙')
+ ,((BoxDouble, BoxDouble, BoxNone, BoxNone), '╚')
+ ,((BoxSingle, BoxNone, BoxNone, BoxDouble), '╛')
+ ,((BoxDouble, BoxNone, BoxNone, BoxSingle), '╜')
+ ,((BoxDouble, BoxNone, BoxNone, BoxDouble), '╝')
+ ,((BoxSingle, BoxDouble, BoxSingle, BoxNone), '╞')
+ ,((BoxDouble, BoxSingle, BoxDouble, BoxNone), '╟')
+ ,((BoxDouble, BoxDouble, BoxDouble, BoxNone), '╠')
+ ,((BoxSingle, BoxNone, BoxSingle, BoxDouble), '╡')
+ ,((BoxDouble, BoxNone, BoxDouble, BoxSingle), '╢')
+ ,((BoxDouble, BoxNone, BoxDouble, BoxDouble), '╣')
+ ,((BoxNone, BoxDouble, BoxSingle, BoxDouble), '╤')
+ ,((BoxNone, BoxSingle, BoxDouble, BoxSingle), '╥')
+ ,((BoxNone, BoxDouble, BoxDouble, BoxDouble), '╦')
+ ,((BoxSingle, BoxDouble, BoxNone, BoxDouble), '╧')
+ ,((BoxDouble, BoxSingle, BoxNone, BoxSingle), '╨')
+ ,((BoxDouble, BoxDouble, BoxNone, BoxDouble), '╩')
+ ,((BoxSingle, BoxDouble, BoxSingle, BoxDouble), '╪')
+ ,((BoxDouble, BoxSingle, BoxDouble, BoxSingle), '╫')
+ ,((BoxDouble, BoxDouble, BoxDouble, BoxDouble), '╬')]
diff --git a/src/System/IO/Terminal/IO.hs b/src/System/IO/Terminal/IO.hs
new file mode 100644
index 0000000..fb0f1c2
--- /dev/null
+++ b/src/System/IO/Terminal/IO.hs
@@ -0,0 +1,57 @@
+{-|
+Module : System.IO.Terminal.IO
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Extra terminal management utility functions. This module basically extends
+the @ansi-terminal@ package.
+-}
+module System.IO.Terminal.IO
+ (queryTermSize
+ -- ,withWinchHandler
+ ,toAlternateScreen
+ ,fromAlternateScreen)
+ where
+
+-- import Foreign.C.Types
+import qualified System.Console.Terminal.Size as TS
+-- import System.Exit
+import System.IO
+-- import System.Posix.Signals
+
+
+-- sigWINCH :: CInt
+-- sigWINCH = 28
+
+
+-- | Request the current terminal size from the terminal. Probably not very
+-- fast.
+queryTermSize :: IO (Int, Int)
+queryTermSize = TS.size >>= \case
+ Just win -> return (TS.width win, TS.height win)
+ Nothing -> error "Cannot get terminal size"
+
+-- withWinchHandler :: IO () -> IO a -> IO a
+-- withWinchHandler h act = do
+-- prevh <- installHandler sigWINCH (Catch h) Nothing
+-- case prevh of
+-- Default -> return ()
+-- Ignore -> return ()
+-- _ -> die "ERROR: A signal handler was already installed for the WINCH signal!"
+
+-- res <- act
+
+-- _ <- installHandler sigWINCH prevh Nothing
+-- return res
+
+-- | Switch to the \"alternate screen\", if the terminal supports it.
+toAlternateScreen :: IO ()
+toAlternateScreen = putStr "\x1B[?1049h" >> hFlush stdout
+
+-- | Switch from the \"alternate screen\" back to the normal buffer, if the
+-- terminal supports it.
+fromAlternateScreen :: IO ()
+fromAlternateScreen = putStr "\x1B[?1049l" >> hFlush stdout
diff --git a/src/System/IO/Terminal/Input.hs b/src/System/IO/Terminal/Input.hs
new file mode 100644
index 0000000..86db30d
--- /dev/null
+++ b/src/System/IO/Terminal/Input.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-}
+{-|
+Module : System.IO.Terminal.Input
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Keyboard input for console applications.
+
+A monad transformer is defined that allows reading keys from the
+keyboard in symbolic form, i.e. escape sequences have already been
+parsed.
+-}
+module System.IO.Terminal.Input
+ (InputT, Input, withInput, liftIO, MonadInput(..)
+ ,Key(..)
+ ,InfInt(..), readKey)
+ where
+
+import Control.Monad.Trans
+import Control.Monad.State.Strict
+import Data.Maybe
+import Numeric.InfInt
+import System.IO.Terminal.Render
+import System.IO.Terminal.Input.Key
+import System.IO.Terminal.Input.SeqParser
+-- import qualified Utils.Debug as Debug
+import Utils.Time
+
+#if defined(OS_LINUX) || defined(OS_MACOS)
+import System.IO.Terminal.Input.Posix
+#else
+import System.IO.Terminal.Input.Windows
+#endif
+
+
+-- | Escape sequence timeout in milliseconds.
+gEscTimeoutMS :: Int
+gEscTimeoutMS = 100
+
+
+-- | The keyboard input monad transformer. The contained monad must be
+-- a monad over 'IO'.
+newtype InputT m a = InputT (StateT InputState m a)
+ deriving (Functor, Applicative, Monad, MonadState InputState, MonadTrans)
+
+deriving instance MonadIO m => MonadIO (InputT m)
+
+-- | The non-transformer variant of 'InputT'.
+type Input = InputT IO
+
+data InputState = InputState { sKeys :: [Key]
+ , sParser :: SeqParser (Maybe Char) Key
+ -- If the timeout event was already returned, Infinity
+ , sLastKey :: InfInt }
+
+-- | Run an 'Input' computation within an IO-based monad.
+withInput :: MonadIO m => InputT m a -> m a
+withInput (InputT st) =
+ withRawMode $ evalStateT st (InputState [] seqParser Infinity)
+
+
+-- | The behavior class for the 'InputT' monad transformer.
+class Monad m => MonadInput m where
+ -- | Timeout in milliseconds; Infinity is no timeout. Returns Nothing
+ -- in case the timeout was reached.
+ readKeyTimeout :: InfInt -> m (Maybe Key)
+
+instance MonadIO m => MonadInput (InputT m) where
+ readKeyTimeout userTimeout =
+ get >>= \s -> case sKeys s of
+ [] -> do
+ let SeqParser parserFunc = sParser s
+
+ beforeKey <- timestampMS <$> liftIO getSystemTime
+
+ -- These timeouts are either 'Finite timeout' in milliseconds, or 'Infinity' in case
+ -- no timeout is needed.
+ let -- Possibly the amount of time left for the next escape sequence item
+ escTimeout = let delta = Finite beforeKey - sLastKey s
+ left = Finite gEscTimeoutMS - delta
+ in if left < 0 then 0 else left
+ -- We wait until either the user timeout or the escape timeout passes, whichever
+ -- is earlier
+ timeoutVal = min userTimeout escTimeout
+
+ -- Debug.logIO ("readKeyTimeout", beforeKey, userTimeout, sLastKey s, escTimeout, timeoutVal)
+
+ ch <- liftIO $ getCharTimeout (toFinite timeoutVal)
+
+ let userTimeoutTriggered = isNothing ch && userTimeout < escTimeout
+ -- If we hit the user timeout, return appropriately
+ if userTimeoutTriggered
+ then {-Debug.logIO "returning Nothing" >>-} return Nothing
+ else do
+ -- We either got an actual key, or we hit the escape timeout. In either
+ -- case, we advance the escape sequence parser.
+ let (ks, p') = parserFunc ch
+ -- Debug.logIO ("keys", ks)
+
+ -- If we got an escape timeout, we'll be reporting it so we mark the last
+ -- key as "long ago" to not report an escape timeout twice to the parser.
+ -- Otherwise, we "start the escape timer" by storing the time of receipt of
+ -- this key.
+ afterKey <- timestampMS <$> liftIO getSystemTime
+ let newLastKey = maybe Infinity (const $ Finite afterKey) ch
+ modify $ \s' -> s' { sKeys = ks, sParser = p', sLastKey = newLastKey }
+
+ -- Either way, we stored some stuff in sKeys, so either that contains keys
+ -- to return, or we got nothing yet and need to retry; recursing handles
+ -- both cases nicely.
+ let userLeft = userTimeout - Finite (afterKey - beforeKey)
+ readKeyTimeout userLeft
+
+ (k:ks) -> do
+ put (s { sKeys = ks })
+ -- Debug.logIO (Just k)
+ return (Just k)
+
+instance MonadInput (RenderT Input) where
+ readKeyTimeout = lift . readKeyTimeout
+
+-- | Read a key from standard input without timeout. Shortcut for
+-- @readKeyTimeout Infinity@.
+readKey :: MonadInput m => m Key
+readKey = fromJust <$> readKeyTimeout Infinity
diff --git a/src/System/IO/Terminal/Input/Key.hs b/src/System/IO/Terminal/Input/Key.hs
new file mode 100644
index 0000000..40b52c3
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Key.hs
@@ -0,0 +1,27 @@
+{-|
+Module : System.IO.Terminal.Input.Key
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+-}
+module System.IO.Terminal.Input.Key where
+
+
+-- | A keypress. This does not attempt to model all possible keypresses
+-- that the user may enter, since not all can be recognised in the terminal
+-- anyway. The argument to 'KInvalid' contains some description of the
+-- unknown key.
+data Key = KChar Char
+ | KUp | KDown | KRight | KLeft
+ | KEnter | KDelete | KBackspace
+ | KPageDown | KPageUp | KHome | KEnd
+ | KTab
+ | KEsc
+ | KMod { kShift :: Bool
+ , kCtrl :: Bool
+ , kAlt :: Bool
+ , kKey :: Key }
+ | KInvalid String
+ deriving (Eq, Ord, Show)
diff --git a/src/System/IO/Terminal/Input/Posix.hs b/src/System/IO/Terminal/Input/Posix.hs
new file mode 100644
index 0000000..85f0268
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Posix.hs
@@ -0,0 +1,187 @@
+{-|
+Module : System.IO.Terminal.Input.Posix
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS
+
+Platform-specific submodule of "System.IO.Terminal.Input" that works on POSIX-like platforms.
+-}
+module System.IO.Terminal.Input.Posix
+ (withRawMode, getCharTimeout
+ ,seqParser)
+ where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Char
+import Data.Function
+import Data.List
+import Data.Maybe
+import System.IO
+import System.IO.Terminal.Input.Key
+import System.IO.Terminal.Input.SeqParser
+import System.Timeout
+
+
+-- | Run an IO-monadic computation with terminal input buffering and echo
+-- turned off.
+withRawMode :: MonadIO m => m a -> m a
+withRawMode = withNoBuffering . withNoEcho
+ where
+ withNoBuffering = with (hGetBuffering stdin `takeLeft` hSetBuffering stdin NoBuffering) (hSetBuffering stdin)
+ withNoEcho = with (hGetEcho stdin `takeLeft` hSetEcho stdin False) (hSetEcho stdin)
+ with start stop act = do
+ val <- liftIO start
+ res <- act
+ _ <- liftIO $ stop val
+ return res
+ takeLeft a b = a >>= \x -> b >> return x
+
+
+peekIO :: Show a => IO a -> IO a
+-- peekIO act = act >>= \x -> print ("peekIO", x) >> return x
+peekIO = id
+
+-- | Get a character from standard input, returning Nothing if no character
+-- has appeared after the specified number of milliseconds.
+getCharTimeout :: Maybe Int -> IO (Maybe Char)
+getCharTimeout (Just timeoutms) = peekIO (timeout (1000 * timeoutms) getChar)
+getCharTimeout Nothing = peekIO (Just <$> getChar)
+
+
+-- | An ANSI escape sequence parser. Pass Nothing to the input if the time
+-- between the surrounding characters was "very long", for some definition
+-- of "very long" (a reasonable value is ~10ms). This timeout value is used
+-- to determine whether certain characters belong together in an escape
+-- sequence or are just unrelated keys.
+seqParser :: SeqParser (Maybe Char) Key
+seqParser = SeqParser $ \case
+ Nothing -> ([], seqParser)
+ Just '\ESC' -> ([], escParser)
+ Just c -> ([recogSingle c], seqParser)
+ where
+ escParser :: SeqParser (Maybe Char) Key
+ escParser = SeqParser $ \case
+ Nothing -> ([KEsc], seqParser)
+ Just '\ESC' -> ([], escEscParser)
+ Just '[' -> ([], ansiParser)
+ Just c -> ([addAlt (recogSingle c)], seqParser)
+
+ escEscParser :: SeqParser (Maybe Char) Key
+ escEscParser = SeqParser $ \case
+ Nothing -> ([addAlt KEsc], seqParser)
+ Just '[' -> ([], fmap1st addAlt ansiParser)
+ Just '\ESC' -> ([addAlt KEsc], escParser)
+ Just c -> ([addAlt KEsc, KChar c], seqParser)
+
+ ansiParser :: SeqParser (Maybe Char) Key
+ ansiParser = fmap recogSequence (untilRangeParser (chr 0x40, chr 0x7e) 64)
+ `followedBy` seqParser
+ where
+ recogSequence :: Maybe [Char] -> Key
+ recogSequence mstr = fromMaybe (KInvalid (show mstr)) $ do
+ str <- mstr
+ guard (not $ null str)
+ guard (length str < 64)
+ args <- parseArguments (init str)
+ recognise args (last str)
+
+ parseArguments :: String -> Maybe [Int]
+ parseArguments = collect . groupBy ((==) `on` isDigit)
+ where
+ collect :: [String] -> Maybe [Int]
+ collect []
+ = Just []
+ collect [num] | Just val <- parseNum num
+ = Just [val]
+ collect (num:sep:args) | Just val <- parseNum num, validSep sep
+ = (val:) <$> collect args
+ collect _
+ = Nothing
+
+ parseNum :: String -> Maybe Int
+ parseNum "" = Nothing
+ parseNum str
+ | all isDigit str = Just (read str)
+ | otherwise = Nothing
+
+ validSep :: String -> Bool
+ validSep ";" = True
+ validSep ":" = True
+ validSep _ = False
+
+ -- Terminating character is included in string
+ -- If a timeout occurs, returns Nothing
+ untilRangeParser :: (Char, Char) -> Int -> SeqParserOnce (Maybe Char) (Maybe [Char])
+ untilRangeParser (from, to) maxlen = SeqParserOnce (charHandler 0)
+ where
+ charHandler :: Int -> Maybe Char -> SeqParserOnce' (Maybe Char) (Maybe [Char])
+ charHandler _ Nothing = SeqParserVal Nothing
+ charHandler len (Just c)
+ | len >= maxlen = SeqParserVal Nothing
+ | from <= c && c <= to = SeqParserVal (Just [c])
+ | otherwise = SeqParserOnce' $ \mc' -> let rec = charHandler (len + 1) mc'
+ in fmap (fmap (c :)) rec
+
+ recognise :: [Int] -> Char -> Maybe Key
+ recognise args 'A' = Just (arrowMod args KUp)
+ recognise args 'B' = Just (arrowMod args KDown)
+ recognise args 'C' = Just (arrowMod args KRight)
+ recognise args 'D' = Just (arrowMod args KLeft)
+ recognise [] 'H' = Just KHome
+ recognise [1,2] 'H' = Just (addShift KHome)
+ recognise [1,5] 'H' = Just (addCtrl KHome)
+ recognise [1,6] 'H' = Just (addShift $ addCtrl KHome)
+ recognise [1,9] 'H' = Just (addAlt KHome)
+ recognise [1,13] 'H' = Just (addCtrl $ addAlt KHome)
+ recognise [1,10] 'H' = Just (addShift $ addAlt KHome)
+ recognise [1,14] 'H' = Just (addCtrl $ addShift $ addAlt KHome)
+ recognise [] 'F' = Just KEnd
+ recognise [1,2] 'F' = Just (addShift KEnd)
+ recognise [1,5] 'F' = Just (addCtrl KEnd)
+ recognise [1,6] 'F' = Just (addShift $ addCtrl KEnd)
+ recognise [1,9] 'F' = Just (addAlt KEnd)
+ recognise [1,13] 'F' = Just (addCtrl $ addAlt KEnd)
+ recognise [1,10] 'F' = Just (addShift $ addAlt KEnd)
+ recognise [1,14] 'F' = Just (addCtrl $ addShift $ addAlt KEnd)
+ recognise _ 'Z' = Just (addShift KTab)
+ recognise [] '~' = Just KDelete
+ recognise [1] '~' = Just KHome
+ recognise [3] '~' = Just KDelete
+ recognise [4] '~' = Just KEnd
+ recognise [5] '~' = Just KPageUp
+ recognise [6] '~' = Just KPageDown
+ recognise [n,2] '~' = addShift <$> recognise [n] '~'
+ recognise [n,5] '~' = addCtrl <$> recognise [n] '~'
+ recognise _ _ = Nothing
+
+ recogSingle :: Char -> Key
+ recogSingle '\HT' = KTab
+ recogSingle '\LF' = KEnter
+ recogSingle '\CR' = KEnter
+ recogSingle '\DEL' = KBackspace
+ recogSingle '\NUL' = addCtrl (KChar ' ')
+ recogSingle c
+ | ord c < 27 = addCtrl (KChar (chr $ ord 'a' - 1 + ord c))
+ | 32 <= ord c, ord c <= 126 = KChar c
+ | otherwise = KInvalid [c]
+
+ arrowMod :: [Int] -> Key -> Key
+ arrowMod [1,2] = addShift
+ arrowMod [1,3] = addAlt
+ arrowMod [1,5] = addCtrl
+ arrowMod [1,6] = addCtrl . addShift
+ arrowMod [1,7] = addCtrl . addAlt
+ arrowMod _ = id -- in particular, []
+
+ addCtrl, addShift, addAlt :: Key -> Key
+ addCtrl = kmodify (\km -> km { kCtrl = True })
+ addShift = kmodify (\km -> km { kShift = True })
+ addAlt = kmodify (\km -> km { kAlt = True })
+
+ kmodify :: (Key -> Key) -> Key -> Key
+ kmodify f k@(KMod {}) = f k
+ kmodify _ (KInvalid s) = KInvalid s
+ kmodify f k = f (KMod False False False k)
diff --git a/src/System/IO/Terminal/Input/SeqParser.hs b/src/System/IO/Terminal/Input/SeqParser.hs
new file mode 100644
index 0000000..8dfdafc
--- /dev/null
+++ b/src/System/IO/Terminal/Input/SeqParser.hs
@@ -0,0 +1,49 @@
+{-|
+Module : System.IO.Terminal.Input.SeqParser
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+This module defines a coroutine-like, finite-state-machine-like type,
+'SeqParser'. Sequence parsers consume an infinite stream of values,
+producing zero or more output values after each input value read. The
+described parser is explicitly lazy to have full and explicit control over
+the amount of input necessary to produce an output value.
+-}
+module System.IO.Terminal.Input.SeqParser where
+
+
+-- | Consumes an explicitly lazy stream of @a@\'s, producing a staggered
+-- infinite stream of @b@\'s.
+newtype SeqParser a b = SeqParser (a -> ([b], SeqParser a b))
+
+-- | Consumes an explicitly lazy stream of @a@\'s, and after some nonzero
+-- number of such values, produces a @b@.
+data SeqParserOnce a b = SeqParserOnce (a -> SeqParserOnce' a b)
+-- | A 'SeqParserOnce' that does not guarantee to consume at least one
+-- @a@.
+data SeqParserOnce' a b = SeqParserOnce' (a -> SeqParserOnce' a b) | SeqParserVal b
+
+-- | Modify the next result from the 'SeqParser'.
+fmap1st :: (b -> b) -> SeqParser a b -> SeqParser a b
+fmap1st f (SeqParser g) =
+ SeqParser $ \a -> case g a of
+ ([], p) -> ([], fmap1st f p)
+ (b : bs, p) -> (f b : bs, p)
+
+instance Functor (SeqParserOnce a) where
+ fmap f (SeqParserOnce g) = SeqParserOnce (fmap f . g)
+
+instance Functor (SeqParserOnce' a) where
+ fmap f (SeqParserVal x) = SeqParserVal (f x)
+ fmap f (SeqParserOnce' g) = SeqParserOnce' (fmap f . g)
+
+-- | After the 'SeqParserOnce' is done, continue processing input with the
+-- 'SeqParser'.
+followedBy :: SeqParserOnce a b -> SeqParser a b -> SeqParser a b
+followedBy (SeqParserOnce g) p =
+ SeqParser $ \a -> case g a of
+ SeqParserVal b -> ([b], p)
+ SeqParserOnce' g' -> ([], SeqParserOnce g' `followedBy` p)
diff --git a/src/System/IO/Terminal/Input/Windows.hs b/src/System/IO/Terminal/Input/Windows.hs
new file mode 100644
index 0000000..0ac4122
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Windows.hs
@@ -0,0 +1,80 @@
+{-|
+Module : System.IO.Terminal.Input.Windows
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : Windows
+
+Platform-specific submodule of "System.IO.Terminal.Input" that works on Windows.
+-}
+module System.IO.Terminal.Input.Windows
+ (withRawMode, getCharTimeout
+ ,seqParser)
+ where
+
+import Control.Monad.IO.Class
+import Data.Char
+import System.IO.HiddenChar
+import System.IO.Terminal.Input.Key
+import System.IO.Terminal.Input.SeqParser
+
+
+-- | Run an IO-monadic computation with terminal input buffering and echo
+-- turned off.
+--
+-- Note: on Windows this is currently nonfunctional.
+withRawMode :: MonadIO m => m a -> m a
+withRawMode = id
+
+
+peekIO :: Show a => IO a -> IO a
+-- peekIO act = act >>= \x -> print ("peekIO", x) >> return x
+peekIO = id
+
+-- | Get a character from standard input, returning Nothing if no character
+-- has appeared after the specified number of milliseconds.
+--
+-- Note: on Windows the timeout is currently ineffective.
+getCharTimeout :: Maybe Int -> IO (Maybe Char)
+getCharTimeout _ = peekIO (Just <$> getHiddenChar)
+
+
+-- | A Windows conio control sequence parser. Pass Nothing to the input if
+-- the time between the surrounding characters was "very long", for some
+-- definition of "very long" (a reasonable value is ~10ms). This timeout
+-- value is used to determine whether certain characters belong together in
+-- an escape sequence or are just unrelated keys.
+seqParser :: SeqParser (Maybe Char) Key
+seqParser = SeqParser $ \case
+ Nothing -> ([], seqParser)
+ Just '\224' -> ([], escParser)
+ Just c -> ([recogSingle c], seqParser)
+ where
+ escParser :: SeqParser (Maybe Char) Key
+ escParser = SeqParser $ \case
+ Nothing -> ([KInvalid "timeout"], seqParser)
+ Just 'H' -> ([KUp], seqParser)
+ Just 'P' -> ([KDown], seqParser)
+ Just 'M' -> ([KRight], seqParser)
+ Just 'K' -> ([KLeft], seqParser)
+ Just c -> ([KInvalid ['\224', c]], seqParser)
+
+ recogSingle :: Char -> Key
+ recogSingle '\ESC' = KEsc
+ recogSingle '\HT' = KTab
+ recogSingle '\LF' = KEnter
+ recogSingle '\CR' = KEnter
+ recogSingle '\BS' = KBackspace
+ recogSingle '\NUL' = addCtrl (KChar ' ')
+ recogSingle c
+ | ord c < 27 = addCtrl (KChar (chr $ ord 'a' - 1 + ord c))
+ | 32 <= ord c, ord c <= 126 = KChar c
+ | otherwise = KInvalid [c]
+
+ addCtrl :: Key -> Key
+ addCtrl = kmodify (\km -> km { kCtrl = True })
+
+ kmodify :: (Key -> Key) -> Key -> Key
+ kmodify f k@(KMod {}) = f k
+ kmodify f k = f (KMod False False False k)
diff --git a/src/System/IO/Terminal/Render.hs b/src/System/IO/Terminal/Render.hs
new file mode 100644
index 0000000..6939c9f
--- /dev/null
+++ b/src/System/IO/Terminal/Render.hs
@@ -0,0 +1,312 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
+{-|
+Module : System.IO.Terminal.Render
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Double-buffering terminal UI library.
+
+This library was inspired by [ncurses](https://www.gnu.org/software/ncurses/ncurses.html)
+in type of functionality and by [termio](https://github.com/tomsmeding/termio)
+in featureset and API. It offers a double-buffered interface for writing
+text on the terminal without being bound to the classical sequential-output
+model that one gets when just printing text without regard for the extra
+features of the terminal.
+
+The API is an imperative DSL that runs in the 'RenderT' monad
+transformer. Because the draw buffer (on which the drawing commands
+operate) is separate from the screen buffer (in which the actual screen
+contents live) (hence "double-buffered"), the user needs to
+__explicitly__ commit their changes to the screen using the 'redraw'
+function. The upside of this is that only the parts of the interface
+that actually changed since the last update are committed to the
+screen.
+
+Functions that write text to the draw buffer generally take the text
+position as an argument, so there is no "current cursor position" in
+the API. On the other hand, the drawing style /is/ stateful, in that
+the current foreground/background color and text formatting rules apply
+for all subsequent writes until the current style is changed to
+something else.
+
+All positions in the terminal are in (x, y) format, where the top-left
+corner is (0, 0).
+-}
+module System.IO.Terminal.Render
+ (Style(..), RGB, defaultStyle
+ ,RenderT, Render, withRender, liftIO
+ ,getTermSize
+ ,redraw, redrawFull
+ ,write, putc
+ ,readPixel
+ ,setStyle, setFg, setBg, setBold, setUnderline
+ ,savingStyle
+ ,fillRect, clearScreen
+ ,bel
+ ,module System.IO.Terminal.Characters)
+ where
+
+import Control.Concurrent
+import Control.Monad.State.Strict
+import Data.Array.IO
+import Data.Colour.SRGB hiding (RGB)
+import Data.Foldable (toList)
+import Data.Word
+import qualified System.Console.ANSI as A
+import System.Exit
+import System.IO
+import System.IO.Terminal.Characters
+import qualified System.IO.Terminal.IO as IO
+import Utils.Monad
+
+
+-- NOTE ON COORDINATES
+-- Friendly coordinates are in the form (x, y), but the world is not
+-- friendly.
+-- * Function arguments: (x, y)
+-- * Array indices: (y, x)
+-- * A.setCursorPosition: (y, x)
+-- Unless explicitly indicated otherwise.
+
+-- Other notes
+-- - For box-drawing characters, it _may_ be necessary to write the C0
+-- codes SO and SI; see https://stackoverflow.com/a/4499628
+
+
+-- | A color in red-green-blue format. (255, 255, 255) is white.
+type RGB = (Word8, Word8, Word8)
+
+-- | The monad transformer on which the drawing commands operate. The
+-- wrapped monad should be a monad over 'IO' (i.e. needs to be an instance
+-- of 'MonadIO').
+newtype RenderT m a = RenderT { unRenderT :: StateT RState m a }
+ deriving (Functor, Applicative, Monad, MonadState RState, MonadTrans)
+
+deriving instance MonadIO m => MonadIO (RenderT m)
+
+-- | A convenience type alias for if 'Render' is the bottom-most monad in
+-- the stack.
+type Render = RenderT IO
+
+data RState = RState { rDrawBuffer :: !(IOArray (Int, Int) Cell)
+ , rScreenBuffer :: !(IOArray (Int, Int) Cell)
+ , rCurrentStyle :: !Style }
+
+data Cell = Cell { cChar :: !Char
+ , cStyle :: !Style }
+ deriving (Eq, Show)
+
+-- | A drawing style. If a color is 'Nothing', it is the color that the
+-- terminal uses by default.
+data Style = Style { sFg :: !(Maybe RGB)
+ , sBg :: !(Maybe RGB)
+ , sBold :: !Bool
+ , sUnderline :: !Bool }
+ deriving (Eq, Show)
+
+-- | The default style of the terminal, i.e. the style that one would get
+-- without explicit styling in the terminal. Note in particular that the
+-- foreground and background colors may be anything: dark-on-light or
+-- light-on-dark are both possible.
+defaultStyle :: Style
+defaultStyle = Style { sFg = Nothing, sBg = Nothing, sBold = False, sUnderline = False }
+
+initRState :: IO RState
+initRState = do
+ (wid, hei) <- IO.queryTermSize
+ let emptyCell = Cell { cChar = ' ', cStyle = defaultStyle }
+ bufferConstructor = newArray ((0, 0), (hei - 1, wid - 1)) emptyCell
+ drawBuffer <- bufferConstructor
+ screenBuffer <- bufferConstructor
+ return $ RState { rDrawBuffer = drawBuffer
+ , rScreenBuffer = screenBuffer
+ , rCurrentStyle = defaultStyle }
+
+-- | Run a 'Render' computation in an IO-monad.
+withRender :: MonadIO m => RenderT m a -> m a
+withRender act = do
+ whenM (liftIO $ not <$> hIsTerminalDevice stdout) $
+ liftIO $ die "ERROR: Stdout is not connected to a terminal!"
+
+ liftIO $ A.hSupportsANSIWithoutEmulation stdout >>= \case
+ Just True -> return ()
+ Just False -> die "ERROR: Terminal is not capable of interpreting ANSI escape sequences!"
+ Nothing -> do
+ hPutStrLn stderr "WARNING: Cannot determine terminal capabilities; continuing anyway..."
+ threadDelay 1000000
+
+ liftIO IO.toAlternateScreen
+ liftIO A.clearScreen
+ liftIO A.hideCursor
+ st <- liftIO initRState
+ res <- evalStateT (unRenderT act) st
+ liftIO A.showCursor
+ liftIO IO.fromAlternateScreen
+ return res
+
+-- | Commit the changes from the draw buffer to the screen buffer.
+redraw :: MonadIO m => RenderT m ()
+redraw = redrawGen False
+
+-- | Commit the draw buffer to the screen buffer, disabling the caching
+-- mechanism: this unconditionally redraws the whole screen. This would
+-- normally be bound to e.g. a ctrl-L keyboard shortcut in a terminal
+-- application.
+redrawFull :: MonadIO m => RenderT m ()
+redrawFull = redrawGen True
+
+redrawGen :: MonadIO m => Bool -> RenderT m ()
+redrawGen full = do
+ drawBuffer <- gets rDrawBuffer
+ screenBuffer <- gets rScreenBuffer
+ size@(wid, hei) <- getTermSize
+ let indices = range ((0, 0), (hei - 1, wid - 1))
+
+ liftIO $ do
+ A.setSGR (styleToSGR defaultStyle)
+ foldM_ (applyCell drawBuffer screenBuffer size) (defaultStyle, (-1, -1)) indices
+ hFlush stdout
+
+ liftIO $ copyArray screenBuffer drawBuffer
+ where
+ applyCell :: IOArray (Int, Int) Cell -- drawbuf
+ -> IOArray (Int, Int) Cell -- screenbuf
+ -> (Int, Int) -- screen size@(y, x)
+ -> (Style, (Int, Int)) -- current (style, curpos@(y, x))
+ -> (Int, Int) -- index@(y, x)
+ -> IO (Style, (Int, Int)) -- new (style, curpos@(y, x))
+ applyCell drawbuf screenbuf size (style, curpos) idx = do
+ dcell <- readArray drawbuf idx
+ scell <- readArray screenbuf idx
+ if dcell /= scell || full
+ then do
+ when (cStyle dcell /= style) $ A.setSGR (styleToSGR (cStyle dcell))
+ when (curpos /= idx) $ uncurry A.setCursorPosition idx
+ putChar (cChar dcell)
+ return (cStyle dcell, incrCursorYX size idx)
+ else do
+ return (style, curpos)
+
+-- | Get the current terminal size. This is a cheap operation.
+getTermSize :: MonadIO m => RenderT m (Int, Int)
+getTermSize = do
+ drawBuffer <- gets rDrawBuffer
+ (_, (maxy, maxx)) <- liftIO (getBounds drawBuffer)
+ return (maxx + 1, maxy + 1)
+
+-- | Write some text to the draw buffer at the given position.
+write :: MonadIO m => (Int, Int) -> String -> RenderT m ()
+write (x, y1) str = do
+ (wid, hei) <- getTermSize
+ let writeLine y line = sequence_ [putc' (x', y) c | (x', c) <- zip [x..] line]
+ sequence_ [writeLine y (take (wid - x) line)
+ | (y, line) <- take (hei - y1) $ zip [y1..] (lines str)]
+
+-- | Write one character to the draw buffer at the given position.
+putc :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
+putc (x, y) c = whenM (inBounds (x, y)) $ putc' (x, y) c
+
+putc' :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
+putc' (x, y) c = do
+ drawBuffer <- gets rDrawBuffer
+ style <- gets rCurrentStyle
+ let cell = Cell { cChar = c, cStyle = style }
+ liftIO $ writeArray drawBuffer (y, x) cell
+
+-- | Obtain the current character and style in the draw buffer at the given
+-- position.
+readPixel :: MonadIO m => (Int, Int) -> RenderT m (Style, Char)
+readPixel (x, y) =
+ ifM (inBounds (x, y))
+ (do buf <- gets rDrawBuffer
+ Cell ch sty <- liftIO $ readArray buf (y, x)
+ return (sty, ch))
+ (return (defaultStyle, ' '))
+
+incrCursorYX :: (Int, Int) -> (Int, Int) -> (Int, Int)
+incrCursorYX (hei, wid) (y, x)
+ | x + 1 == wid = if y + 1 == hei then (y, 0) else (y + 1, 0)
+ | otherwise = (y, x + 1)
+
+-- | Set the current style.
+setStyle :: Monad m => Style -> RenderT m ()
+setStyle style = modify' $ \s -> s { rCurrentStyle = style }
+
+modifyCurrentStyle :: Monad m => (Style -> Style) -> RenderT m ()
+modifyCurrentStyle f = modify' $ \s -> s { rCurrentStyle = f (rCurrentStyle s)}
+
+-- | Set the foreground color component of the current style.
+setFg :: Monad m => Maybe RGB -> RenderT m ()
+setFg clr = modifyCurrentStyle (\s -> s { sFg = clr })
+
+-- | Set the background color component of the current style.
+setBg :: Monad m => Maybe RGB -> RenderT m ()
+setBg clr = modifyCurrentStyle (\s -> s { sBg = clr })
+
+-- | Set the boldface component of the current style.
+setBold :: Monad m => Bool -> RenderT m ()
+setBold bold = modifyCurrentStyle (\s -> s { sBold = bold })
+
+-- | Set the text-underline component of the current style.
+setUnderline :: Monad m => Bool -> RenderT m ()
+setUnderline ul = modifyCurrentStyle (\s -> s { sUnderline = ul })
+
+-- | Fill a rectangle, specified using its top-left and bottom-right
+-- corners, with a particular character. Calling this function with a space
+-- character allows clearing a subregion of the screen.
+fillRect :: MonadIO m => (Int, Int) -> (Int, Int) -> Char -> RenderT m ()
+fillRect (fromx, fromy) (tox, toy) ch =
+ forM_ [(x, y) | y <- [fromy..toy], x <- [fromx..tox]] $ \(x, y) -> do
+ putc' (x, y) ch
+
+-- | Clear the whole screen. This may also be accomplished using 'fillRect'
+-- with appropriate bounds.
+clearScreen :: MonadIO m => RenderT m ()
+clearScreen = savingStyle $ do
+ (w, h) <- getTermSize
+ setStyle defaultStyle
+ fillRect (0, 0) (w-1, h-1) ' '
+
+-- | After running the computation, restore the current style as it was
+-- before running the computation.
+savingStyle :: MonadIO m => RenderT m a -> RenderT m a
+savingStyle act = do
+ st <- gets rCurrentStyle
+ res <- act
+ setStyle st
+ return res
+
+styleToSGR :: Style -> [A.SGR]
+styleToSGR style =
+ [A.Reset] ++
+ toList (A.SetRGBColor A.Foreground . fromRGB <$> sFg style) ++
+ toList (A.SetRGBColor A.Background . fromRGB <$> sBg style) ++
+ (if sBold style then [A.SetConsoleIntensity A.BoldIntensity] else []) ++
+ (if sUnderline style then [A.SetUnderlining A.SingleUnderline] else [])
+
+fromRGB :: RGB -> Colour Float
+fromRGB (r, g, b) = sRGB24 r g b
+
+-- | Sound the terminal bell (plonk, dong, BEEP). This bypasses the buffer
+-- model, i.e. it happens immediately.
+bel :: MonadIO m => RenderT m ()
+bel = liftIO $ putChar '\BEL' >> hFlush stdout
+
+inBounds :: MonadIO m => (Int, Int) -> RenderT m Bool
+inBounds (x, y) = do
+ (wid, hei) <- getTermSize
+ return $ x >= 0 && x < wid && y >= 0 && y < hei
+
+
+-- Bounds of dest and src should be equal!
+copyArray :: (MArray a e m, Ix i) => a i e -> a i e -> m ()
+copyArray dest src = do
+ destbounds <- getBounds dest
+ srcbounds <- getBounds src
+ when (srcbounds /= destbounds) $ error "Logic error: incompatible array bounds in copyArray"
+
+ forM_ (range destbounds) $ \idx ->
+ readArray src idx >>= writeArray dest idx
diff --git a/src/Utils/Monad.hs b/src/Utils/Monad.hs
new file mode 100644
index 0000000..3c1ad17
--- /dev/null
+++ b/src/Utils/Monad.hs
@@ -0,0 +1,26 @@
+{-|
+Module : Utils.Monad
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+Some useful functions lifted to monadic actions.
+-}
+module Utils.Monad where
+
+
+-- | If the boolean resolves to True, returns the first argument, else the
+-- second.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM b t e = b >>= \b' -> if b' then t else e
+
+-- | Runs the monadic action only if the boolean resolves to True.
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM b t = ifM b t (return ())
+
+-- | whenJust m a = when (isJust m) (a (fromJust m)), but with less
+-- fromJust.
+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenJust = flip (maybe (return ()))
diff --git a/src/Utils/Time.hs b/src/Utils/Time.hs
new file mode 100644
index 0000000..2139c53
--- /dev/null
+++ b/src/Utils/Time.hs
@@ -0,0 +1,43 @@
+{-|
+Module : Utils.Time
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+-}
+module Utils.Time where
+
+import Data.Time.Clock
+import Data.Time.Clock.System hiding (getSystemTime)
+import qualified Data.Time.Clock.System as Sys
+import Data.Time.Format
+
+
+-- | A timestamp in milliseconds.
+newtype TimeStamp = TimeStamp Int
+ deriving (Show, Read, Eq, Ord)
+
+-- | The number of milliseconds stored in the timestamp newtype.
+timestampMS :: TimeStamp -> Int
+timestampMS (TimeStamp n) = n
+
+-- | Offset the timestamp by the given number of milliseconds.
+plusMS :: TimeStamp -> Int -> TimeStamp
+plusMS (TimeStamp n) m = TimeStamp (n + m)
+
+-- | The number of milliseconds that the first timestamp is later than the
+-- second.
+subtractMS :: TimeStamp -> TimeStamp -> Int
+subtractMS (TimeStamp n) (TimeStamp m) = n - m
+
+-- | Return the current system time as a timestamp.
+getSystemTime :: IO TimeStamp
+getSystemTime = TimeStamp . systemToMS <$> Sys.getSystemTime
+ where
+ systemToMS tm = let MkSystemTime s ns = truncateSystemTimeLeapSecond tm
+ in fromIntegral s * 1000 + fromIntegral ns `div` 1000000
+
+-- | Show a UTCTime in ISO-8601 format.
+iso8601Show :: UTCTime -> String
+iso8601Show = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))