master..2a88195 · vty · git.iko.soy

CHANGELOG.md−83

since splitsnapshots

unifiedsplit

@@ -1,87 +1,4 @@

1

2−5.35.1

3−------

4−

5−Bug fixes:

6− * Fixed a build issue with a test program.

7−

8−5.35

9−----

10−

11−New features:

12− * Add support for 24-bit color (thanks @u-quark). This change

13− updates Vty to look at the `COLORTERM` environment variable that is

14− conventionally used to advertise support for truecolor escape

15− sequences. The change also updates the Vty demo to demonstrate

16− 24-bit colors. This change also adds a new data type, `ColorMode`,

17− to represent the color mode in use, as well as an `Output` interface

18− field, `outputColorMode`, to track the active color mode and use it

19− to clamp emitted color escape sequences to the active color range.

20−

21−API changes:

22− * All types in `Graphics.Vty.Input.Events` now have strict constructor

23− fields.

24− * Internal events are now wrapped in a new `InternalEvent` type to

25− improve how signal handling is done. This change modifies the `Input`

26− type's event channel API to produce `InternalEvents`, not `Events`.

27− The new `InternalEvent` either wraps `Event` with the `InputEvent`

28− constructor (the previous behavior) or indicates that Vty resumed

29− after handling a signal using the `ResumeAfterSignal` constructor.

30− This change avoids the previous use of `EvResize` with lazy exception

31− arguments as a sentinel value for `ResumeAfterSignal`.

32−

33−Other enhancements:

34− * Bracketed paste parsing performance has been greatly improved thanks

35− to benchmarking and optimization work by @iphydf. As part of that

36− work, Vty now uses bytestrings rather than Strings internally when

37− parsing input to look for events.

38− * The `\b` value is now interpreted as `KBS` (thanks @vglfr)

39−

40−5.34

41−----

42−

43−API changes:

44− * Added an `NFData` instance for `Event` (thanks Mario Lang)

45− * Removed `Monoid` and `Semigroup` instances for `Attr` and

46− `MaybeDefault`. This change removed the instances because they were

47− misbehaved; merging `Attr` and `MaybeDefault` values with these

48− instances resulted in field value losses. For example, before this

49− change,

50−```

51−(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)

52−```

53− would result in just

54−```

55− (defAttr `withBackColor` green)

56−```

57− because the instances were designed to favor the right-hand

58− arguments' fields even if they had not been explicitly set

59− (a consequence of the `MaybeDefault` `Semigroup` instance).

60− While that behavior was sensible specifically in the context of

61− `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made

62− for surprising instance behavior. Since there is actually no good way

63− to handle this in a `Semigroup` instance for `Attr` -- some choices

64− have to be made about how to merge two attributes' foreground colors,

65− and that won't be much better than what we had -- the instance was

66− just removed.

67−

68−

69−5.33

70−----

71−

72−API changes:

73−* The `Cursor` type got a new `PositionOnly` constructor for cursor

74− placement without visibility.

75−

76−Package changes:

77−* Relaxed upper bound for `random`

78−* Updated `microlens` bounds to allow 0.4.12

79−

80−Other improvements:

81−* Various hlint-driven improvements (thanks Willem Van Onsem)

82−* The implementation of `color240` was improved (thanks (Willem Van

83− Onsem)

84−

855.32

25.32

86----

3----

87

4

demos/Demo.hs+4−12

@@ -31,8 +31,7 @@ introText = vertCat $ map (string defAttr)

31 [ "this line is hidden by the top layer"

32 , "The vty demo program will echo the events generated by the pressed keys."

33 , "Below there is a 240 color box."

34− , "Followed by a description of the 16 color palette."

34+ , "Followed by a description of the 16 color pallete."

35− , "Followed by tones of red using a 24-bit palette."

36 , "If the 240 color box is not visible then the terminal"

35 , "If the 240 color box is not visible then the terminal"

37 , "claims 240 colors are not supported."

36 , "claims 240 colors are not supported."

38 , "Try setting TERM to xterm-256color"

37 , "Try setting TERM to xterm-256color"

@@ -43,19 +42,12 @@ introText = vertCat $ map (string defAttr)

43 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"

42 , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"

44 ]

43 ]

45

44

46−splitColorImages :: [Image] -> [[Image]]

47−splitColorImages [] = []

48−splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

49−

50−fullcolorbox :: Image

51−fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages

52− where

53− colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255]

54−

55colorbox_240 :: Image

45colorbox_240 :: Image

56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

46colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

57 where

47 where

58 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

48 colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

49+ splitColorImages [] = []

50+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

59

51

60colorbox_16 :: Image

52colorbox_16 :: Image

@@ -78,7 +70,7 @@ updateDisplay = do

78 "Press ESC to exit. Events for keys below."

70 "Press ESC to exit. Events for keys below."

79 eventLog <- foldMap (string defAttr) <$> get

71 eventLog <- foldMap (string defAttr) <$> get

80 let pic = picForImage (info <-> eventLog)

72 let pic = picForImage (info <-> eventLog)

81− `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox)

73+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)

82 vty <- ask

74 vty <- ask

83 liftIO $ update vty pic

75 liftIO $ update vty pic

84

76

src/Data/Terminfo/Parse.hs+2−2

@@ -1,9 +1,9 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

