d478957 · vty · git.iko.soy

ModeDemo.hsnew file+52

compare with master

unifiedsplit

@@ -0,0 +1,52 @@

1+module Main where

2+

3+import Data.Monoid

4+

5+import Graphics.Vty

6+

7+mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image

8+mkUI (m, ms, p, ps) e =

9+ vertCat [ string defAttr $ "Mouse mode supported: " <> show m

10+ , string defAttr $ "Mouse mode status: " <> show ms

11+ , string defAttr " "

12+ , string defAttr $ "Paste mode supported: " <> show p

13+ , string defAttr $ "Paste mode status: " <> show ps

14+ , string defAttr " "

15+ , string defAttr $ "Last event: " <> show e

16+ , string defAttr " "

17+ , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit."

18+ ]

19+

20+main :: IO ()

21+main = do

22+ cfg <- standardIOConfig

23+ vty <- mkVty cfg

24+

25+ let renderUI lastE = do

26+ let output = outputIface vty

27+ info <- (,,,) <$> (pure $ supportsMode output Mouse)

28+ <*> getModeStatus output Mouse

29+ <*> (pure $ supportsMode output BracketedPaste)

30+ <*> getModeStatus output BracketedPaste

31+ return $ picForImage $ mkUI info lastE

32+

33+ let go lastE = do

34+ pic <- renderUI lastE

35+ update vty pic

36+ e <- nextEvent vty

37+ case e of

38+ EvKey (KChar 'q') [] -> return ()

39+ EvKey (KChar 'm') [] -> do

40+ let output = outputIface vty

41+ enabled <- getModeStatus output Mouse

42+ setMode output Mouse (not enabled)

43+ go (Just e)

44+ EvKey (KChar 'p') [] -> do

45+ let output = outputIface vty

46+ enabled <- getModeStatus output BracketedPaste

47+ setMode output BracketedPaste (not enabled)

48+ go (Just e)

49+ _ -> go (Just e)

50+

51+ go Nothing

52+ shutdown vty

src/Graphics/Vty.hs+2

@@ -49,6 +49,7 @@ module Graphics.Vty ( Vty(..)

49 , module Graphics.Vty.Output

50 , module Graphics.Vty.Picture

51 , DisplayRegion

52+ , Mode(..)

52 )

53 )

53 where

54 where

54

55

@@ -57,6 +58,7 @@ import Graphics.Vty.Prelude

57import Graphics.Vty.Config

58import Graphics.Vty.Config

58import Graphics.Vty.Input

59import Graphics.Vty.Input

59import Graphics.Vty.Output

60import Graphics.Vty.Output

61+import Graphics.Vty.Output.Interface

60import Graphics.Vty.Picture

62import Graphics.Vty.Picture

61

63

62import Control.Concurrent.STM

64import Control.Concurrent.STM

src/Graphics/Vty/Config.hs+10

@@ -104,6 +104,10 @@ data Config = Config

104 vmin :: Maybe Int

105 -- | The default is 100 milliseconds, 0.1 seconds.

106 , vtime :: Maybe Int

107+ -- | The default is False.

108+ , mouseMode :: Maybe Bool

109+ -- | The default is False.

110+ , bracketedPasteMode :: Maybe Bool

107 -- | Debug information is appended to this file if not Nothing.

111 -- | Debug information is appended to this file if not Nothing.

108 , debugLog :: Maybe FilePath

112 , debugLog :: Maybe FilePath

109 -- | The (input byte, output event) pairs extend the internal input table of VTY and the table

113 -- | The (input byte, output event) pairs extend the internal input table of VTY and the table

@@ -127,6 +131,8 @@ instance Monoid Config where

127 mempty = Config

131 mempty = Config

