Handling of SIGWINCH (and some maintenance)HEADmaster

5 files changed, 156 insertions, 58 deletions

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