3+{-# OPTIONS_HADDOCK hide #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

4{-# LANGUAGE NoMonomorphismRestriction #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE NamedFieldPuns #-}

5{-# OPTIONS_GHC -funbox-strict-fields -O #-}

6{-# OPTIONS_GHC -funbox-strict-fields -O #-}

6−{-# OPTIONS_HADDOCK hide #-}

7

8module Data.Terminfo.Parse

9 ( module Data.Terminfo.Parse

src/Graphics/Vty.hs+10−14

@@ -1,5 +1,4 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3

2

4-- | Vty provides interfaces for both terminal input and terminal

3-- | Vty provides interfaces for both terminal input and terminal

5-- output.

4-- output.

@@ -48,7 +47,6 @@ where

48

47

49import Graphics.Vty.Config

48import Graphics.Vty.Config

50import Graphics.Vty.Input

49import Graphics.Vty.Input

51−import Graphics.Vty.Input.Events

52import Graphics.Vty.Output

50import Graphics.Vty.Output

53import Graphics.Vty.Output.Interface

51import Graphics.Vty.Output.Interface

54import Graphics.Vty.Picture

52import Graphics.Vty.Picture

@@ -168,7 +166,7 @@ internalMkVty :: Input -> Output -> IO Vty

168internalMkVty input out = do

166internalMkVty input out = do

169 reserveDisplay out

167 reserveDisplay out

170

168

171− shutdownVar <- newTVarIO False

169+ shutdownVar <- atomically $ newTVar False

172 let shutdownIo = do

170 let shutdownIo = do

173 alreadyShutdown <- atomically $ swapTVar shutdownVar True

171 alreadyShutdown <- atomically $ swapTVar shutdownVar True

174 when (not alreadyShutdown) $ do

172 when (not alreadyShutdown) $ do

@@ -176,7 +174,7 @@ internalMkVty input out = do

176 releaseDisplay out

174 releaseDisplay out

177 releaseTerminal out

175 releaseTerminal out

178

176

179− let shutdownStatus = readTVarIO shutdownVar

177+ let shutdownStatus = atomically $ readTVar shutdownVar

180

178

181 lastPicRef <- newIORef Nothing

179 lastPicRef <- newIORef Nothing

182 lastUpdateRef <- newIORef Nothing

180 lastUpdateRef <- newIORef Nothing

@@ -210,18 +208,16 @@ internalMkVty input out = do

210 maybe (return ()) innerUpdate mPic

208 maybe (return ()) innerUpdate mPic

211

209

212 let mkResize = uncurry EvResize <$> displayBounds out

210 let mkResize = uncurry EvResize <$> displayBounds out

213−

214− translateInternalEvent ResumeAfterSignal = mkResize

215− translateInternalEvent (InputEvent e) = return e

216−

217 gkey = do

211 gkey = do

218− e <- atomically $ readTChan $ _eventChannel input

212+ k <- atomically $ readTChan $ _eventChannel input

219− translateInternalEvent e

213+ case k of

214+ (EvResize _ _) -> mkResize

215+ _ -> return k

220 gkey' = do

216 gkey' = do

221− mEv <- atomically $ tryReadTChan $ _eventChannel input

217+ k <- atomically $ tryReadTChan $ _eventChannel input

222− case mEv of

218+ case k of

223− Just e -> Just <$> translateInternalEvent e

219+ (Just (EvResize _ _)) -> Just <$> mkResize

224− Nothing -> return Nothing

220+ _ -> return k

225

221

226 return $ Vty { update = innerUpdate

222 return $ Vty { update = innerUpdate

227 , nextEvent = gkey

223 , nextEvent = gkey

src/Graphics/Vty/Attributes.hs+33

@@ -61,6 +61,9 @@ where

61

62import Control.DeepSeq

63import Data.Bits

64+#if !(MIN_VERSION_base(4,11,0))

65+import Data.Semigroup

66+#endif

64import Data.Text (Text)

67import Data.Text (Text)

65import Data.Word

68import Data.Word

66import GHC.Generics

69import GHC.Generics

@@ -113,6 +116,19 @@ data Attr = Attr

113-- Then the foreground color encoded into 8 bits.

116-- Then the foreground color encoded into 8 bits.

114-- Then the background color encoded into 8 bits.

117-- Then the background color encoded into 8 bits.

115

118

119+instance Semigroup Attr where

120+ attr0 <> attr1 =

121+ Attr ( attrStyle attr0 <> attrStyle attr1 )

122+ ( attrForeColor attr0 <> attrForeColor attr1 )

123+ ( attrBackColor attr0 <> attrBackColor attr1 )

124+ ( attrURL attr0 <> attrURL attr1 )

125+

126+instance Monoid Attr where

127+ mempty = Attr mempty mempty mempty mempty

128+#if !(MIN_VERSION_base(4,11,0))

129+ mappend = (<>)

130+#endif

131+

116-- | Specifies the display attributes such that the final style and

132-- | Specifies the display attributes such that the final style and

117-- color values do not depend on the previously applied display

133-- color values do not depend on the previously applied display

118-- attribute. The display attributes can still depend on the terminal's

134-- attribute. The display attributes can still depend on the terminal's

@@ -135,6 +151,23 @@ instance (NFData v) => NFData (MaybeDefault v) where

135 rnf KeepCurrent = ()

151 rnf KeepCurrent = ()

136 rnf (SetTo v) = rnf v

152 rnf (SetTo v) = rnf v

137

153

154+instance Eq v => Semigroup (MaybeDefault v) where

155+ Default <> Default = Default

156+ Default <> KeepCurrent = Default

157+ Default <> SetTo v = SetTo v

158+ KeepCurrent <> Default = Default

159+ KeepCurrent <> KeepCurrent = KeepCurrent

160+ KeepCurrent <> SetTo v = SetTo v

161+ SetTo _v <> Default = Default

162+ SetTo v <> KeepCurrent = SetTo v

163+ SetTo _ <> SetTo v = SetTo v

164+

165+instance Eq v => Monoid ( MaybeDefault v ) where

166+ mempty = KeepCurrent

167+#if !(MIN_VERSION_base(4,11,0))

168+ mappend = (<>)

169+#endif

170+

138-- | Styles are represented as an 8 bit word. Each bit in the word is 1

171-- | Styles are represented as an 8 bit word. Each bit in the word is 1

139-- if the style attribute assigned to that bit should be applied and 0

172-- if the style attribute assigned to that bit should be applied and 0

140-- if the style attribute should not be applied.

173-- if the style attribute should not be applied.

src/Graphics/Vty/Attributes/Color.hs+3−67

@@ -1,14 +1,8 @@

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveAnyClass #-}

3−{-# LANGUAGE MultiWayIf #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5

3

6module Graphics.Vty.Attributes.Color

4module Graphics.Vty.Attributes.Color

7 ( Color(..)

5 ( Color(..)

8− , ColorMode(..)

9−

10− -- * Detecting Terminal Color Support

11− , detectColorMode

12

6

13 -- ** Fixed Colors

7 -- ** Fixed Colors

14 -- | Standard 8-color ANSI terminal color codes.

8 -- | Standard 8-color ANSI terminal color codes.

@@ -38,10 +32,7 @@ module Graphics.Vty.Attributes.Color

38 , brightCyan

32 , brightCyan

39 , brightWhite

33 , brightWhite

40 -- ** Creating Colors From RGB

34 -- ** Creating Colors From RGB

41− , linearColor

42− , srgbColor

43 , rgbColor

35 , rgbColor

44− , color240

45 , module Graphics.Vty.Attributes.Color240

36 , module Graphics.Vty.Attributes.Color240

46 )

37 )

47where

38where

@@ -49,11 +40,6 @@ where

49import Data.Word

40import Data.Word

50import GHC.Generics

41import GHC.Generics

51import Control.DeepSeq

42import Control.DeepSeq

52−import System.Environment (lookupEnv)

53−

54−import qualified System.Console.Terminfo as Terminfo

55−import Control.Exception (catch)

56−import Data.Maybe

57

43

58import Graphics.Vty.Attributes.Color240

44import Graphics.Vty.Attributes.Color240

59

45

@@ -95,7 +81,7 @@ import Graphics.Vty.Attributes.Color240

95-- reported then the color reproduction will be incorrect.

81-- reported then the color reproduction will be incorrect.

96--

82--

97-- If the terminal reports <= 16 colors then the 240 color palette

83-- If the terminal reports <= 16 colors then the 240 color palette

98−-- points are only mapped to the 8 color palette. I'm not sure of

84+-- points are only mapped to the 8 color pallete. I'm not sure of

99-- the RGB points for the "bright" colors which is why they are not

85-- the RGB points for the "bright" colors which is why they are not

100-- addressable via the 240 color palette.

86-- addressable via the 240 color palette.

101--

87--

@@ -109,33 +95,9 @@ import Graphics.Vty.Attributes.Color240

109-- terminfo but I don't know it.

95-- terminfo but I don't know it.

110--

96--

111-- Seriously, terminal color support is INSANE.

97-- Seriously, terminal color support is INSANE.

112−data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8

98+data Color = ISOColor !Word8 | Color240 !Word8

113 deriving ( Eq, Show, Read, Generic, NFData )

99 deriving ( Eq, Show, Read, Generic, NFData )

114

100

115−data ColorMode

116− = NoColor

117− | ColorMode8

118− | ColorMode16

119− | ColorMode240 !Word8

120− | FullColor

121− deriving ( Eq, Show )

122−

123−detectColorMode :: String -> IO ColorMode

124−detectColorMode termName' = do

125− term <- catch (Just <$> Terminfo.setupTerm termName')

126− (\(_ :: Terminfo.SetupTermError) -> return Nothing)

127− let getCap cap = term >>= \t -> Terminfo.getCapability t cap

128− termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")

129− colorterm <- lookupEnv "COLORTERM"

130− return $ if

131− | termColors < 8 -> NoColor

132− | termColors < 16 -> ColorMode8

133− | termColors == 16 -> ColorMode16

134− | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)

135− | colorterm == Just "truecolor" -> FullColor

136− | colorterm == Just "24bit" -> FullColor

137− | otherwise -> ColorMode240 240

138−

139black, red, green, yellow, blue, magenta, cyan, white :: Color

101black, red, green, yellow, blue, magenta, cyan, white :: Color

140black = ISOColor 0

102black = ISOColor 0

141red = ISOColor 1

103red = ISOColor 1

@@ -157,35 +119,9 @@ brightMagenta= ISOColor 13

157brightCyan = ISOColor 14

119brightCyan = ISOColor 14

158brightWhite = ISOColor 15

120brightWhite = ISOColor 15

159

121

160−linearColor :: Integral i => i -> i -> i -> Color

161−linearColor r g b = RGBColor r' g' b'

162− where

163− r' = fromIntegral (clamp r) :: Word8

164− g' = fromIntegral (clamp g) :: Word8

165− b' = fromIntegral (clamp b) :: Word8

166− clamp = min 255 . max 0

167−

168−srgbColor :: Integral i => i -> i -> i -> Color

169−srgbColor r g b =

170− -- srgb to rgb transformation as described at

171− -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation

172− --

173− -- TODO: it may be worth translating this to a lookup table, as with color240

174− let shrink n = fromIntegral n / 255 :: Double

175− -- called gamma^-1 in wiki

176− gamma u

177− | u <= 0.04045 = u/12.92

178− | otherwise = ((u + 0.055) / 1.055) ** 2.4

179− -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?

180− expand n = round (255 * n)

181− convert = expand . gamma . shrink

182− in RGBColor (convert r) (convert g) (convert b)

183−

184−color240 :: Integral i => i -> i -> i -> Color

185−color240 r g b = Color240 (rgbColorToColor240 r g b)

186

122

187-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.

123-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.

188-- This function is lossy in the sense that we only internally support 240 colors but the

124-- This function is lossy in the sense that we only internally support 240 colors but the

189-- #RRGGBB format supports 16^3 colors.

125-- #RRGGBB format supports 16^3 colors.

190rgbColor :: Integral i => i -> i -> i -> Color

126rgbColor :: Integral i => i -> i -> i -> Color

191−rgbColor = color240

127+rgbColor r g b = Color240 (rgbColorToColor240 r g b)

src/Graphics/Vty/Config.hs+2−11

@@ -3,7 +3,6 @@

3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE LambdaCase, MultiWayIf #-}

7-- | Vty supports a configuration file format and associated 'Config'

6-- | Vty supports a configuration file format and associated 'Config'

8-- data type. The 'Config' can be provided to 'mkVty' to customize the

7-- data type. The 'Config' can be provided to 'mkVty' to customize the

9-- application's use of Vty.

8-- application's use of Vty.

@@ -55,7 +54,7 @@

55-- If a debug log is requested then vty will output the current input

54-- If a debug log is requested then vty will output the current input

56-- table to the log in the above format. A workflow for using this is

55-- table to the log in the above format. A workflow for using this is

57-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for

56-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for

58−-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.

57+-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.

59--

58--

60-- = Unicode Character Width Maps

59-- = Unicode Character Width Maps

61--

60--

@@ -123,7 +122,6 @@ import Data.Semigroup (Semigroup(..))

123import Data.Typeable (Typeable)

122import Data.Typeable (Typeable)

124

123

125import Graphics.Vty.Input.Events

124import Graphics.Vty.Input.Events

126−import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)

127

125

128import GHC.Generics

126import GHC.Generics

129

127

@@ -195,9 +193,6 @@ data Config =

195 -- configuration specifies one. If no custom table is loaded

193 -- configuration specifies one. If no custom table is loaded

196 -- (or if a load fails), the built-in character width table

194 -- (or if a load fails), the built-in character width table

197 -- will be used.

195 -- will be used.

198− , colorMode :: Maybe ColorMode

199− -- ^ The color mode used to know how many colors the terminal

200− -- supports.

201 }

196 }

202 deriving (Show, Eq)

197 deriving (Show, Eq)

203

198

@@ -219,7 +214,6 @@ instance Semigroup Config where

219 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

214 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

220 , allowCustomUnicodeWidthTables =

215 , allowCustomUnicodeWidthTables =

221 allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

216 allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

222− , colorMode = colorMode c1 <|> colorMode c0

223 }

217 }

224

218

225instance Monoid Config where

219instance Monoid Config where

@@ -235,7 +229,6 @@ instance Monoid Config where

235 , termName = Nothing

229 , termName = Nothing

236 , termWidthMaps = []

230 , termWidthMaps = []

237 , allowCustomUnicodeWidthTables = Nothing

231 , allowCustomUnicodeWidthTables = Nothing

238− , colorMode = Nothing

239 }

232 }

240#if !(MIN_VERSION_base(4,11,0))

233#if !(MIN_VERSION_base(4,11,0))

241 mappend = (<>)

234 mappend = (<>)

@@ -291,8 +284,7 @@ standardIOConfig = do

291 mb <- lookupEnv termVariable

284 mb <- lookupEnv termVariable

292 case mb of

285 case mb of

293 Nothing -> throwIO VtyMissingTermEnvVar

286 Nothing -> throwIO VtyMissingTermEnvVar

294− Just t -> do

287+ Just t ->

295− mcolorMode <- detectColorMode t

296 return defaultConfig

288 return defaultConfig

297 { vmin = Just 1

289 { vmin = Just 1

298 , mouseMode = Just False

290 , mouseMode = Just False

@@ -301,7 +293,6 @@ standardIOConfig = do

301 , inputFd = Just stdInput

293 , inputFd = Just stdInput

302 , outputFd = Just stdOutput

294 , outputFd = Just stdOutput

303 , termName = Just t

295 , termName = Just t

304− , colorMode = Just mcolorMode

305 }

296 }

306

297

307parseConfigFile :: FilePath -> IO Config

298parseConfigFile :: FilePath -> IO Config

src/Graphics/Vty/Image.hs+2−1

@@ -1,4 +1,5 @@

2+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE DisambiguateRecordFields #-}

4{-# LANGUAGE DisambiguateRecordFields #-}

4-- | A Vty program makes 'Picture's from 'Image's. This module provides

5-- | A Vty program makes 'Picture's from 'Image's. This module provides

@@ -137,7 +138,7 @@ char a c =

137 let displayWidth = safeWcwidth c

138 let displayWidth = safeWcwidth c

138 in HorizText a (TL.singleton c) displayWidth 1

139 in HorizText a (TL.singleton c) displayWidth 1

139

140

140−-- | Make an image from a string of characters laid out on a single

141+-- | Make an image from a string of characters layed out on a single

141-- row with the same display attribute. The string is assumed to be a

142-- row with the same display attribute. The string is assumed to be a

142-- sequence of ISO-10646 characters. The input string should be

143-- sequence of ISO-10646 characters. The input string should be

143-- sanitized of escape sequences (ASCII 27) and carriage returns;

144-- sanitized of escape sequences (ASCII 27) and carriage returns;

src/Graphics/Vty/Image/Internal.hs+2−2

@@ -228,7 +228,7 @@ instance Monoid Image where

228--

229-- The result image will have a width equal to the sum of the two images

230-- width. And the height will equal the largest height of the two

231−-- images. The area not defined in one image due to a height mismatch

231+-- images. The area not defined in one image due to a height missmatch

232-- will be filled with the background pattern.

233horizJoin :: Image -> Image -> Image

234horizJoin EmptyImage i = i

@@ -259,7 +259,7 @@ horizJoin _ _ = error "horizJoin applied to undefined values."

259--

260-- The result image will have a height equal to the sum of the heights

261-- of both images. The width will equal the largest width of the two

262−-- images. The area not defined in one image due to a width mismatch

262+-- images. The area not defined in one image due to a width missmatch

263-- will be filled with the background pattern.

264vertJoin :: Image -> Image -> Image

265vertJoin EmptyImage i = i

src/Graphics/Vty/Inline.hs+7−5

@@ -1,3 +1,5 @@

1+{-# LANGUAGE BangPatterns #-}

2+

1-- | The inline module provides a limited interface to changing the

3-- | The inline module provides a limited interface to changing the

2-- style of terminal output. The intention is for this interface to be

4-- style of terminal output. The intention is for this interface to be

3-- used inline with other output systems.

5-- used inline with other output systems.

@@ -56,13 +58,13 @@ data InlineState =

56-- | Set the background color to the provided 'Color'.

58-- | Set the background color to the provided 'Color'.

57backColor :: Color -> InlineM ()

59backColor :: Color -> InlineM ()

58backColor c = modify $ \s ->

60backColor c = modify $ \s ->

59− s { inlineAttr = inlineAttr s `withBackColor` c

61+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withBackColor` c)

60 }

62 }

61

63

62-- | Set the foreground color to the provided 'Color'.

64-- | Set the foreground color to the provided 'Color'.

63foreColor :: Color -> InlineM ()

65foreColor :: Color -> InlineM ()

64foreColor c = modify $ \s ->

66foreColor c = modify $ \s ->

65− s { inlineAttr = inlineAttr s `withForeColor` c

67+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withForeColor` c)

66 }

68 }

67

69

68-- | Attempt to change the 'Style' of the following text..

70-- | Attempt to change the 'Style' of the following text..

@@ -71,7 +73,7 @@ foreColor c = modify $ \s ->

71-- produced. The style can still be removed.

73-- produced. The style can still be removed.

72applyStyle :: Style -> InlineM ()

74applyStyle :: Style -> InlineM ()

73applyStyle st = modify $ \s ->

75applyStyle st = modify $ \s ->

74− s { inlineAttr = inlineAttr s `withStyle` st

76+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st)

75 }

77 }

