path: root/src/System/IO/Terminal/Render.hs

{-# 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