{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE 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, putcWith
    ,readPixel
    ,setStyle, setFg, setBg, setBold, setUnderline
    ,savingStyle
    ,fillRect, clearScreen
    ,bel
    ,module System.IO.Terminal.Characters)
    where

import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan (newTChan, writeTChan, TChan, tryReadTChan)
import Control.Monad.IO.Unlift
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

#if defined(OS_LINUX) || defined(OS_MACOS)
import qualified System.IO.Terminal.IO.Posix as IO
#else
import qualified System.IO.Terminal.IO.Windows as IO
#endif


-- 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 newtype (Functor, Applicative, Monad, MonadState RState, MonadTrans)
  deriving MonadUnliftIO via StateTUnliftIOWrapper RState m

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
                     , rWinchChan :: !(TChan ())
                     , rForceFullRedraw :: !Bool }

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 }

allocateBuffer :: (Int, Int) -> IO (IOArray (Int, Int) Cell)
allocateBuffer (wid, hei) = newArray ((0, 0), (hei - 1, wid - 1)) emptyCell
  where emptyCell = Cell { cChar = ' ', cStyle = defaultStyle }

initRState :: TChan () -> IO RState
initRState winchChan = do
    (wid, hei) <- IO.queryTermSize
    drawBuffer <- allocateBuffer (wid, hei)
    screenBuffer <- allocateBuffer (wid, hei)
    return $ RState { rDrawBuffer = drawBuffer
                    , rScreenBuffer = screenBuffer
                    , rCurrentStyle = defaultStyle
                    , rWinchChan = winchChan
                    , rForceFullRedraw = False }

-- | Run a 'Render' computation in an IO-monad.
withRender :: MonadUnliftIO m => RenderT m a -> m a
withRender act = do
    liftIO $ whenM (not <$> hIsTerminalDevice stdout) $
        die "ERROR: Stdout is not connected to a terminal!"

    liftIO $ whenM (not <$> A.hSupportsANSI stdout) $
        die "ERROR: Terminal is not capable of interpreting ANSI escape sequences!"

    winchChan <- liftIO $ atomically newTChan

    unliftBracket_ (liftIO IO.toAlternateScreen) (liftIO IO.fromAlternateScreen) $ do
        liftIO A.clearScreen
        unliftBracket_ (liftIO A.hideCursor) (liftIO A.showCursor) $ do
            IO.withWinchHandler (atomically $ writeTChan winchChan ()) $ do
                st <- liftIO $ initRState winchChan
                res <- evalStateT (unRenderT act) st
                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 fullRequest = do
    fullForced <- gets rForceFullRedraw
    modify $ \s -> s { rForceFullRedraw = False }
    let full = fullRequest || fullForced

    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 full drawBuffer screenBuffer size) (defaultStyle, (-1, -1)) indices
        hFlush stdout

    liftIO $ copyArray screenBuffer drawBuffer
  where
    applyCell :: Bool                     -- full redraw
              -> 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 full 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 does not roundtrip via the terminal on
-- every invocation (it only re-checks after a SIGWINCH), but does reallocate
-- the window buffers if things changed.
-- If the terminal size changed, the next redraw will automatically be a full
-- redraw.
getTermSize :: MonadIO m => RenderT m (Int, Int)
getTermSize = do
    winchChan <- gets rWinchChan
    liftIO (atomically $ tryReadTChan winchChan) >>= \case
        Nothing -> do
          drawBuffer <- gets rDrawBuffer
          (_, (maxy, maxx)) <- liftIO (getBounds drawBuffer)
          return (maxx + 1, maxy + 1)
        Just () -> do
          size <- liftIO IO.queryTermSize
          oldDrawbuf <- gets rDrawBuffer
          oldScreenbuf <- gets rScreenBuffer
          newDrawbuf <- liftIO $ allocateBuffer size
          newScreenbuf <- liftIO $ allocateBuffer size
          liftIO $ copyArrayIntersection newDrawbuf oldDrawbuf
          liftIO $ copyArrayIntersection newScreenbuf oldScreenbuf
          modify $ \s -> s { rDrawBuffer = newDrawbuf
                           , rScreenBuffer = newScreenbuf
                           , rForceFullRedraw = True }
          return size

-- | 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_ [unsafePutc (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)) $ unsafePutc (x, y) c

-- | Write one character to the draw buffer at the given position with the given
-- style (instead of the stateful style).
putcWith :: MonadIO m => Style -> (Int, Int) -> Char -> RenderT m ()
putcWith sty (x, y) c = whenM (inBounds (x, y)) $ unsafePutcWith sty (x, y) c

-- | 'putc', but don't check bounds
unsafePutc :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
unsafePutc (x, y) c = do
    style <- gets rCurrentStyle
    unsafePutcWith style (x, y) c

-- | 'putcWith', but don't check bounds
unsafePutcWith :: MonadIO m => Style -> (Int, Int) -> Char -> RenderT m ()
unsafePutcWith style (x, y) c = do
    drawBuffer <- gets rDrawBuffer
    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
        unsafePutc (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

-- Copies the intersection of the bounds.
copyArrayIntersection :: MArray a e m => a (Int, Int) e -> a (Int, Int) e -> m ()
copyArrayIntersection dest src = do
    ((ds1, ds2), (de1, de2)) <- getBounds dest
    ((ss1, ss2), (se1, se2)) <- getBounds src
    let bounds = ((max ss1 ds1, max ss2 ds2), (min se1 de1, min se2 de2))

    forM_ (range bounds) $ \idx ->
        readArray src idx >>= writeArray dest idx