76

78

77-- | Attempt to remove the specified 'Style' from the display of the

79-- | Attempt to remove the specified 'Style' from the display of the

@@ -83,8 +85,8 @@ removeStyle :: Style -> InlineM ()

83removeStyle sMask = modify $ \s ->

85removeStyle sMask = modify $ \s ->

84 s { inlineAttr =

86 s { inlineAttr =

85 let style' = case attrStyle (inlineAttr s) of

87 let style' = case attrStyle (inlineAttr s) of

86− Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

88+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

87− KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

89+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

88 SetTo st -> st .&. complement sMask

90 SetTo st -> st .&. complement sMask

89 in (inlineAttr s) { attrStyle = SetTo style' }

91 in (inlineAttr s) { attrStyle = SetTo style' }

90 }

92 }

src/Graphics/Vty/Input.hs+4−3

@@ -77,7 +77,7 @@

77-- The input encoding determines how UTF-8 encoded characters are

78-- recognized.

79--

80−-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is

80+-- * 7-bit mode: UTF-8 can be input unambiguiously. UTF-8 input is

81-- a superset of ASCII. UTF-8 does not overlap escaped control key

82-- sequences. However, the escape key must be differentiated from

83-- escaped control key sequences by the timing of the input bytes.

@@ -95,7 +95,7 @@

95--

96-- == Terminal Input is Broken

97--

98−-- Clearly terminal input has fundamental issues. There is no easy way

98+-- Clearly terminal input has fundemental issues. There is no easy way

99-- to reliably resolve these issues.

100--

101-- One resolution would be to ditch standard terminal interfaces

@@ -158,8 +158,9 @@ inputForConfig config@Config{ termName = Just termName

158 setAttrs

159 input <- initInput config activeInputMap

160 let pokeIO = Catch $ do

161+ let e = error "vty internal failure: this value should not propagate to users"

161 setAttrs

162 setAttrs

162− atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal

163+ atomically $ writeTChan (input^.eventChannel) (EvResize e e)

163 _ <- installHandler windowChange pokeIO Nothing

164 _ <- installHandler windowChange pokeIO Nothing

164 _ <- installHandler continueProcess pokeIO Nothing

165 _ <- installHandler continueProcess pokeIO Nothing

165

166

src/Graphics/Vty/Input/Classify.hs+29−53

@@ -1,11 +1,10 @@

1{-# OPTIONS_HADDOCK hide #-}

2−-- This makes a kind of trie. Has space efficiency issues with large

2+-- This makes a kind of tri. Has space efficiency issues with large

3-- input blocks. Likely building a parser and just applying that would

4-- be better.

5module Graphics.Vty.Input.Classify

6 ( classify

7 , KClass(..)

8− , ClassifierState(..)

9 )

8 )

10where

9where

11

10

@@ -17,39 +16,25 @@ import Graphics.Vty.Input.Classify.Types

17

16

18import Codec.Binary.UTF8.Generic (decode)

17import Codec.Binary.UTF8.Generic (decode)

19

18

20−import Control.Arrow (first)

19+import Data.List (inits)

21import qualified Data.Map as M( fromList, lookup )

20import qualified Data.Map as M( fromList, lookup )

22import Data.Maybe ( mapMaybe )

21import Data.Maybe ( mapMaybe )

23import qualified Data.Set as S( fromList, member )

22import qualified Data.Set as S( fromList, member )

24

23

24+import Data.Char

25import Data.Word

26

27−import qualified Data.ByteString as BS

28−import qualified Data.ByteString.Char8 as BS8

29−import Data.ByteString.Char8 (ByteString)

30−

31−-- | Whether the classifier is currently processing a chunked format.

32−-- Currently, only bracketed pastes use this.

33−data ClassifierState

34− = ClassifierStart

35− -- ^ Not processing a chunked format.

36− | ClassifierInChunk ByteString [ByteString]

37− -- ^ Currently processing a chunked format. The initial chunk is in the

38− -- first argument and a reversed remainder of the chunks is collected in

39− -- the second argument. At the end of the processing, the chunks are

40− -- reversed and concatenated with the final chunk.

41−

42−compile :: ClassifyMap -> ByteString -> KClass

27+compile :: ClassifyMap -> String -> KClass

43compile table = cl' where

28compile table = cl' where

44 -- take all prefixes and create a set of these

29 -- take all prefixes and create a set of these

45− prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table

30+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

46 maxValidInputLength = maximum (map (length . fst) table)

31 maxValidInputLength = maximum (map (length . fst) table)

47− eventForInput = M.fromList $ map (first BS8.pack) table

32+ eventForInput = M.fromList table

48− cl' inputBlock | BS8.null inputBlock = Prefix

33+ cl' [] = Prefix

49 cl' inputBlock = case M.lookup inputBlock eventForInput of

34 cl' inputBlock = case M.lookup inputBlock eventForInput of

50 -- if the inputBlock is exactly what is expected for an

35 -- if the inputBlock is exactly what is expected for an

51 -- event then consume the whole block and return the event

36 -- event then consume the whole block and return the event

52− Just e -> Valid e BS8.empty

37+ Just e -> Valid e []

53 Nothing -> case S.member inputBlock prefixSet of

38 Nothing -> case S.member inputBlock prefixSet of

54 True -> Prefix

39 True -> Prefix

55 -- look up progressively smaller tails of the input

40 -- look up progressively smaller tails of the input

@@ -60,49 +45,40 @@ compile table = cl' where

60 -- H: There will always be one match. The prefixSet

45 -- H: There will always be one match. The prefixSet

61 -- contains, by definition, all prefixes of an event.

46 -- contains, by definition, all prefixes of an event.

62 False ->

47 False ->

63− let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock

48+ let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock

64 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of

49 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of

65− (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)

50+ (s,e) : _ -> Valid e (drop (length s) inputBlock)

66 -- neither a prefix or a full event.

51 -- neither a prefix or a full event.

67 [] -> Invalid

52 [] -> Invalid

68

53

69−classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass

54+classify :: ClassifyMap -> String -> KClass

70−classify table = process

55+classify table =

71− where

72− standardClassifier = compile table

56+ let standardClassifier = compile table

73−

74− process ClassifierStart s =

75− case BS.uncons s of

57+ in \s -> case s of

76− _ | bracketedPasteStarted s ->

58+ _ | bracketedPasteStarted s ->

77− if bracketedPasteFinished s

78− then parseBracketedPaste s

79− else Chunk

80− _ | isMouseEvent s -> classifyMouseEvent s

81− _ | isFocusEvent s -> classifyFocusEvent s

82− Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs

83− _ -> standardClassifier s

84−

85− process (ClassifierInChunk p ps) s | bracketedPasteStarted p =

86 if bracketedPasteFinished s

59 if bracketedPasteFinished s

87− then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)

60+ then parseBracketedPaste s

88− else Chunk

61+ else Prefix

89− process ClassifierInChunk{} _ = Invalid

62+ _ | isMouseEvent s -> classifyMouseEvent s

63+ _ | isFocusEvent s -> classifyFocusEvent s

64+ c:cs | ord c >= 0xC2 -> classifyUtf8 c cs

65+ _ -> standardClassifier s

90

66

91−classifyUtf8 :: Word8 -> ByteString -> KClass

67+classifyUtf8 :: Char -> String -> KClass

92classifyUtf8 c cs =

68classifyUtf8 c cs =

93− let n = utf8Length c

69+ let n = utf8Length (ord c)

94− (codepoint,rest) = BS8.splitAt (n - 1) cs

70+ (codepoint,rest) = splitAt n (c:cs)

95

71

96 codepoint8 :: [Word8]

72 codepoint8 :: [Word8]

97− codepoint8 = c:BS.unpack codepoint

73+ codepoint8 = map (fromIntegral . ord) codepoint

98

74

99 in case decode codepoint8 of

75 in case decode codepoint8 of

100− _ | n < BS.length codepoint + 1 -> Prefix

76+ _ | n < length codepoint -> Prefix

101− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

77+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

102 -- something bad happened; just ignore and continue.

78 -- something bad happened; just ignore and continue.

103− Nothing -> Invalid

79+ Nothing -> Invalid

104

80

105−utf8Length :: Word8 -> Int

81+utf8Length :: (Num t, Ord a, Num a) => a -> t

106utf8Length c

82utf8Length c

107 | c < 0x80 = 1

83 | c < 0x80 = 1

108 | c < 0xE0 = 2

84 | c < 0xE0 = 2

src/Graphics/Vty/Input/Classify/Parse.hs+7−10

@@ -16,15 +16,12 @@ import Graphics.Vty.Input.Classify.Types

16import Control.Monad.Trans.Maybe

17import Control.Monad.State

18

19−import qualified Data.ByteString.Char8 as BS8

20−import Data.ByteString.Char8 (ByteString)

21−

22−type Parser a = MaybeT (State ByteString) a

19+type Parser a = MaybeT (State String) a

23

20

24-- | Run a parser on a given input string. If the parser fails, return

21-- | Run a parser on a given input string. If the parser fails, return

25-- 'Invalid'. Otherwise return the valid event ('Valid') and the

22-- 'Invalid'. Otherwise return the valid event ('Valid') and the

26-- remaining unparsed characters.

23-- remaining unparsed characters.

27−runParser :: ByteString -> Parser Event -> KClass

24+runParser :: String -> Parser Event -> KClass

28runParser s parser =

25runParser s parser =

29 case runState (runMaybeT parser) s of

26 case runState (runMaybeT parser) s of

30 (Nothing, _) -> Invalid

27 (Nothing, _) -> Invalid

@@ -39,9 +36,9 @@ failParse = fail "invalid parse"

39-- return '123' and consume those characters.

36-- return '123' and consume those characters.

40readInt :: Parser Int

37readInt :: Parser Int

41readInt = do

38readInt = do

42− s <- BS8.unpack <$> get

39+ s <- get

43 case (reads :: ReadS Int) s of

40 case (reads :: ReadS Int) s of

44− [(i, rest)] -> put (BS8.pack rest) >> return i

41+ [(i, rest)] -> put rest >> return i

45 _ -> failParse

42 _ -> failParse

46

43

47-- | Read a character from the input stream. If one cannot be read (e.g.

44-- | Read a character from the input stream. If one cannot be read (e.g.

@@ -49,9 +46,9 @@ readInt = do

49readChar :: Parser Char

46readChar :: Parser Char

50readChar = do

47readChar = do

51 s <- get

48 s <- get

52− case BS8.uncons s of

49+ case s of

53− Just (c,rest) -> put rest >> return c

50+ c:rest -> put rest >> return c

54− Nothing -> failParse

51+ _ -> failParse

55

52

56-- | Read a character from the input stream and fail parsing if it is

53-- | Read a character from the input stream and fail parsing if it is

57-- not the specified character.

54-- not the specified character.

src/Graphics/Vty/Input/Classify/Types.hs+1−7

@@ -1,6 +1,5 @@

1-- | This module exports the input classification type to avoid import

2-- cycles between other modules that need this.

3−{-# LANGUAGE StrictData #-}

4module Graphics.Vty.Input.Classify.Types

3module Graphics.Vty.Input.Classify.Types

5 ( KClass(..)

4 ( KClass(..)

6 )

5 )

@@ -8,10 +7,8 @@ where

8

7

9import Graphics.Vty.Input.Events

8import Graphics.Vty.Input.Events

10

9

11−import Data.ByteString.Char8 (ByteString)

12−

13data KClass

10data KClass

14− = Valid Event ByteString

11+ = Valid Event String

15 -- ^ A valid event was parsed. Any unused characters from the input

12 -- ^ A valid event was parsed. Any unused characters from the input

16 -- stream are also provided.

13 -- stream are also provided.

17 | Invalid

14 | Invalid

@@ -19,7 +16,4 @@ data KClass

19 | Prefix

16 | Prefix

20 -- ^ The input characters form the prefix of a valid event character

17 -- ^ The input characters form the prefix of a valid event character

21 -- sequence.

18 -- sequence.

22− | Chunk

23− -- ^ The input characters are either start of a bracketed paste chunk

24− -- or in the middle of a bracketed paste chunk.

25 deriving(Show, Eq)

19 deriving(Show, Eq)

src/Graphics/Vty/Input/Events.hs+6−24

@@ -1,8 +1,6 @@

1{-# Language DeriveGeneric #-}

2−{-# Language StrictData #-}

3module Graphics.Vty.Input.Events where

2module Graphics.Vty.Input.Events where

4

3

5−import Control.DeepSeq

6import Data.ByteString

4import Data.ByteString

7import GHC.Generics

5import GHC.Generics

8

6

@@ -16,29 +14,23 @@ import GHC.Generics

16--

14--

17-- * Actually, support for most of these but KEsc, KChar, KBS, and

15-- * Actually, support for most of these but KEsc, KChar, KBS, and

18-- KEnter vary by terminal and keyboard.

16-- KEnter vary by terminal and keyboard.

19−data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter

17+data Key = KEsc | KChar Char | KBS | KEnter

20 | KLeft | KRight | KUp | KDown

18 | KLeft | KRight | KUp | KDown

22− | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns

24 deriving (Eq,Show,Read,Ord,Generic)

22 deriving (Eq,Show,Read,Ord,Generic)

25

23

26−instance NFData Key

27−

28-- | Modifier keys. Key codes are interpreted such that users are more

24-- | Modifier keys. Key codes are interpreted such that users are more

29-- likely to have Meta than Alt; for instance on the PC Linux console,

25-- likely to have Meta than Alt; for instance on the PC Linux console,

30-- 'MMeta' will generally correspond to the physical Alt key.

26-- 'MMeta' will generally correspond to the physical Alt key.

31data Modifier = MShift | MCtrl | MMeta | MAlt

27data Modifier = MShift | MCtrl | MMeta | MAlt

32 deriving (Eq,Show,Read,Ord,Generic)

28 deriving (Eq,Show,Read,Ord,Generic)

33

29

34−instance NFData Modifier

35−

36-- | Mouse buttons.

30-- | Mouse buttons.

37data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown

31data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown

38 deriving (Eq,Show,Read,Ord,Generic)

32 deriving (Eq,Show,Read,Ord,Generic)

39

33

40−instance NFData Button

41−

42-- | Events.

34-- | Events.

43data Event

35data Event

44 = EvKey Key [Modifier]

36 = EvKey Key [Modifier]

@@ -52,8 +44,10 @@ data Event

52 -- without specifying which one; in that case, Nothing is provided.

44 -- without specifying which one; in that case, Nothing is provided.

53 -- Otherwise Just the button released is included in the event.

45 -- Otherwise Just the button released is included in the event.

54 | EvResize Int Int

46 | EvResize Int Int

55− -- The terminal window was resized and the size is provided in the

47+ -- ^ If read from 'eventChannel' this is the size at the time of the

56− -- integer fields (width, height).

48+ -- signal. If read from 'nextEvent' this is the size at the time the

49+ -- event was processed by Vty. Typically these are the same, but if

50+ -- somebody is resizing the terminal quickly they can be different.

57 | EvPaste ByteString

51 | EvPaste ByteString

58 -- ^ A paste event occurs when a bracketed paste input sequence is

52 -- ^ A paste event occurs when a bracketed paste input sequence is

59 -- received. For terminals that support bracketed paste mode, these

53 -- received. For terminals that support bracketed paste mode, these

@@ -68,16 +62,4 @@ data Event

68 -- ^ The terminal running the application gained input focus.

62 -- ^ The terminal running the application gained input focus.

69 deriving (Eq,Show,Read,Ord,Generic)

63 deriving (Eq,Show,Read,Ord,Generic)

70

64

71−instance NFData Event

72−

73type ClassifyMap = [(String,Event)]

65type ClassifyMap = [(String,Event)]

74−

75−-- | The type of internal events that drive the internal Vty event

76−-- dispatching to the application.

77−data InternalEvent =

78− ResumeAfterSignal

79− -- ^ Vty resumed operation after the process was interrupted with a

80− -- signal. In practice this translates into a screen redraw in the

81− -- input event loop.

82− | InputEvent Event

83− -- ^ An input event was received.

src/Graphics/Vty/Input/Focus.hs+13−15

@@ -11,32 +11,30 @@ import Graphics.Vty.Input.Classify.Types

11import Graphics.Vty.Input.Classify.Parse

12

13import Control.Monad.State

14−

14+import Data.List (isPrefixOf)

15−import qualified Data.ByteString.Char8 as BS8

16−import Data.ByteString.Char8 (ByteString)

17

15

18-- | These sequences set xterm-based terminals to send focus event

16-- | These sequences set xterm-based terminals to send focus event

19-- sequences.

17-- sequences.

20−requestFocusEvents :: ByteString

18+requestFocusEvents :: String

21−requestFocusEvents = BS8.pack "\ESC[?1004h"

19+requestFocusEvents = "\ESC[?1004h"

22

20

23-- | These sequences disable focus events.

21-- | These sequences disable focus events.

24−disableFocusEvents :: ByteString

22+disableFocusEvents :: String

25−disableFocusEvents = BS8.pack "\ESC[?1004l"

23+disableFocusEvents = "\ESC[?1004l"

26

24

27-- | Does the specified string begin with a focus event?

25-- | Does the specified string begin with a focus event?

28−isFocusEvent :: ByteString -> Bool

26+isFocusEvent :: String -> Bool

29−isFocusEvent s = BS8.isPrefixOf focusIn s ||

27+isFocusEvent s = isPrefixOf focusIn s ||

30− BS8.isPrefixOf focusOut s

28+ isPrefixOf focusOut s

31

29

32−focusIn :: ByteString

30+focusIn :: String

33−focusIn = BS8.pack "\ESC[I"

31+focusIn = "\ESC[I"

34

32

35−focusOut :: ByteString

33+focusOut :: String

36−focusOut = BS8.pack "\ESC[O"

34+focusOut = "\ESC[O"

37

35

38-- | Attempt to classify an input string as a focus event.

36-- | Attempt to classify an input string as a focus event.

39−classifyFocusEvent :: ByteString -> KClass

37+classifyFocusEvent :: String -> KClass

40classifyFocusEvent s = runParser s $ do

38classifyFocusEvent s = runParser s $ do

41 when (not $ isFocusEvent s) failParse

39 when (not $ isFocusEvent s) failParse

42

40

src/Graphics/Vty/Input/Loop.hs+22−41

@@ -1,9 +1,8 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TemplateHaskell #-}

6{-# OPTIONS_HADDOCK hide #-}

2{-# OPTIONS_HADDOCK hide #-}

3+{-# LANGUAGE NoMonomorphismRestriction #-}

4+{-# LANGUAGE TemplateHaskell #-}

5+{-# LANGUAGE CPP #-}

7-- | The input layer used to be a single function that correctly

6-- | The input layer used to be a single function that correctly

8-- accounted for the non-threaded runtime by emulating the terminal

7-- accounted for the non-threaded runtime by emulating the terminal

9-- VMIN adn VTIME handling. This has been removed and replace with a

8-- VMIN adn VTIME handling. This has been removed and replace with a

@@ -34,15 +33,12 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)

34import Control.Monad.State.Class (MonadState, modify)

33import Control.Monad.State.Class (MonadState, modify)

35import Control.Monad.Trans.Reader (ReaderT(..))

34import Control.Monad.Trans.Reader (ReaderT(..))

36

35

37−import qualified Data.ByteString.Char8 as BS8

36+import Data.Char

38−import qualified Data.ByteString as BS

39−import Data.ByteString.Char8 (ByteString)

40import Data.IORef

37import Data.IORef

41import Data.Word (Word8)

38import Data.Word (Word8)

42

39

43−import Foreign (allocaArray)

40+import Foreign ( allocaArray, peekArray, Ptr )

44import Foreign.C.Types (CInt(..))

41import Foreign.C.Types (CInt(..))

45−import Foreign.Ptr (Ptr, castPtr)

46

42

47import System.IO

43import System.IO

48import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))

44import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))

@@ -55,7 +51,7 @@ data Input = Input

55 { -- | Channel of events direct from input processing. Unlike

51 { -- | Channel of events direct from input processing. Unlike

56 -- 'nextEvent' this will not refresh the display if the next event

52 -- 'nextEvent' this will not refresh the display if the next event

57 -- is an 'EvResize'.

53 -- is an 'EvResize'.

58− _eventChannel :: TChan InternalEvent

54+ _eventChannel :: TChan Event

59 -- | Shuts down the input processing. As part of shutting down the

55 -- | Shuts down the input processing. As part of shutting down the

60 -- input, this should also restore the input state.

56 -- input, this should also restore the input state.

61 , shutdownInput :: IO ()

57 , shutdownInput :: IO ()

@@ -80,11 +76,10 @@ data InputBuffer = InputBuffer

80makeLenses ''InputBuffer

76makeLenses ''InputBuffer

81

77

82data InputState = InputState

78data InputState = InputState

83− { _unprocessedBytes :: ByteString

79+ { _unprocessedBytes :: String

84− , _classifierState :: ClassifierState

85 , _appliedConfig :: Config

80 , _appliedConfig :: Config

86 , _inputBuffer :: InputBuffer

81 , _inputBuffer :: InputBuffer

87− , _classifier :: ClassifierState -> ByteString -> KClass

82+ , _classifier :: String -> KClass

88 }

83 }

89

84

90makeLenses ''InputState

85makeLenses ''InputState

@@ -109,20 +104,20 @@ loopInputProcessor = do

109 dropInvalid

104 dropInvalid

110 loopInputProcessor

105 loopInputProcessor

111

106

112−addBytesToProcess :: ByteString -> InputM ()

107+addBytesToProcess :: String -> InputM ()

113addBytesToProcess block = unprocessedBytes <>= block

108addBytesToProcess block = unprocessedBytes <>= block

114

109

115emit :: Event -> InputM ()

110emit :: Event -> InputM ()

116emit event = do

111emit event = do

117 logMsg $ "parsed event: " ++ show event

112 logMsg $ "parsed event: " ++ show event

118− view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)

113+ view eventChannel >>= liftIO . atomically . flip writeTChan event

119

114

120-- The timing requirements are assured by the VMIN and VTIME set for the

115-- The timing requirements are assured by the VMIN and VTIME set for the

121-- device.

116-- device.

122--

117--

123-- Precondition: Under the threaded runtime. Only current use is from a

118-- Precondition: Under the threaded runtime. Only current use is from a

124-- forkOS thread. That case satisfies precondition.

119-- forkOS thread. That case satisfies precondition.

125−readFromDevice :: InputM ByteString

120+readFromDevice :: InputM String

126readFromDevice = do

121readFromDevice = do

127 newConfig <- view configRef >>= liftIO . readIORef

122 newConfig <- view configRef >>= liftIO . readIORef

128 oldConfig <- use appliedConfig

123 oldConfig <- use appliedConfig

@@ -142,10 +137,9 @@ readFromDevice = do

142 threadWaitRead fd

137 threadWaitRead fd

143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

138 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

144 if bytesRead > 0

139 if bytesRead > 0

145− then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)

140+ then map (chr . fromIntegral) <$> peekArray (fromIntegral bytesRead) bufferPtr

146− else return BS.empty

141+ else return []

147− when (not $ BS.null stringRep) $

148− logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)

142+ when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep

149 return stringRep

143 return stringRep

150

144

151applyConfig :: Fd -> Config -> IO ()

145applyConfig :: Fd -> Config -> IO ()

@@ -156,43 +150,30 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat

156parseEvent :: InputM Event

150parseEvent :: InputM Event

157parseEvent = do

151parseEvent = do

158 c <- use classifier

152 c <- use classifier

159− s <- use classifierState

160 b <- use unprocessedBytes

153 b <- use unprocessedBytes

161− case c s b of

154+ case c b of

162 Valid e remaining -> do

155 Valid e remaining -> do

163 logMsg $ "valid parse: " ++ show e

156 logMsg $ "valid parse: " ++ show e

164 logMsg $ "remaining: " ++ show remaining

157 logMsg $ "remaining: " ++ show remaining

165− classifierState .= ClassifierStart

166 unprocessedBytes .= remaining

158 unprocessedBytes .= remaining

167 return e

159 return e

168− _ -> mzero

160+ _ -> mzero

169

161

170dropInvalid :: InputM ()

162dropInvalid :: InputM ()

171dropInvalid = do

163dropInvalid = do

172 c <- use classifier

164 c <- use classifier

173− s <- use classifierState

174 b <- use unprocessedBytes

165 b <- use unprocessedBytes

175− case c s b of

176− Chunk -> do

177− classifierState .=

178− case s of

179− ClassifierStart -> ClassifierInChunk b []

180− ClassifierInChunk p bs -> ClassifierInChunk p (b:bs)

181− unprocessedBytes .= BS8.empty

182− Invalid -> do

166+ when (c b == Invalid) $ do

183− logMsg "dropping input bytes"

167+ logMsg "dropping input bytes"

184− classifierState .= ClassifierStart

185− unprocessedBytes .= BS8.empty

168+ unprocessedBytes .= []

186− _ -> return ()

187

169

188runInputProcessorLoop :: ClassifyMap -> Input -> IO ()

170runInputProcessorLoop :: ClassifyMap -> Input -> IO ()

189runInputProcessorLoop classifyTable input = do

171runInputProcessorLoop classifyTable input = do

190 let bufferSize = 1024

172 let bufferSize = 1024

191 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

173 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

192− s0 <- InputState BS8.empty ClassifierStart

193− <$> readIORef (_configRef input)

174+ s0 <- InputState [] <$> readIORef (_configRef input)

194− <*> pure (InputBuffer bufferPtr bufferSize)

175+ <*> pure (InputBuffer bufferPtr bufferSize)

195− <*> pure (classify classifyTable)

176+ <*> pure (classify classifyTable)

196 runReaderT (evalStateT loopInputProcessor s0) input

177 runReaderT (evalStateT loopInputProcessor s0) input

197

178

198-- | Construct two IO actions: one to configure the terminal for Vty and

179-- | Construct two IO actions: one to configure the terminal for Vty and

src/Graphics/Vty/Input/Mouse.hs+17−19

@@ -15,12 +15,10 @@ import Graphics.Vty.Input.Classify.Types

15import Graphics.Vty.Input.Classify.Parse

16

17import Control.Monad.State

18+import Data.List (isPrefixOf)

18import Data.Maybe (catMaybes)

19import Data.Maybe (catMaybes)

19import Data.Bits ((.&.))

20import Data.Bits ((.&.))

20

21

21−import qualified Data.ByteString.Char8 as BS8

22−import Data.ByteString.Char8 (ByteString)

23−

24-- A mouse event in SGR extended mode is

22-- A mouse event in SGR extended mode is

25--

23--

26-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')

24-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')

@@ -34,28 +32,28 @@ import Data.ByteString.Char8 (ByteString)

34

32

35-- | These sequences set xterm-based terminals to send mouse event

33-- | These sequences set xterm-based terminals to send mouse event

36-- sequences.

34-- sequences.

37−requestMouseEvents :: ByteString

35+requestMouseEvents :: String

38−requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"

36+requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h"

39

37

40-- | These sequences disable mouse events.

38-- | These sequences disable mouse events.

41−disableMouseEvents :: ByteString

39+disableMouseEvents :: String

42−disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"

40+disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l"

43

41

44-- | Does the specified string begin with a mouse event?

42-- | Does the specified string begin with a mouse event?

45−isMouseEvent :: ByteString -> Bool

43+isMouseEvent :: String -> Bool

46isMouseEvent s = isSGREvent s || isNormalEvent s

44isMouseEvent s = isSGREvent s || isNormalEvent s

47

45

48−isSGREvent :: ByteString -> Bool

46+isSGREvent :: String -> Bool

49−isSGREvent = BS8.isPrefixOf sgrPrefix

47+isSGREvent = isPrefixOf sgrPrefix

50

48

51−sgrPrefix :: ByteString

49+sgrPrefix :: String

52−sgrPrefix = BS8.pack "\ESC[M"

50+sgrPrefix = "\ESC[M"

53

51

54−isNormalEvent :: ByteString -> Bool

52+isNormalEvent :: String -> Bool

55−isNormalEvent = BS8.isPrefixOf normalPrefix

53+isNormalEvent = isPrefixOf normalPrefix

56

54

57−normalPrefix :: ByteString

55+normalPrefix :: String

58−normalPrefix = BS8.pack "\ESC[<"

56+normalPrefix = "\ESC[<"

59

57

60-- Modifier bits:

58-- Modifier bits:

61shiftBit :: Int

59shiftBit :: Int

@@ -89,8 +87,8 @@ scrollDown = 65

89hasBitSet :: Int -> Int -> Bool

87hasBitSet :: Int -> Int -> Bool

90hasBitSet val bit = val .&. bit > 0

88hasBitSet val bit = val .&. bit > 0

91

89

92−-- | Attempt to classify an input string as a mouse event.

90+-- | Attempt to lassify an input string as a mouse event.

93−classifyMouseEvent :: ByteString -> KClass

91+classifyMouseEvent :: String -> KClass

94classifyMouseEvent s = runParser s $ do

92classifyMouseEvent s = runParser s $ do

95 when (not $ isMouseEvent s) failParse

93 when (not $ isMouseEvent s) failParse

96

94

@@ -102,7 +100,7 @@ classifyMouseEvent s = runParser s $ do

102 'M' -> classifyNormalMouseEvent

100 'M' -> classifyNormalMouseEvent

103 _ -> failParse

101 _ -> failParse

104

102

105−-- Given a modifier/button value, determine which button was indicated

103+-- Given a modifer/button value, determine which button was indicated

106getSGRButton :: Int -> Parser Button

104getSGRButton :: Int -> Parser Button

107getSGRButton mods =

105getSGRButton mods =

108 let buttonMap = [ (leftButton, BLeft)

106 let buttonMap = [ (leftButton, BLeft)

src/Graphics/Vty/Input/Paste.hs+24−16

@@ -9,33 +9,41 @@ module Graphics.Vty.Input.Paste

9where

10

11import qualified Data.ByteString.Char8 as BS8

12−import Data.ByteString.Char8 (ByteString)

13

12

14import Graphics.Vty.Input.Events

13import Graphics.Vty.Input.Events

15import Graphics.Vty.Input.Classify.Types

14import Graphics.Vty.Input.Classify.Types

16

15

17−bracketedPasteStart :: ByteString

16+import Data.List (isPrefixOf, isInfixOf)

18−bracketedPasteStart = BS8.pack "\ESC[200~"

19

17

18+bracketedPasteStart :: String

19+bracketedPasteStart = "\ESC[200~"

20+

20−bracketedPasteEnd :: ByteString

21+bracketedPasteEnd :: String

21−bracketedPasteEnd = BS8.pack "\ESC[201~"

22+bracketedPasteEnd = "\ESC[201~"

22

23

23-- | Does the input start a bracketed paste?

24-- | Does the input start a bracketed paste?

24−bracketedPasteStarted :: ByteString -> Bool

25+bracketedPasteStarted :: String -> Bool

25−bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart

26+bracketedPasteStarted = isPrefixOf bracketedPasteStart

26

27

27-- | Does the input contain a complete bracketed paste?

28-- | Does the input contain a complete bracketed paste?

28−bracketedPasteFinished :: ByteString -> Bool

29+bracketedPasteFinished :: String -> Bool

29−bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd

30+bracketedPasteFinished = isInfixOf bracketedPasteEnd

30

31

31-- | Parse a bracketed paste. This should only be called on a string if

32-- | Parse a bracketed paste. This should only be called on a string if

32-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

33-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

33-- 'True'.

34-- 'True'.

34−parseBracketedPaste :: ByteString -> KClass

35+parseBracketedPaste :: String -> KClass

35parseBracketedPaste s =

36parseBracketedPaste s =

37+ let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd

38+ rest' = if bracketedPasteEnd `isPrefixOf` rest

39+ then drop (length bracketedPasteEnd) rest

40+ else rest

36− Valid (EvPaste p) (BS8.drop endLen rest')

41+ in Valid (EvPaste $ BS8.pack p) rest'

37− where

42+

38− startLen = BS8.length bracketedPasteStart

43+takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])

39− endLen = BS8.length bracketedPasteEnd

44+takeUntil [] _ = ([], [])

40− (_, rest ) = BS8.breakSubstring bracketedPasteStart s

45+takeUntil cs sub

41− (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest

46+ | length cs < length sub = (cs, [])

47+ | take (length sub) cs == sub = ([], drop (length sub) cs)

48+ | otherwise = let (pre, suf) = takeUntil (tail cs) sub

49+ in (head cs:pre, suf)

src/Graphics/Vty/Input/Terminfo.hs+1−1

@@ -91,7 +91,7 @@ specialSupportKeys =

91 -- special support for ESC

92 , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

93 -- Special support for backspace

94− , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS [])

94+ , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])

95 -- Special support for Enter

96 , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])

97 -- explicit support for tab

src/Graphics/Vty/Output.hs+5−6

@@ -1,4 +1,4 @@

1−{-# LANGUAGE RecordWildCards, CPP #-}

1+{-# LANGUAGE RecordWildCards, NamedFieldPuns, CPP #-}

2-- | This module provides functions for accessing the current terminal

3-- or a specific terminal device.

4--

@@ -58,12 +58,11 @@ import Data.Monoid ((<>))

58-- * If TERM contains "xterm" or "screen", use XTermColor.

59-- * otherwise use the TerminfoBased driver.

60outputForConfig :: Config -> IO Output

61−outputForConfig Config{ outputFd = Just fd, termName = Just termName

61+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do

62− , colorMode = Just colorMode, .. } = do

63 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName

62 t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName

64− then XTermColor.reserveTerminal termName fd colorMode

63+ then XTermColor.reserveTerminal termName fd

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

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

66− else TerminfoBased.reserveTerminal termName fd colorMode

65+ else TerminfoBased.reserveTerminal termName fd

67

66

68 case mouseMode of

67 case mouseMode of

69 Just s -> setMode t Mouse s

68 Just s -> setMode t Mouse s

@@ -78,7 +77,7 @@ outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig

78

77

79-- | Sets the cursor position to the given output column and row.

78-- | Sets the cursor position to the given output column and row.

80--

79--

81−-- This is not necessarily the same as the character position with the

80+-- This is not necessarially the same as the character position with the

82-- same coordinates. Characters can be a variable number of columns in

81-- same coordinates. Characters can be a variable number of columns in

83-- width.

82-- width.

84--

83--

src/Graphics/Vty/Output/Interface.hs+18−23

@@ -1,9 +1,9 @@

1-- Copyright Corey O'Connor

2+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7-- | This module provides an abstract interface for performing terminal

8-- output. The only user-facing part of this API is 'Output'.

9module Graphics.Vty.Output.Interface

@@ -79,6 +79,9 @@ data Output = Output

79 , displayBounds :: IO DisplayRegion

80 -- | Output the bytestring to the terminal device.

81 , outputByteBuffer :: BS.ByteString -> IO ()

82+ -- | Specifies the maximum number of colors supported by the

83+ -- context.

84+ , contextColorCount :: Int

82 -- | Specifies whether the cursor can be shown / hidden.

85 -- | Specifies whether the cursor can be shown / hidden.

83 , supportsCursorVisibility :: Bool

86 , supportsCursorVisibility :: Bool

84 -- | Indicates support for terminal modes for this output device.

87 -- | Indicates support for terminal modes for this output device.

@@ -114,8 +117,6 @@ data Output = Output

114 -- be a reliable indicator of whether the feature will work as

117 -- be a reliable indicator of whether the feature will work as

115 -- desired.

118 -- desired.

116 , supportsStrikethrough :: IO Bool

119 , supportsStrikethrough :: IO Bool

117− -- | Returns how many colors the terminal supports.

118− , outputColorMode :: ColorMode

119 }

120 }

120

121

121displayContext :: Output -> DisplayRegion -> IO DisplayContext

122displayContext :: Output -> DisplayRegion -> IO DisplayContext

@@ -309,23 +310,17 @@ limitAttrForDisplay t attr

309 where

310 where

310 clampColor Default = Default

311 clampColor Default = Default

311 clampColor KeepCurrent = KeepCurrent

312 clampColor KeepCurrent = KeepCurrent

312− clampColor (SetTo c) = clampColor' (outputColorMode t) c

313+ clampColor (SetTo c) = clampColor' c

313−

314− clampColor' NoColor _ = Default

314+ clampColor' (ISOColor v)

315−

315+ | contextColorCount t < 8 = Default

316− clampColor' ColorMode8 (ISOColor v)

317− | v >= 8 = SetTo $ ISOColor (v - 8)

316+ | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

318− | otherwise = SetTo $ ISOColor v

317+ | otherwise = SetTo $ ISOColor v

319− clampColor' ColorMode8 _ = Default

318+ clampColor' (Color240 v)

320−

319+ -- Should we choose closest ISO color?

321− clampColor' ColorMode16 c@(ISOColor _) = SetTo c

320+ | contextColorCount t < 8 = Default

322− clampColor' ColorMode16 _ = Default

321+ | contextColorCount t < 16 = Default

323−

322+ | contextColorCount t <= 256 = SetTo $ Color240 v

324− clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c

325− clampColor' (ColorMode240 colorCount) c@(Color240 n)

326− | n <= colorCount = SetTo c

327− | otherwise = Default

323+ | otherwise

328− clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =

324+ = let p :: Double = fromIntegral v / 240.0

329− clampColor' colorMode (color240 r g b)

325+ v' = floor $ p * (fromIntegral $ contextColorCount t)

330−

326+ in SetTo $ Color240 v'

331− clampColor' FullColor c = SetTo c

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

@@ -11,7 +11,6 @@ module Graphics.Vty.Output.Mock

11where

12

13import Graphics.Vty.Image (DisplayRegion)

14−import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))

15import Graphics.Vty.Output.Interface

14import Graphics.Vty.Output.Interface

16

15

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

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

@@ -31,7 +30,7 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)

