diff options
Diffstat (limited to 'src/System/IO/Terminal/Render.hs')
| -rw-r--r-- | src/System/IO/Terminal/Render.hs | 113 |
1 files changed, 84 insertions, 29 deletions
diff --git a/src/System/IO/Terminal/Render.hs b/src/System/IO/Terminal/Render.hs index f3f0b59..cae01e9 100644 --- a/src/System/IO/Terminal/Render.hs +++ b/src/System/IO/Terminal/Render.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-| Module : System.IO.Terminal.Render Copyright : (c) UU, 2019 @@ -49,6 +53,9 @@ module System.IO.Terminal.Render ,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) @@ -61,6 +68,12 @@ 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 @@ -82,7 +95,8 @@ type RGB = (Word8, Word8, Word8) -- 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 newtype (Functor, Applicative, Monad, MonadState RState, MonadTrans) + deriving MonadUnliftIO via StateTUnliftIOWrapper RState m deriving instance MonadIO m => MonadIO (RenderT m) @@ -92,7 +106,9 @@ type Render = RenderT IO data RState = RState { rDrawBuffer :: !(IOArray (Int, Int) Cell) , rScreenBuffer :: !(IOArray (Int, Int) Cell) - , rCurrentStyle :: !Style } + , rCurrentStyle :: !Style + , rWinchChan :: !(TChan ()) + , rForceFullRedraw :: !Bool } data Cell = Cell { cChar :: !Char , cStyle :: !Style } @@ -113,34 +129,39 @@ data Style = Style { sFg :: !(Maybe RGB) defaultStyle :: Style defaultStyle = Style { sFg = Nothing, sBg = Nothing, sBold = False, sUnderline = False } -initRState :: IO RState -initRState = do +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 - let emptyCell = Cell { cChar = ' ', cStyle = defaultStyle } - bufferConstructor = newArray ((0, 0), (hei - 1, wid - 1)) emptyCell - drawBuffer <- bufferConstructor - screenBuffer <- bufferConstructor + drawBuffer <- allocateBuffer (wid, hei) + screenBuffer <- allocateBuffer (wid, hei) return $ RState { rDrawBuffer = drawBuffer , rScreenBuffer = screenBuffer - , rCurrentStyle = defaultStyle } + , rCurrentStyle = defaultStyle + , rWinchChan = winchChan + , rForceFullRedraw = False } -- | Run a 'Render' computation in an IO-monad. -withRender :: MonadIO m => RenderT m a -> m a +withRender :: MonadUnliftIO 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 $ 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!" - 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 + 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 () @@ -154,7 +175,11 @@ redrawFull :: MonadIO m => RenderT m () redrawFull = redrawGen True redrawGen :: MonadIO m => Bool -> RenderT m () -redrawGen full = do +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 @@ -162,18 +187,19 @@ redrawGen full = do liftIO $ do A.setSGR (styleToSGR defaultStyle) - foldM_ (applyCell drawBuffer screenBuffer size) (defaultStyle, (-1, -1)) indices + foldM_ (applyCell full drawBuffer screenBuffer size) (defaultStyle, (-1, -1)) indices hFlush stdout liftIO $ copyArray screenBuffer drawBuffer where - applyCell :: IOArray (Int, Int) Cell -- drawbuf + 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 drawbuf screenbuf size (style, curpos) idx = do + applyCell full drawbuf screenbuf size (style, curpos) idx = do dcell <- readArray drawbuf idx scell <- readArray screenbuf idx if dcell /= scell || full @@ -185,12 +211,31 @@ redrawGen full = do else do return (style, curpos) --- | Get the current terminal size. This is a cheap operation. +-- | 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 - drawBuffer <- gets rDrawBuffer - (_, (maxy, maxx)) <- liftIO (getBounds drawBuffer) - return (maxx + 1, maxy + 1) + 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 () @@ -317,3 +362,13 @@ copyArray dest src = do 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 |