diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/System/IO/Terminal/IO.hs | 34 | ||||
| -rw-r--r-- | src/System/IO/Terminal/IO/Posix.hs | 37 | ||||
| -rw-r--r-- | src/System/IO/Terminal/IO/Windows.hs | 19 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input.hs | 11 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Render.hs | 113 | ||||
| -rw-r--r-- | src/Utils/Monad.hs | 36 |
6 files changed, 192 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 diff --git a/src/Utils/Monad.hs b/src/Utils/Monad.hs index 3c1ad17..b52b53b 100644 --- a/src/Utils/Monad.hs +++ b/src/Utils/Monad.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-| Module : Utils.Monad Copyright : (c) UU, 2019 @@ -10,6 +13,11 @@ Some useful functions lifted to monadic actions. -} module Utils.Monad where +import Control.Monad.IO.Unlift +import Control.Monad.State.Strict (StateT (..), lift, get, put, MonadState, MonadTrans) +import Data.IORef +import Control.Exception (bracket, bracket_) + -- | If the boolean resolves to True, returns the first argument, else the -- second. @@ -24,3 +32,31 @@ whenM b t = ifM b t (return ()) -- fromJust. whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip (maybe (return ())) + +-- | 'bracket', but unlifted. +unliftBracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m b) -> m b +unliftBracket f g h = + withRunInIO $ \run -> + bracket (run f) (run . g) (run . h) + +-- | 'bracket_', but unlifted. +unliftBracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c +unliftBracket_ f g h = + withRunInIO $ \run -> + bracket_ (run f) (run g) (run h) + +newtype StateTUnliftIOWrapper s m a = StateTUnliftIOWrapper { runStateTUnliftIOWrapper :: StateT s m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadState s, MonadTrans) + +instance MonadUnliftIO m => MonadUnliftIO (StateTUnliftIOWrapper s m) where + withRunInIO act = StateTUnliftIOWrapper $ do + state0 <- get + ref <- liftIO $ newIORef state0 + let runner mrun (StateT mf) = do + s1 <- readIORef ref + (res, s2) <- runStateT (StateT $ mrun . mf) s1 + writeIORef ref s2 + return res + res <- lift $ withRunInIO $ \mrun -> act (runner mrun . runStateTUnliftIOWrapper) + liftIO (readIORef ref) >>= put + return res |