31-- without considering terminal specific issues.

30-- without considering terminal specific issues.

32--

31--

33-- The mock implementation is useful in manually determining if the

32-- The mock implementation is useful in manually determining if the

34−-- sequence of terminal operations matches the expected sequence. The

33+-- sequence of terminal operations matche the expected sequence. The

35-- requirement of the produced representation is simplicity in parsing

34-- requirement of the produced representation is simplicity in parsing

36-- the text representation and determining how the picture was mapped to

35-- the text representation and determining how the picture was mapped to

37-- terminal operations.

36-- terminal operations.

@@ -56,12 +55,12 @@ mockTerminal r = liftIO $ do

56 , outputByteBuffer = \bytes -> do

55 , outputByteBuffer = \bytes -> do

57 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

56 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

58 writeIORef outRef $ UTF8.fromRep bytes

57 writeIORef outRef $ UTF8.fromRep bytes

58+ , contextColorCount = 16

59 , supportsCursorVisibility = True

60 , supportsMode = const False

61 , setMode = const $ const $ return ()

62 , getModeStatus = const $ return False

63 , assumedStateRef = newAssumedStateRef

64− , outputColorMode = ColorMode16

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

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

66 { contextRegion = rActual

65 { contextRegion = rActual

67 , contextDevice = tActual

66 , contextDevice = tActual

src/Graphics/Vty/Output/TerminfoBased.hs+38−68

@@ -1,3 +1,4 @@

1+{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

@@ -14,7 +15,7 @@ module Graphics.Vty.Output.TerminfoBased

14where

15where

15

16

16import Control.Monad (when)

17import Control.Monad (when)

17−import Data.Bits (shiftL, (.&.))

18+import Data.Bits (shiftL)

18import qualified Data.ByteString as BS

19import qualified Data.ByteString as BS

19import Data.ByteString.Internal (toForeignPtr)

20import Data.ByteString.Internal (toForeignPtr)

20import Data.Terminfo.Parse

21import Data.Terminfo.Parse

@@ -25,8 +26,9 @@ import Graphics.Vty.Image (DisplayRegion)

25import Graphics.Vty.DisplayAttributes

26import Graphics.Vty.DisplayAttributes

26import Graphics.Vty.Output.Interface

27import Graphics.Vty.Output.Interface

27

28

28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)

29+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)

29

30

31+import Data.Bits ((.&.))

30import Data.IORef

32import Data.IORef

31import Data.Maybe (isJust, isNothing, fromJust)

33import Data.Maybe (isJust, isNothing, fromJust)

32import Data.Word

34import Data.Word

@@ -49,6 +51,7 @@ data TerminfoCaps = TerminfoCaps

49 , cup :: CapExpression

51 , cup :: CapExpression

50 , cnorm :: Maybe CapExpression

52 , cnorm :: Maybe CapExpression

51 , civis :: Maybe CapExpression

53 , civis :: Maybe CapExpression

54+ , supportsNoColors :: Bool

52 , useAltColorMap :: Bool

55 , useAltColorMap :: Bool

53 , setForeColor :: CapExpression

56 , setForeColor :: CapExpression

54 , setBackColor :: CapExpression

57 , setBackColor :: CapExpression

@@ -103,28 +106,28 @@ sendCapToTerminal t cap capParams = do

103--

106--

104-- * Providing independent string capabilities for all display

107-- * Providing independent string capabilities for all display

105-- attributes.

108-- attributes.

106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output

109+reserveTerminal :: String -> Fd -> IO Output

107−reserveTerminal termName outFd colorMode = do

110+reserveTerminal termName outFd = do

108 ti <- Terminfo.setupTerm termName

111 ti <- Terminfo.setupTerm termName

109 -- assumes set foreground always implies set background exists.

112 -- assumes set foreground always implies set background exists.

110 -- if set foreground is not set then all color changing style

113 -- if set foreground is not set then all color changing style

111 -- attributes are filtered.

114 -- attributes are filtered.

112 msetaf <- probeCap ti "setaf"

115 msetaf <- probeCap ti "setaf"

113 msetf <- probeCap ti "setf"

116 msetf <- probeCap ti "setf"

114− let (useAlt, setForeCap)

117+ let (noColors, useAlt, setForeCap)

115 = case msetaf of

118 = case msetaf of

116− Just setaf -> (False, setaf)

119+ Just setaf -> (False, False, setaf)

117 Nothing -> case msetf of

120 Nothing -> case msetf of

118− Just setf -> (True, setf)

121+ Just setf -> (False, True, setf)

119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)