128 { vmin = Nothing

132 { vmin = Nothing

129 , vtime = Nothing

133 , vtime = Nothing

134+ , mouseMode = Nothing

135+ , bracketedPasteMode = Nothing

130 , debugLog = mempty

136 , debugLog = mempty

131 , inputMap = mempty

137 , inputMap = mempty

132 , inputFd = Nothing

138 , inputFd = Nothing

@@ -137,6 +143,8 @@ instance Monoid Config where

137 -- latter config takes priority for everything but inputMap

143 -- latter config takes priority for everything but inputMap

138 { vmin = vmin c1 <|> vmin c0

144 { vmin = vmin c1 <|> vmin c0

139 , vtime = vtime c1 <|> vtime c0

145 , vtime = vtime c1 <|> vtime c0

146+ , mouseMode = mouseMode c1

147+ , bracketedPasteMode = bracketedPasteMode c1

140 , debugLog = debugLog c1 <|> debugLog c0

148 , debugLog = debugLog c1 <|> debugLog c0

141 , inputMap = inputMap c0 <> inputMap c1

149 , inputMap = inputMap c0 <> inputMap c1

142 , inputFd = inputFd c1 <|> inputFd c0

150 , inputFd = inputFd c1 <|> inputFd c0

@@ -163,6 +171,8 @@ standardIOConfig :: IO Config

163standardIOConfig = do

171standardIOConfig = do

164 Just t <- getEnv "TERM"

172 Just t <- getEnv "TERM"

165 return $ def { vmin = Just 1

173 return $ def { vmin = Just 1

174+ , mouseMode = Just False

175+ , bracketedPasteMode = Just False

166 , vtime = Just 100

176 , vtime = Just 100

167 , inputFd = Just stdInput

177 , inputFd = Just stdInput

168 , outputFd = Just stdOutput

178 , outputFd = Just stdOutput

src/Graphics/Vty/Output.hs+9

@@ -65,6 +65,15 @@ outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do

65 then XTermColor.reserveTerminal termName fd

66 -- Not an xterm-like terminal. try for generic terminfo.

67 else TerminfoBased.reserveTerminal termName fd

68+

69+ case mouseMode of

70+ Just s -> setMode t Mouse s

71+ Nothing -> return ()

72+

73+ case bracketedPasteMode of

74+ Just s -> setMode t BracketedPaste s

75+ Nothing -> return ()

76+

68 return t

77 return t

69outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig

78outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig

70

79

src/Graphics/Vty/Output/Interface.hs+11

@@ -37,6 +37,11 @@ import qualified Data.Vector as Vector

37import Data.Monoid (mempty, mappend)

38#endif

39

40+-- | Modal terminal features that can be enabled and disabled.

41+data Mode = Mouse

42+ | BracketedPaste

43+ deriving (Eq, Read, Show)

44+

40data Output = Output

45data Output = Output

41 { -- | Text identifier for the output device. Used for debugging.

46 { -- | Text identifier for the output device. Used for debugging.

42 terminalID :: String

47 terminalID :: String

@@ -67,6 +72,12 @@ data Output = Output

67 , contextColorCount :: Int

72 , contextColorCount :: Int

68 -- | if the cursor can be shown / hidden

73 -- | if the cursor can be shown / hidden

69 , supportsCursorVisibility :: Bool

74 , supportsCursorVisibility :: Bool

75+ -- | Indicates support for terminal modes for this output device

76+ , supportsMode :: Mode -> Bool

77+ -- | Enables or disables a mode (does nothing if the mode is unsupported)

78+ , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()

79+ -- | Returns whether a mode is enabled

80+ , getModeStatus :: forall m. MonadIO m => Mode -> m Bool

70 , assumedStateRef :: IORef AssumedState

81 , assumedStateRef :: IORef AssumedState

71 -- | Acquire display access to the given region of the display.

82 -- | Acquire display access to the given region of the display.

72 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

83 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

src/Graphics/Vty/Output/Mock.hs+3

@@ -47,6 +47,9 @@ mockTerminal r = liftIO $ do

47 writeIORef outRef $ UTF8.fromRep bytes

48 , contextColorCount = 16

49 , supportsCursorVisibility = True

50+ , supportsMode = const False

51+ , setMode = const $ const $ return ()

52+ , getModeStatus = const $ return False

50 , assumedStateRef = newAssumedStateRef

53 , assumedStateRef = newAssumedStateRef

51 , mkDisplayContext = \tActual rActual -> return $ DisplayContext

54 , mkDisplayContext = \tActual rActual -> return $ DisplayContext

52 { contextRegion = rActual

55 { contextRegion = rActual

src/Graphics/Vty/Output/TerminfoBased.hs+3

@@ -173,6 +173,9 @@ reserveTerminal termName outFd = liftIO $ do

173 Just v -> toEnum v

174 True -> 1

175 , supportsCursorVisibility = isJust $ civis terminfoCaps

176+ , supportsMode = const False

177+ , setMode = const $ const $ return ()

178+ , getModeStatus = const $ return False

176 , assumedStateRef = newAssumedStateRef

179 , assumedStateRef = newAssumedStateRef

177 -- I think fix would help assure tActual is the only reference. I was having issues

180 -- I think fix would help assure tActual is the only reference. I was having issues

178 -- tho.

181 -- tho.

src/Graphics/Vty/Output/XTermColor.hs+29−5

@@ -15,8 +15,9 @@ import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

15import Blaze.ByteString.Builder (writeToByteString)

16import Blaze.ByteString.Builder.Word (writeWord8)

17

18−import Control.Monad (void)

18+import Control.Monad (void, when)

19import Control.Monad.Trans

20+import Data.IORef

20

21

21import System.Posix.IO (fdWrite)

22import System.Posix.IO (fdWrite)

22import System.Posix.Types (Fd)

23import System.Posix.Types (Fd)

@@ -34,19 +35,42 @@ reserveTerminal variant outFd = liftIO $ do

34 -- xterm-color is broken.

35 -- xterm-color is broken.

35 let variant' = if variant == "xterm-color" then "xterm" else variant

36 let variant' = if variant == "xterm-color" then "xterm" else variant

36 flushedPut setUtf8CharSet

37 flushedPut setUtf8CharSet

37− flushedPut enableBracketedPastes

38− flushedPut requestMouseEvents

39 t <- TerminfoBased.reserveTerminal variant' outFd

38 t <- TerminfoBased.reserveTerminal variant' outFd

39+

40+ mouseModeStatus <- newIORef False

41+ pasteModeStatus <- newIORef False

42+

43+ let xtermSetMode t' m newStatus = do

44+ curStatus <- getModeStatus t' m

45+ when (newStatus /= curStatus) $

46+ case m of

47+ Mouse -> liftIO $ do

48+ case newStatus of

49+ True -> flushedPut requestMouseEvents

50+ False -> flushedPut disableMouseEvents

51+ writeIORef mouseModeStatus newStatus

52+ BracketedPaste -> liftIO $ do

53+ case newStatus of

54+ True -> flushedPut enableBracketedPastes

55+ False -> flushedPut disableBracketedPastes

56+ writeIORef pasteModeStatus newStatus

57+

58+ xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus

59+ xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus

60+

40 let t' = t

61 let t' = t

41 { terminalID = terminalID t ++ " (xterm-color)"

62 { terminalID = terminalID t ++ " (xterm-color)"

42 , releaseTerminal = do

63 , releaseTerminal = do

43 liftIO $ flushedPut setDefaultCharSet

64 liftIO $ flushedPut setDefaultCharSet

44− liftIO $ flushedPut disableBracketedPastes

65+ setMode t' BracketedPaste False

45− liftIO $ flushedPut disableMouseEvents

66+ setMode t' Mouse False

46 releaseTerminal t

67 releaseTerminal t

47 , mkDisplayContext = \tActual r -> do

68 , mkDisplayContext = \tActual r -> do

48 dc <- mkDisplayContext t tActual r

69 dc <- mkDisplayContext t tActual r

49 return $ dc { inlineHack = xtermInlineHack t' }

70 return $ dc { inlineHack = xtermInlineHack t' }

71+ , supportsMode = const True

72+ , getModeStatus = xtermGetMode

73+ , setMode = xtermSetMode t'

50 }

74 }

51 return t'

75 return t'

52

76

vty.cabal+15

@@ -129,6 +129,21 @@ library

129

130 cc-options: -O2

131

132+executable vty-mode-demo

133+ main-is: ModeDemo.hs

134+

135+ default-language: Haskell2010

136+ default-extensions: ScopedTypeVariables

137+ ghc-options: -threaded

138+

139+ build-depends: vty,

140+ base >= 4 && < 5,

141+ containers,

142+ data-default >= 0.5.3,

143+ microlens,

144+ microlens-mtl,

145+ mtl >= 1.1.1.0 && < 2.3

146+

132executable vty-demo

147executable vty-demo

133 main-is: Demo.hs

148 main-is: Demo.hs

134

149