From afa2cb06002cc6ab42b17302b82cdcfc31e46bec Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Mon, 30 Sep 2019 16:51:01 -0700 Subject: [PATCH 1/2] Remove unnecessary MonadIO and MonadFail uses --- src/Graphics/Vty/Output.hs | 15 +++++------ src/Graphics/Vty/Output/Interface.hs | 26 +++++++++---------- src/Graphics/Vty/Output/TerminfoBased.hs | 33 ++++++++++-------------- 3 files changed, 33 insertions(+), 41 deletions(-) diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs index 133ecfb5..f902e0e4 100644 --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -38,9 +38,6 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased import Blaze.ByteString.Builder (writeToByteString) -import Control.Monad.Fail (MonadFail) -import Control.Monad.Trans - import Data.List (isPrefixOf) import Data.Monoid ((<>)) @@ -85,23 +82,23 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig -- Currently, the only way to set the cursor position to a given -- character coordinate is to specify the coordinate in the Picture -- instance provided to 'outputPicture' or 'refresh'. -setCursorPos :: (MonadIO m, MonadFail m) => Output -> Int -> Int -> m () +setCursorPos :: Output -> Int -> Int -> IO () setCursorPos t x y = do bounds <- displayBounds t when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do dc <- displayContext t bounds - liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y + outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y -- | Hides the cursor. -hideCursor :: (MonadIO m, MonadFail m) => Output -> m () +hideCursor :: Output -> IO () hideCursor t = do bounds <- displayBounds t dc <- displayContext t bounds - liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc + outputByteBuffer t $ writeToByteString $ writeHideCursor dc -- | Shows the cursor. -showCursor :: (MonadIO m, MonadFail m) => Output -> m () +showCursor :: Output -> IO () showCursor t = do bounds <- displayBounds t dc <- displayContext t bounds - liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc + outputByteBuffer t $ writeToByteString $ writeShowCursor dc diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs index 15046906..27db7bc3 100644 --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -62,7 +62,7 @@ data Output = Output terminalID :: String -- | Release the terminal just prior to application exit and reset -- it to its state prior to application startup. - , releaseTerminal :: forall m. MonadIO m => m () + , releaseTerminal :: IO () -- | Clear the display and initialize the terminal to some initial -- display state. -- @@ -72,12 +72,12 @@ data Output = Output -- - cursor at top left -- - UTF-8 character encoding -- - drawing characteristics are the default - , reserveDisplay :: forall m. MonadIO m => m () + , reserveDisplay :: IO () -- | Return the display to the state before `reserveDisplay` If no -- previous state then set the display state to the initial state. - , releaseDisplay :: forall m. MonadIO m => m () + , releaseDisplay :: IO () -- | Returns the current display bounds. - , displayBounds :: forall m. (MonadIO m, MonadFail m) => m DisplayRegion + , displayBounds :: IO DisplayRegion -- | Output the bytestring to the terminal device. , outputByteBuffer :: BS.ByteString -> IO () -- | Specifies the maximum number of colors supported by the @@ -89,23 +89,23 @@ data Output = Output , supportsMode :: Mode -> Bool -- | Enables or disables a mode (does nothing if the mode is -- unsupported). - , setMode :: forall m. MonadIO m => Mode -> Bool -> m () + , setMode :: Mode -> Bool -> IO () -- | Returns whether a mode is enabled. - , getModeStatus :: forall m. MonadIO m => Mode -> m Bool + , getModeStatus :: Mode -> IO Bool , assumedStateRef :: IORef AssumedState -- | Acquire display access to the given region of the display. -- Currently all regions have the upper left corner of (0,0) and -- the lower right corner at (max displayWidth providedWidth, max -- displayHeight providedHeight) - , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext + , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext -- | Ring the terminal bell if supported. - , ringTerminalBell :: forall m. MonadIO m => m () + , ringTerminalBell :: IO () -- | Returns whether the terminal has an audio bell feature. - , supportsBell :: forall m. MonadIO m => m Bool + , supportsBell :: IO Bool } -displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext -displayContext t = liftIO . mkDisplayContext t t +displayContext :: Output -> DisplayRegion -> IO DisplayContext +displayContext t = mkDisplayContext t t data AssumedState = AssumedState { prevFattr :: Maybe FixedAttr @@ -164,8 +164,8 @@ writeUtf8Text = writeByteString -- 4. Serialized to the display. -- -- 5. The cursor is then shown and positioned or kept hidden. -outputPicture :: MonadIO m => DisplayContext -> Picture -> m () -outputPicture dc pic = liftIO $ do +outputPicture :: DisplayContext -> Picture -> IO () +outputPicture dc pic = do urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink as <- readIORef (assumedStateRef $ contextDevice dc) let manipCursor = supportsCursorVisibility (contextDevice dc) diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs index 4bd8a5a6..715f46c2 100644 --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/src/Graphics/Vty/Output/TerminfoBased.hs @@ -25,9 +25,6 @@ import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable) -import Control.Monad.Fail (MonadFail) -import Control.Monad.Trans - import Data.Bits ((.&.)) import Data.Foldable (foldMap) import Data.IORef @@ -101,8 +98,8 @@ sendCapToTerminal t cap capParams = do -- -- * Providing independent string capabilities for all display -- attributes. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output -reserveTerminal termName outFd = liftIO $ do +reserveTerminal :: String -> Fd -> IO Output +reserveTerminal termName outFd = do ti <- Terminfo.setupTerm termName -- assumes set foreground always implies set background exists. -- if set foreground is not set then all color changing style @@ -131,13 +128,13 @@ reserveTerminal termName outFd = liftIO $ do curStatus <- terminfoModeStatus m when (newStatus /= curStatus) $ case m of - Hyperlink -> liftIO $ do + Hyperlink -> do writeIORef hyperlinkModeStatus newStatus writeIORef newAssumedStateRef initialAssumedState _ -> return () terminfoModeStatus m = case m of - Hyperlink -> liftIO $ readIORef hyperlinkModeStatus + Hyperlink -> readIORef hyperlinkModeStatus _ -> return False terminfoModeSupported Hyperlink = True terminfoModeSupported _ = False @@ -159,22 +156,22 @@ reserveTerminal termName outFd = liftIO $ do <*> probeCap ti "bel" let t = Output { terminalID = termName - , releaseTerminal = liftIO $ do + , releaseTerminal = do sendCap setDefaultAttr [] maybeSendCap cnorm [] , supportsBell = return $ isJust $ ringBellAudio terminfoCaps - , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio [] - , reserveDisplay = liftIO $ do + , ringTerminalBell = maybeSendCap ringBellAudio [] + , reserveDisplay = do -- If there is no support for smcup: Clear the screen -- and then move the mouse to the home position to -- approximate the behavior. maybeSendCap smcup [] sendCap clearScreen [] - , releaseDisplay = liftIO $ do + , releaseDisplay = do maybeSendCap rmcup [] maybeSendCap cnorm [] , displayBounds = do - rawSize <- liftIO $ getWindowSize outFd + rawSize <- getWindowSize outFd case rawSize of (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize | otherwise -> return (w,h) @@ -198,33 +195,31 @@ reserveTerminal termName outFd = liftIO $ do , assumedStateRef = newAssumedStateRef -- I think fix would help assure tActual is the only -- reference. I was having issues tho. - , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps + , mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps } sendCap s = sendCapToTerminal t (s terminfoCaps) maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) return t -requireCap :: (Applicative m, MonadIO m, MonadFail m) => Terminfo.Terminal -> String -> m CapExpression +requireCap :: Terminfo.Terminal -> String -> IO CapExpression requireCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" Just capStr -> parseCap capStr -probeCap :: (Applicative m, MonadIO m, MonadFail m) => Terminfo.Terminal -> String -> m (Maybe CapExpression) +probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression) probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr -parseCap :: (Applicative m, MonadIO m, MonadFail m) => String -> m CapExpression +parseCap :: String -> IO CapExpression parseCap capStr = do case parseCapExpression capStr of Left e -> fail $ show e Right cap -> return cap -currentDisplayAttrCaps :: ( Applicative m, MonadIO m, MonadFail m ) - => Terminfo.Terminal - -> m DisplayAttrCaps +currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps currentDisplayAttrCaps ti = pure DisplayAttrCaps <*> probeCap ti "sgr" From 4fcd927f29a60070746fa49753ebc0829c36ee2f Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 1 Oct 2019 08:42:34 -0700 Subject: [PATCH 2/2] Remove now redundant imports --- src/Graphics/Vty/Output/Interface.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs index 27db7bc3..72a3b064 100644 --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -29,9 +29,6 @@ import Graphics.Vty.DisplayAttributes import Blaze.ByteString.Builder (Write, writeToByteString) import Blaze.ByteString.Builder.ByteString (writeByteString) -import Control.Monad.Fail (MonadFail) -import Control.Monad.Trans - import qualified Data.ByteString as BS import Data.IORef import qualified Data.Text.Encoding as T