122+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)

120 msetab <- probeCap ti "setab"

123 msetab <- probeCap ti "setab"

121 msetb <- probeCap ti "setb"

124 msetb <- probeCap ti "setb"

122− let setBackCap

125+ let set_back_cap

123 = case msetab of

126 = case msetab of

124− Just setab -> setab

125 Nothing -> case msetb of

127 Nothing -> case msetb of

126 Just setb -> setb

128 Just setb -> setb

127 Nothing -> error $ "no back color support for terminal " ++ termName

129 Nothing -> error $ "no back color support for terminal " ++ termName

130+ Just setab -> setab

128

131

129 hyperlinkModeStatus <- newIORef False

132 hyperlinkModeStatus <- newIORef False

130 newAssumedStateRef <- newIORef initialAssumedState

133 newAssumedStateRef <- newIORef initialAssumedState

@@ -150,9 +153,10 @@ reserveTerminal termName outFd colorMode = do

150 <*> requireCap ti "cup"

153 <*> requireCap ti "cup"

151 <*> probeCap ti "cnorm"

154 <*> probeCap ti "cnorm"

152 <*> probeCap ti "civis"

155 <*> probeCap ti "civis"

156+ <*> pure noColors

153 <*> pure useAlt

157 <*> pure useAlt

154 <*> pure setForeCap

