From b3da0f16b5e47732bc1b2d632088830dab87a77d Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 9 Jul 2023 16:22:47 +0200
Subject: Handling of SIGWINCH (and some maintenance)
---
src/System/IO/Terminal/IO.hs | 34 +++--------
src/System/IO/Terminal/IO/Posix.hs | 37 ++++++++++++
src/System/IO/Terminal/IO/Windows.hs | 19 ++++++
src/System/IO/Terminal/Input.hs | 11 +++-
src/System/IO/Terminal/Render.hs | 113 ++++++++++++++++++++++++++---------
5 files changed, 156 insertions(+), 58 deletions(-)
create mode 100644 src/System/IO/Terminal/IO/Posix.hs
create mode 100644 src/System/IO/Terminal/IO/Windows.hs
(limited to 'src/System')
diff --git a/src/System/IO/Terminal/IO.hs b/src/System/IO/Terminal/IO.hs
index fb0f1c2..6d57d11 100644
--- a/src/System/IO/Terminal/IO.hs
+++ b/src/System/IO/Terminal/IO.hs
@@ -9,22 +9,15 @@ 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
+module System.IO.Terminal.IO (
+ queryTermSize,
+ toAlternateScreen,
+ fromAlternateScreen,
+) where
--- import Foreign.C.Types
import qualified System.Console.Terminal.Size as TS
--- import System.Exit
+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
@@ -32,20 +25,7 @@ import System.IO
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
+ Nothing -> die "ERROR: Cannot get terminal size"
-- | Switch to the \"alternate screen\", if the terminal supports it.
toAlternateScreen :: IO ()
diff --git a/src/System/IO/Terminal/IO/Posix.hs b/src/System/IO/Terminal/IO/Posix.hs
new file mode 100644
index 0000000..6e44b86
--- /dev/null
+++ b/src/System/IO/Terminal/IO/Posix.hs
@@ -0,0 +1,37 @@
+{-|
+Module : System.IO.Terminal.IO.Posix
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS
+
+Platform-specific submodule of "System.IO.Terminal.IO" that works on POSIX-like platforms.
+-}
+module System.IO.Terminal.IO.Posix (
+ withWinchHandler,
+) where
+
+import Control.Exception (bracket)
+import Control.Monad.IO.Unlift (MonadUnliftIO(..))
+import Foreign.C.Types (CInt)
+import System.Exit (die)
+import System.Posix.Signals (installHandler, Handler(..))
+
+
+sigWINCH :: CInt
+sigWINCH = 28
+
+-- | Install a SIGWINCH handler, then run the body, then uninstall. Uses
+-- 'bracket'.
+withWinchHandler :: MonadUnliftIO m => IO () -> m a -> m a
+withWinchHandler h act =
+ withRunInIO $ \run ->
+ bracket (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!"
+ return prevh)
+ (\prevh -> installHandler sigWINCH prevh Nothing)
+ (\_ -> run act)
diff --git a/src/System/IO/Terminal/IO/Windows.hs b/src/System/IO/Terminal/IO/Windows.hs
new file mode 100644
index 0000000..a46ec85
--- /dev/null
+++ b/src/System/IO/Terminal/IO/Windows.hs
@@ -0,0 +1,19 @@
+{-|
+Module : System.IO.Terminal.IO.Windows
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : Windows
+
+Platform-specific submodule of "System.IO.Terminal.IO" that (does not yet) work on Windows.
+-}
+module System.IO.Terminal.IO.Windows where
+
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+
+
+-- | Currently does nothing, i.e. just executes the body as-is. WINCH support
+-- is currently unix-only.
+withWinchHandler :: MonadUnliftIO m => IO () -> m a -> m a
+withWinchHandler _ act = act
diff --git a/src/System/IO/Terminal/Input.hs b/src/System/IO/Terminal/Input.hs
index 86db30d..efacf4f 100644
--- a/src/System/IO/Terminal/Input.hs
+++ b/src/System/IO/Terminal/Input.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-|
Module : System.IO.Terminal.Input
Copyright : (c) UU, 2019
@@ -20,6 +24,7 @@ module System.IO.Terminal.Input
,InfInt(..), readKey)
where
+import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans
import Control.Monad.State.Strict
import Data.Maybe
@@ -29,6 +34,7 @@ import System.IO.Terminal.Input.Key
import System.IO.Terminal.Input.SeqParser
-- import qualified Utils.Debug as Debug
import Utils.Time
+import Utils.Monad
#if defined(OS_LINUX) || defined(OS_MACOS)
import System.IO.Terminal.Input.Posix
@@ -45,7 +51,8 @@ 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 newtype (Functor, Applicative, Monad, MonadState InputState, MonadTrans)
+ deriving MonadUnliftIO via StateTUnliftIOWrapper InputState m
deriving instance MonadIO m => MonadIO (InputT m)
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
--
cgit v1.2.3-70-g09d2