1 files changed, 312 insertions, 0 deletions
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