158 <*> pure setForeCap

155− <*> pure setBackCap

159+ <*> pure set_back_cap

156 <*> requireCap ti "sgr0"

160 <*> requireCap ti "sgr0"

157 <*> requireCap ti "clear"

161 <*> requireCap ti "clear"

158 <*> requireCap ti "el"

162 <*> requireCap ti "el"

@@ -192,12 +196,17 @@ reserveTerminal termName outFd colorMode = do

192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "

196 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "

193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen

197 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen

194 ++ " Please report this bug to vty project."

198 ++ " Please report this bug to vty project."

199+ , contextColorCount

200+ = case supportsNoColors terminfoCaps of

201+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

202+ Nothing -> 8

203+ Just v -> toEnum v

204+ True -> 1

195 , supportsCursorVisibility = isJust $ civis terminfoCaps

205 , supportsCursorVisibility = isJust $ civis terminfoCaps

196 , supportsMode = terminfoModeSupported

206 , supportsMode = terminfoModeSupported

197 , setMode = terminfoSetMode

207 , setMode = terminfoSetMode

198 , getModeStatus = terminfoModeStatus

208 , getModeStatus = terminfoModeStatus

199 , assumedStateRef = newAssumedStateRef

209 , assumedStateRef = newAssumedStateRef

200− , outputColorMode = colorMode

201 -- I think fix would help assure tActual is the only

210 -- I think fix would help assure tActual is the only

202 -- reference. I was having issues tho.

211 -- reference. I was having issues tho.

203 , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

212 , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

@@ -295,7 +304,7 @@ writeURLEscapes NoLinkChange =

295-- | Portably setting the display attributes is a giant pain in the ass.

304-- | Portably setting the display attributes is a giant pain in the ass.

296--

305--

297-- If the terminal supports the sgr capability (which sets the on/off

306-- If the terminal supports the sgr capability (which sets the on/off

298−-- state of each style directly; and, for no good reason, resets the

307+-- state of each style directly ; and, for no good reason, resets the

299-- colors to the default) this procedure is used:

308-- colors to the default) this procedure is used:

300--

309--

301-- 0. set the style attributes. This resets the fore and back color.

310-- 0. set the style attributes. This resets the fore and back color.

@@ -334,9 +343,9 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

334 -- The only way to reset either color, portably, to the default

343 -- The only way to reset either color, portably, to the default

335 -- is to use either the set state capability or the set default

344 -- is to use either the set state capability or the set default

336 -- capability.

345 -- capability.

337− True -> do

346+ True -> do

338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

347 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

339− (fixedStyle attr)

348+ (fixedStyle attr )

340 (styleToApplySeq $ fixedStyle attr) of

349 (styleToApplySeq $ fixedStyle attr) of

341 -- only way to reset a color to the defaults

350 -- only way to reset a color to the defaults

342 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

351 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

@@ -346,7 +355,8 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

346 setColors

355 setColors

347 -- implicitly resets the colors to the defaults

356 -- implicitly resets the colors to the defaults

348 SetState state -> writeCapExpr (fromJust $ setAttrStates

357 SetState state -> writeCapExpr (fromJust $ setAttrStates

349− $ displayAttrCaps terminfoCaps

358+ $ displayAttrCaps

359+ $ terminfoCaps

350 )

360 )

351 (sgrArgsForState state)

361 (sgrArgsForState state)

352 `mappend` setItalics

362 `mappend` setItalics

@@ -369,9 +379,9 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

369 -- applied states.

379 -- applied states.

370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps

380 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps

371 `mappend`

381 `mappend`

372− writeColorDiff Foreground (foreColorDiff diffs)

382+ writeColorDiff setForeColor (foreColorDiff diffs)

373 `mappend`

383 `mappend`

374− writeColorDiff Background (backColorDiff diffs)

384+ writeColorDiff setBackColor (backColorDiff diffs)

375 -- implicitly resets the colors to the defaults

385 -- implicitly resets the colors to the defaults

376 SetState state -> writeCapExpr (fromJust $ setAttrStates

386 SetState state -> writeCapExpr (fromJust $ setAttrStates

377 $ displayAttrCaps terminfoCaps

387 $ displayAttrCaps terminfoCaps

@@ -403,65 +413,29 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

403 | otherwise = mempty

413 | otherwise = mempty

404 setColors =

414 setColors =

405 (case fixedForeColor attr of

415 (case fixedForeColor attr of

406− Just c -> writeColor Foreground c

416+ Just c -> writeCapExpr (setForeColor terminfoCaps)

417+ [toEnum $ colorMap c]

407 Nothing -> mempty)

418 Nothing -> mempty)

408 `mappend`

419 `mappend`

409 (case fixedBackColor attr of

420 (case fixedBackColor attr of

410− Just c -> writeColor Background c

421+ Just c -> writeCapExpr (setBackColor terminfoCaps)

422+ [toEnum $ colorMap c]

411 Nothing -> mempty)

423 Nothing -> mempty)

412− writeColorDiff _side NoColorChange

424+ writeColorDiff _f NoColorChange

413 = mempty

425 = mempty

414− writeColorDiff _side ColorToDefault

426+ writeColorDiff _f ColorToDefault

415 = error "ColorToDefault is not a possible case for applyColorDiffs"

427 = error "ColorToDefault is not a possible case for applyColorDiffs"

416− writeColorDiff side (SetColor c)

428+ writeColorDiff f (SetColor c)

417− = writeColor side c

418−

419− writeColor side (RGBColor r g b) =

420− case outputColorMode (contextDevice dc) of

421− FullColor ->

422− hardcodeColor side (r, g, b)

423− _ ->

424− error "clampColor should remove rgb colors in standard mode"

425− writeColor side c =

426− writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]

429+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]

427−

428−-- a color can either be in the foreground or the background

429−data ColorSide = Foreground | Background

430−

431−-- get the capability for drawing a color on a specific side

432−setSideColor :: ColorSide -> TerminfoCaps -> CapExpression

433−setSideColor Foreground = setForeColor

434−setSideColor Background = setBackColor

435−

436−hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write

437−hardcodeColor side (r, g, b) =

438− -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"

439− mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter

440− , writeColor r, delimiter, writeColor g, delimiter, writeColor b

441− , writeChar 'm']

442− where

443− writeChar = writeWord8 . fromIntegral . fromEnum

444− writeStr = mconcat . map writeChar

445− writeColor = writeStr . show

446− delimiter = writeChar ';'

447− -- 38/48 are used to set whether we should write to the

448− -- foreground/background. I really don't want to know why.

449− sideCode = case side of

450− Foreground -> writeStr "38"

451− Background -> writeStr "48"

452

430

453-- | The color table used by a terminal is a 16 color set followed by a

431-- | The color table used by a terminal is a 16 color set followed by a

454-- 240 color set that might not be supported by the terminal.

432-- 240 color set that might not be supported by the terminal.

455--

433--

456−-- This takes a Color which clearly identifies which palette to use and

434+-- This takes a Color which clearly identifies which pallete to use and

457−-- computes the index into the full 256 color palette.

435+-- computes the index into the full 256 color pallete.

458ansiColorIndex :: Color -> Int

436ansiColorIndex :: Color -> Int

459ansiColorIndex (ISOColor v) = fromEnum v

437ansiColorIndex (ISOColor v) = fromEnum v

460ansiColorIndex (Color240 v) = 16 + fromEnum v

438ansiColorIndex (Color240 v) = 16 + fromEnum v

461−ansiColorIndex (RGBColor _ _ _) =

462− error $ unlines [ "Attempted to create color index from rgb color."

463− , "This is currently unsupported, and shouldn't ever happen"

464− ]

465

439

466-- | For terminals without setaf/setab

440-- | For terminals without setaf/setab

467--

441--

@@ -478,10 +452,6 @@ altColorIndex (ISOColor 6) = 3

478altColorIndex (ISOColor 7) = 7

452altColorIndex (ISOColor 7) = 7

479altColorIndex (ISOColor v) = fromEnum v

453altColorIndex (ISOColor v) = fromEnum v

480altColorIndex (Color240 v) = 16 + fromEnum v

454altColorIndex (Color240 v) = 16 + fromEnum v

481−altColorIndex (RGBColor _ _ _) =

482− error $ unlines [ "Attempted to create color index from rgb color."

483− , "This is currently unsupported, and shouldn't ever happen"

484− ]

485

455

486{- | The sequence of terminfo caps to apply a given style are determined

456{- | The sequence of terminfo caps to apply a given style are determined

487 - according to these rules.

457 - according to these rules.

src/Graphics/Vty/Output/XTermColor.hs+12−23

@@ -10,23 +10,18 @@ where

10import Graphics.Vty.Output.Interface

11import Graphics.Vty.Input.Mouse

12import Graphics.Vty.Input.Focus

13−import Graphics.Vty.Attributes.Color (ColorMode)

14import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

13import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

15

14

16import Blaze.ByteString.Builder (writeToByteString)

15import Blaze.ByteString.Builder (writeToByteString)

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

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

18

17

19−import qualified Data.ByteString.Char8 as BS8

20−import Data.ByteString.Char8 (ByteString)

21−import Foreign.Ptr (castPtr)

22−

23import Control.Monad (void, when)

18import Control.Monad (void, when)

24import Control.Monad.Trans

19import Control.Monad.Trans

25import Data.Char (toLower)

20import Data.Char (toLower)

26import Data.IORef

21import Data.IORef

27

22

28−import System.Posix.IO (fdWriteBuf)

23+import System.Posix.IO (fdWrite)

29−import System.Posix.Types (ByteCount, Fd)

24+import System.Posix.Types (Fd)

30import System.Posix.Env (getEnv)

25import System.Posix.Env (getEnv)

31

26

32import Data.List (isInfixOf)

27import Data.List (isInfixOf)

@@ -36,15 +31,9 @@ import Data.Maybe (catMaybes)

36import Data.Monoid ((<>))

31import Data.Monoid ((<>))

37#endif

32#endif

38

33

39−-- | Write a 'ByteString' to an 'Fd'.

40−fdWrite :: Fd -> ByteString -> IO ByteCount

41−fdWrite fd s =

42− BS8.useAsCStringLen s $ \(buf,len) -> do

43− fdWriteBuf fd (castPtr buf) (fromIntegral len)

44−

45-- | Construct an Xterm output driver. Initialize the display to UTF-8.

34-- | Construct an Xterm output driver. Initialize the display to UTF-8.

46−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output

35+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

47−reserveTerminal variant outFd colorMode = liftIO $ do

36+reserveTerminal variant outFd = liftIO $ do

48 let flushedPut = void . fdWrite outFd

37 let flushedPut = void . fdWrite outFd

49 -- If the terminal variant is xterm-color use xterm instead since,

38 -- If the terminal variant is xterm-color use xterm instead since,

50 -- more often than not, xterm-color is broken.

39 -- more often than not, xterm-color is broken.

@@ -52,7 +41,7 @@ reserveTerminal variant outFd colorMode = liftIO $ do

52

41

53 utf8a <- utf8Active

42 utf8a <- utf8Active

54 when (not utf8a) $ flushedPut setUtf8CharSet

43 when (not utf8a) $ flushedPut setUtf8CharSet

55− t <- TerminfoBased.reserveTerminal variant' outFd colorMode

44+ t <- TerminfoBased.reserveTerminal variant' outFd

56

45

57 mouseModeStatus <- newIORef False

46 mouseModeStatus <- newIORef False

58 focusModeStatus <- newIORef False

47 focusModeStatus <- newIORef False

@@ -111,19 +100,19 @@ utf8Active = do

111

100

112-- | Enable bracketed paste mode:

101-- | Enable bracketed paste mode:

113-- http://cirw.in/blog/bracketed-paste

102-- http://cirw.in/blog/bracketed-paste

114−enableBracketedPastes :: ByteString

103+enableBracketedPastes :: String

115−enableBracketedPastes = BS8.pack "\ESC[?2004h"

104+enableBracketedPastes = "\ESC[?2004h"

116

105

117-- | Disable bracketed paste mode:

106-- | Disable bracketed paste mode:

118−disableBracketedPastes :: ByteString

107+disableBracketedPastes :: String

119−disableBracketedPastes = BS8.pack "\ESC[?2004l"

108+disableBracketedPastes = "\ESC[?2004l"

120

109

121-- | These sequences set xterm based terminals to UTF-8 output.

110-- | These sequences set xterm based terminals to UTF-8 output.

122--

111--

123-- There is no known terminfo capability equivalent to this.

112-- There is no known terminfo capability equivalent to this.

124−setUtf8CharSet, setDefaultCharSet :: ByteString

113+setUtf8CharSet, setDefaultCharSet :: String

125−setUtf8CharSet = BS8.pack "\ESC%G"

114+setUtf8CharSet = "\ESC%G"

126−setDefaultCharSet = BS8.pack "\ESC%@"

115+setDefaultCharSet = "\ESC%@"

127

116

128xtermInlineHack :: Output -> IO ()

117xtermInlineHack :: Output -> IO ()

129xtermInlineHack t = do

118xtermInlineHack t = do

src/Graphics/Vty/Picture.hs+4−3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

1-- A 'Picture' is a background paired with a set of 'Image' layers. The

2-- A 'Picture' is a background paired with a set of 'Image' layers. The

2-- 'Picture' data structure is representative of the final terminal

3-- 'Picture' data structure is representative of the final terminal

3-- view.

4-- view.

@@ -79,6 +80,9 @@ picForLayers is = Picture

79data Cursor =

80data Cursor =

80 -- | Hide the cursor

81 -- | Hide the cursor

81 NoCursor

82 NoCursor

83+ -- | Show the cursor at the given logical column accounting for

84+ -- character width in the presence of multi-column characters.

85+ | PositionOnly !Bool !Int !Int

82 -- | Set the terminal's cursor position without displaying a cursor

86 -- | Set the terminal's cursor position without displaying a cursor

83 -- character. This is important for accessibility with screen

87 -- character. This is important for accessibility with screen

84 -- readers where a cursor position needs to be reported but we may

88 -- readers where a cursor position needs to be reported but we may

@@ -86,9 +90,6 @@ data Cursor =

86 -- reasons. The boolean argument indicates whether the positioning

90 -- reasons. The boolean argument indicates whether the positioning

87 -- should be absolute as with 'AbsoluteCursor' ('True') or logical

91 -- should be absolute as with 'AbsoluteCursor' ('True') or logical

88 -- as with 'Cursor' ('False').

92 -- as with 'Cursor' ('False').

89− | PositionOnly !Bool !Int !Int

90− -- | Show the cursor at the given logical column accounting for

91− -- character width in the presence of multi-column characters.

92 | Cursor !Int !Int

93 | Cursor !Int !Int

93 -- | Show the cursor at the given absolute terminal column and row

94 -- | Show the cursor at the given absolute terminal column and row

94 | AbsoluteCursor !Int !Int

95 | AbsoluteCursor !Int !Int

src/Graphics/Vty/PictureToSpans.hs+1−1

@@ -72,7 +72,7 @@ displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)

72-- | Returns the DisplayOps for an image rendered to a window the size

73-- of the image.

74--

75−-- largely used only for debugging.

75+-- largerly used only for debugging.

76displayOpsForImage :: Image -> DisplayOps

77displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)

78

src/Graphics/Vty/Span.hs+2

@@ -1,4 +1,6 @@

1-- Copyright Corey O'Connor

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

3-- | A picture is translated into a sequences of state changes and

5-- | A picture is translated into a sequences of state changes and

4-- character spans. The attribute is applied to all following spans,

6-- character spans. The attribute is applied to all following spans,

test/VerifyEmptyImageProps.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyEmptyImageProps where

1module VerifyEmptyImageProps where

3

2

4import Verify

3import Verify

test/VerifyEvalTerminfoCaps.hs−1

@@ -1,6 +1,5 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4module VerifyEvalTerminfoCaps where

3module VerifyEvalTerminfoCaps where

5

4

6import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)

5import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)

test/VerifyImageOps.hs+1−2

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyImageOps where

1module VerifyImageOps where

3

2

4import Graphics.Vty.Attributes

3import Graphics.Vty.Attributes

@@ -137,7 +136,7 @@ cropBottomLimitsHeight :: Image -> Int -> Property

137cropBottomLimitsHeight i v = v >= 0 ==>

136cropBottomLimitsHeight i v = v >= 0 ==>

138 v >= imageHeight (cropBottom v i)

137 v >= imageHeight (cropBottom v i)

139

138

140−-- ridiculous tests just to satisfy my desire for nice code coverage :-P

139+-- rediculous tests just to satisfy my desire for nice code coverage :-P

141canShowImage :: Image -> Bool

140canShowImage :: Image -> Bool

142canShowImage i = length (show i) > 0

141canShowImage i = length (show i) > 0

143

142

test/VerifyOutput.hs+2−7

@@ -1,7 +1,6 @@

1−-- We setup the environment to invoke certain terminals of interest.

1+-- We setup the environment to envoke certain terminals of interest.

2-- This assumes appropriate definitions exist in the current environment

3-- for the terminals of interest.

4−{-# LANGUAGE ScopedTypeVariables #-}

5module VerifyOutput where

4module VerifyOutput where

6

5

7import Verify

6import Verify

@@ -35,11 +34,7 @@ smokeTestTermNonMac termName i = liftIOResult $ do

35smokeTestTerm :: String -> Image -> IO Result

34smokeTestTerm :: String -> Image -> IO Result

36smokeTestTerm termName i = do

35smokeTestTerm termName i = do

37 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags

36 nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags

38− t <- outputForConfig $ defaultConfig

37+ t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }

39− { outputFd = Just nullOut

40− , termName = Just termName

41− , colorMode = Just NoColor

42− }

43 -- putStrLn $ "context color count: " ++ show (contextColorCount t)

38 -- putStrLn $ "context color count: " ++ show (contextColorCount t)

44 reserveDisplay t

39 reserveDisplay t

45 dc <- displayContext t (100,100)

40 dc <- displayContext t (100,100)

test/VerifyParseTerminfoCaps.hs−1

@@ -1,5 +1,4 @@

1{-# LANGUAGE NamedFieldPuns #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3module VerifyParseTerminfoCaps where

2module VerifyParseTerminfoCaps where

4

3

5import Prelude hiding ( catch )

4import Prelude hiding ( catch )

test/VerifyUsingMockInput.hs+1−4

@@ -1,6 +1,5 @@

1{-# LANGUAGE MultiParamTypeClasses #-}

2{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4-- Generate some input bytes and delays between blocks of input bytes.

3-- Generate some input bytes and delays between blocks of input bytes.

5-- Verify the events produced are as expected.

4-- Verify the events produced are as expected.

6module Main where

5module Main where

@@ -132,9 +131,7 @@ assertEventsFromSynInput table inputSpec expectedEvents = do

132 readLoop 0 = return ()

131 readLoop 0 = return ()

133 readLoop n = do

132 readLoop n = do

134 e <- atomically $ readTChan $ input^.eventChannel

133 e <- atomically $ readTChan $ input^.eventChannel

135− case e of

136− InputEvent ev -> modifyIORef eventsRef ((:) ev)

134+ modifyIORef eventsRef ((:) e)

137− ResumeAfterSignal -> return ()

138 readLoop (n - 1)

135 readLoop (n - 1)

139 genEventsUsingIoActions maxDuration writeWaitClose readEvents

136 genEventsUsingIoActions maxDuration writeWaitClose readEvents

140 outEvents <- reverse <$> readIORef eventsRef

137 outEvents <- reverse <$> readIORef eventsRef

test/interactive_terminal_test.hs+1−1

@@ -364,7 +364,7 @@ Did the test output match the description?

364|]

365 defaultSuccessConfirmResults

366

367−-- Explicitly define the bytes that encode each example text.

367+-- Explicitely definethe bytes that encode each example text.

368-- This avoids any issues with how the compiler represents string literals.

369--

370-- This document is UTF-8 encoded so the UTF-8 string is still included for

vty.cabal+23−4

@@ -1,5 +1,5 @@

1name: vty

2−version: 5.35.1

2+version: 5.32

3license: BSD3

4license-file: LICENSE

5author: AUTHORS

@@ -117,6 +117,8 @@ library

117

118 hs-source-dirs: src

119

120+ default-extensions: ScopedTypeVariables

121+

120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10

122 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10

121

123

122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10

124 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10

@@ -141,6 +143,7 @@ executable vty-mode-demo

141 hs-source-dirs: demos

143 hs-source-dirs: demos

142

144

143 default-language: Haskell2010

145 default-language: Haskell2010

146+ default-extensions: ScopedTypeVariables

144 ghc-options: -threaded

147 ghc-options: -threaded

145

148

146 build-depends: vty,

149 build-depends: vty,

@@ -155,6 +158,7 @@ executable vty-demo

155 hs-source-dirs: demos

158 hs-source-dirs: demos

156

159

157 default-language: Haskell2010

160 default-language: Haskell2010

161+ default-extensions: ScopedTypeVariables

158 ghc-options: -threaded

162 ghc-options: -threaded

159

163

160 build-depends: vty,

164 build-depends: vty,

@@ -166,6 +170,7 @@ executable vty-demo

166

170

167test-suite verify-using-mock-terminal

171test-suite verify-using-mock-terminal

168 default-language: Haskell2010

172 default-language: Haskell2010

173+ default-extensions: ScopedTypeVariables

169

174

170 type: detailed-0.9

175 type: detailed-0.9

171

176

@@ -198,6 +203,7 @@ test-suite verify-using-mock-terminal

198

203

199test-suite verify-terminal

204test-suite verify-terminal

200 default-language: Haskell2010

205 default-language: Haskell2010

206+ default-extensions: ScopedTypeVariables

201

207

202 type: detailed-0.9

208 type: detailed-0.9

203

209

@@ -230,6 +236,7 @@ test-suite verify-terminal

230

236

231test-suite verify-display-attributes

237test-suite verify-display-attributes

232 default-language: Haskell2010

238 default-language: Haskell2010

239+ default-extensions: ScopedTypeVariables

233

240

234 type: detailed-0.9

241 type: detailed-0.9

235

242

@@ -261,6 +268,7 @@ test-suite verify-display-attributes

261

268

262test-suite verify-empty-image-props

269test-suite verify-empty-image-props

263 default-language: Haskell2010

270 default-language: Haskell2010

271+ default-extensions: ScopedTypeVariables

264

272

265 type: detailed-0.9

273 type: detailed-0.9

266

274

@@ -286,6 +294,7 @@ test-suite verify-empty-image-props

286

294

287test-suite verify-eval-terminfo-caps

295test-suite verify-eval-terminfo-caps

288 default-language: Haskell2010

296 default-language: Haskell2010

297+ default-extensions: ScopedTypeVariables

289

298

290 type: detailed-0.9

299 type: detailed-0.9

291

300

@@ -314,6 +323,7 @@ test-suite verify-eval-terminfo-caps

314

323

315test-suite verify-image-ops

324test-suite verify-image-ops

316 default-language: Haskell2010

325 default-language: Haskell2010

326+ default-extensions: ScopedTypeVariables

317

327

318 type: detailed-0.9

328 type: detailed-0.9

319

329

@@ -341,6 +351,7 @@ test-suite verify-image-ops

341

351

342test-suite verify-image-trans

352test-suite verify-image-trans

343 default-language: Haskell2010

353 default-language: Haskell2010

354+ default-extensions: ScopedTypeVariables

344

355

345 type: detailed-0.9

356 type: detailed-0.9

346

357

@@ -368,6 +379,7 @@ test-suite verify-image-trans

368

379

369test-suite verify-inline

380test-suite verify-inline

370 default-language: Haskell2010

381 default-language: Haskell2010

382+ default-extensions: ScopedTypeVariables

371

383

372 type: detailed-0.9

384 type: detailed-0.9

373

385

@@ -394,6 +406,7 @@ test-suite verify-inline

394

406

395test-suite verify-parse-terminfo-caps

407test-suite verify-parse-terminfo-caps

396 default-language: Haskell2010

408 default-language: Haskell2010

409+ default-extensions: ScopedTypeVariables

397

410

398 type: detailed-0.9

411 type: detailed-0.9

399

412

@@ -422,6 +435,7 @@ test-suite verify-parse-terminfo-caps

422

435

423test-suite verify-simple-span-generation

436test-suite verify-simple-span-generation

424 default-language: Haskell2010

437 default-language: Haskell2010

438+ default-extensions: ScopedTypeVariables

425

439

426 type: detailed-0.9

440 type: detailed-0.9

427

441

@@ -453,6 +467,7 @@ test-suite verify-simple-span-generation

453

467

454test-suite verify-crop-span-generation

468test-suite verify-crop-span-generation

455 default-language: Haskell2010

469 default-language: Haskell2010

470+ default-extensions: ScopedTypeVariables

456

471

457 type: detailed-0.9

472 type: detailed-0.9

458

473

@@ -484,6 +499,7 @@ test-suite verify-crop-span-generation

484

499

485test-suite verify-layers-span-generation

500test-suite verify-layers-span-generation

486 default-language: Haskell2010

501 default-language: Haskell2010

502+ default-extensions: ScopedTypeVariables

487

503

488 type: detailed-0.9

504 type: detailed-0.9

489

505

@@ -514,6 +530,7 @@ test-suite verify-layers-span-generation

514

530

515test-suite verify-color-mapping

531test-suite verify-color-mapping

516 default-language: Haskell2010

532 default-language: Haskell2010

533+ default-extensions: ScopedTypeVariables

517

534

518 type: detailed-0.9

535 type: detailed-0.9

519

536

@@ -526,7 +543,7 @@ test-suite verify-color-mapping

526 build-depends: vty,

543 build-depends: vty,

527 Cabal >= 1.20,

544 Cabal >= 1.20,

528 QuickCheck >= 2.7,

545 QuickCheck >= 2.7,

529− random >= 1.0 && < 1.3,

546+ random >= 1.0 && < 1.2,

530 base >= 4.8 && < 5,

547 base >= 4.8 && < 5,

531 bytestring,

548 bytestring,

532 containers,

549 containers,

@@ -537,8 +554,10 @@ test-suite verify-color-mapping

537 utf8-string >= 0.3 && < 1.1,

554 utf8-string >= 0.3 && < 1.1,

538 vector >= 0.7

555 vector >= 0.7

539

556

557+

540test-suite verify-utf8-width

558test-suite verify-utf8-width

541 default-language: Haskell2010

559 default-language: Haskell2010

560+ default-extensions: ScopedTypeVariables

542

561

543 type: detailed-0.9

562 type: detailed-0.9

544

563

@@ -564,6 +583,7 @@ test-suite verify-utf8-width

564

583

565test-suite verify-using-mock-input

584test-suite verify-using-mock-input

566 default-language: Haskell2010

585 default-language: Haskell2010

586+ default-extensions: ScopedTypeVariables

567

587

568 type: exitcode-stdio-1.0

588 type: exitcode-stdio-1.0

569

589

@@ -571,8 +591,6 @@ test-suite verify-using-mock-input

571

591

572 main-is: VerifyUsingMockInput.hs

592 main-is: VerifyUsingMockInput.hs

573

593

574− other-modules: Verify.Graphics.Vty.Output

575−

576 build-depends: vty,

594 build-depends: vty,

577 Cabal >= 1.20,

595 Cabal >= 1.20,

578 QuickCheck >= 2.7,

596 QuickCheck >= 2.7,

@@ -599,6 +617,7 @@ test-suite verify-using-mock-input

599

617

600test-suite verify-config

618test-suite verify-config

601 default-language: Haskell2010

619 default-language: Haskell2010

620+ default-extensions: ScopedTypeVariables

602

621

603 type: exitcode-stdio-1.0

622 type: exitcode-stdio-1.0

604

623