b3504fb...master · vty

CHANGELOG.md+38

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

11

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+

2405.34

341----

442

demos/Demo.hs+12−4

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

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

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

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

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

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

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

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

3637 , "claims 240 colors are not supported."

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

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

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

4344 ]

4445

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+

4555colorbox_240 :: Image

4656colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

4757 where

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

49− splitColorImages [] = []

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

5159

5260colorbox_16 :: Image

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

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

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

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

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

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

7482 vty <- ask

7583 liftIO $ update vty pic

7684

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

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

11{-# LANGUAGE BangPatterns #-}

22{-# LANGUAGE CPP #-}

3−{-# OPTIONS_HADDOCK hide #-}

43{-# LANGUAGE NoMonomorphismRestriction #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

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

6+{-# OPTIONS_HADDOCK hide #-}

67

78module Data.Terminfo.Parse

89 ( module Data.Terminfo.Parse

src/Graphics/Vty.hs+12−8

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

23

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

45-- output.

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

4748

4849import Graphics.Vty.Config

4950import Graphics.Vty.Input

51+import Graphics.Vty.Input.Events

5052import Graphics.Vty.Output

5153import Graphics.Vty.Output.Interface

5254import Graphics.Vty.Picture

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

208210 maybe (return ()) innerUpdate mPic

209211

210212 let mkResize = uncurry EvResize <$> displayBounds out

213+

214+ translateInternalEvent ResumeAfterSignal = mkResize

215+ translateInternalEvent (InputEvent e) = return e

216+

211217 gkey = do

212− k <- atomically $ readTChan $ _eventChannel input

213− case k of

214− (EvResize _ _) -> mkResize

215− _ -> return k

218+ e <- atomically $ readTChan $ _eventChannel input

219+ translateInternalEvent e

216220 gkey' = do

217− k <- atomically $ tryReadTChan $ _eventChannel input

218− case k of

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

220− _ -> return k

221+ mEv <- atomically $ tryReadTChan $ _eventChannel input

222+ case mEv of

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

224+ Nothing -> return Nothing

221225

222226 return $ Vty { update = innerUpdate

223227 , nextEvent = gkey

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

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

11{-# LANGUAGE DeriveGeneric #-}

22{-# LANGUAGE DeriveAnyClass #-}

3+{-# LANGUAGE MultiWayIf #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

35

46module Graphics.Vty.Attributes.Color

57 ( Color(..)

8+ , ColorMode(..)

9+

10+ -- * Detecting Terminal Color Support

11+ , detectColorMode

612

713 -- ** Fixed Colors

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

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

3238 , brightCyan

3339 , brightWhite

3440 -- ** Creating Colors From RGB

41+ , linearColor

42+ , srgbColor

3543 , rgbColor

44+ , color240

3645 , module Graphics.Vty.Attributes.Color240

3746 )

3847where

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

4049import Data.Word

4150import GHC.Generics

4251import 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

4357

4458import Graphics.Vty.Attributes.Color240

4559

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

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

8296--

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

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

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

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

86100-- addressable via the 240 color palette.

87101--

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

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

96110--

97111-- Seriously, terminal color support is INSANE.

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

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

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

100114

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+

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

102140black = ISOColor 0

103141red = ISOColor 1

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

119157brightCyan = ISOColor 14

120158brightWhite = ISOColor 15

121159

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)

122186

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

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

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

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

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

191+rgbColor = color240

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

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

33{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE ScopedTypeVariables #-}

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

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

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

89-- application's use of Vty.

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

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

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

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

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

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

5859--

5960-- = Unicode Character Width Maps

6061--

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

122123import Data.Typeable (Typeable)

123124

124125import Graphics.Vty.Input.Events

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

125127

126128import GHC.Generics

127129

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

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

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

195197 -- will be used.

198+ , colorMode :: Maybe ColorMode

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

200+ -- supports.

196201 }

197202 deriving (Show, Eq)

198203

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

214219 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

215220 , allowCustomUnicodeWidthTables =

216221 allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

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

217223 }

218224

219225instance Monoid Config where

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

229235 , termName = Nothing

230236 , termWidthMaps = []

231237 , allowCustomUnicodeWidthTables = Nothing

238+ , colorMode = Nothing

232239 }

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

234241 mappend = (<>)

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

284291 mb <- lookupEnv termVariable

285292 case mb of

286293 Nothing -> throwIO VtyMissingTermEnvVar

287− Just t ->

294+ Just t -> do

295+ mcolorMode <- detectColorMode t

288296 return defaultConfig

289297 { vmin = Just 1

290298 , mouseMode = Just False

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

293301 , inputFd = Just stdInput

294302 , outputFd = Just stdOutput

295303 , termName = Just t

304+ , colorMode = Just mcolorMode

296305 }

297306

298307parseConfigFile :: FilePath -> IO Config

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

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

137137 let displayWidth = safeWcwidth c

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

139139

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

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

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

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

143143-- 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

228228--

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

230230-- 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 missmatch

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

232232-- will be filled with the background pattern.

233233horizJoin :: Image -> Image -> Image

234234horizJoin EmptyImage i = i

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

259259--

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

261261-- 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 missmatch

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

263263-- will be filled with the background pattern.

264264vertJoin :: Image -> Image -> Image

265265vertJoin EmptyImage i = i

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

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

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

7878-- recognized.

7979--

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

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

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

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

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

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

9595--

9696-- == Terminal Input is Broken

9797--

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

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

9999-- to reliably resolve these issues.

100100--

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

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

158158 setAttrs

159159 input <- initInput config activeInputMap

160160 let pokeIO = Catch $ do

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

162161 setAttrs

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

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

164163 _ <- installHandler windowChange pokeIO Nothing

165164 _ <- installHandler continueProcess pokeIO Nothing

166165

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

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

11{-# OPTIONS_HADDOCK hide #-}

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

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

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

44-- be better.

55module Graphics.Vty.Input.Classify

66 ( classify

77 , KClass(..)

8+ , ClassifierState(..)

89 )

910where

1011

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

1617

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

1819

19−import Data.List (inits)

20+import Control.Arrow (first)

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

2122import Data.Maybe ( mapMaybe )

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

2324

24−import Data.Char

2525import Data.Word

2626

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

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

2843compile table = cl' where

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

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

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

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

32− eventForInput = M.fromList table

33− cl' [] = Prefix

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

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

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

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

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

37− Just e -> Valid e []

52+ Just e -> Valid e BS8.empty

3853 Nothing -> case S.member inputBlock prefixSet of

3954 True -> Prefix

4055 -- look up progressively smaller tails of the input

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

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

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

4762 False ->

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

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

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

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

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

5166 -- neither a prefix or a full event.

5267 [] -> Invalid

5368

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

55−classify table =

56− let standardClassifier = compile table

57− in \s -> case s of

58− _ | bracketedPasteStarted s ->

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

70+classify table = process

71+ where

72+ standardClassifier = compile table

73+

74+ process ClassifierStart s =

75+ case BS.uncons s of

76+ _ | 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 =

5986 if bracketedPasteFinished s

60− then parseBracketedPaste s

61− else Prefix

62− _ | isMouseEvent s -> classifyMouseEvent s

63− _ | isFocusEvent s -> classifyFocusEvent s

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

65− _ -> standardClassifier s

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

88+ else Chunk

89+ process ClassifierInChunk{} _ = Invalid

6690

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

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

6892classifyUtf8 c cs =

69− let n = utf8Length (ord c)

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

93+ let n = utf8Length c

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

7195

7296 codepoint8 :: [Word8]

73− codepoint8 = map (fromIntegral . ord) codepoint

97+ codepoint8 = c:BS.unpack codepoint

7498

7599 in case decode codepoint8 of

76− _ | n < length codepoint -> Prefix

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

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

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

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

79− Nothing -> Invalid

103+ Nothing -> Invalid

80104

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

105+utf8Length :: Word8 -> Int

82106utf8Length c

83107 | c < 0x80 = 1

84108 | c < 0xE0 = 2

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

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

1616import Control.Monad.Trans.Maybe

1717import Control.Monad.State

1818

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

19+import qualified Data.ByteString.Char8 as BS8

20+import Data.ByteString.Char8 (ByteString)

21+

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

2023

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

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

2326-- remaining unparsed characters.

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

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

2528runParser s parser =

2629 case runState (runMaybeT parser) s of

2730 (Nothing, _) -> Invalid

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

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

3740readInt :: Parser Int

3841readInt = do

39− s <- get

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

4043 case (reads :: ReadS Int) s of

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

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

4245 _ -> failParse

4346

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

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

4649readChar :: Parser Char

4750readChar = do

4851 s <- get

49− case s of

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

51− _ -> failParse

52+ case BS8.uncons s of

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

54+ Nothing -> failParse

5255

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

5457-- not the specified character.

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

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

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

22-- cycles between other modules that need this.

3+{-# LANGUAGE StrictData #-}

34module Graphics.Vty.Input.Classify.Types

45 ( KClass(..)

56 )

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

78

89import Graphics.Vty.Input.Events

910

11+import Data.ByteString.Char8 (ByteString)

12+

1013data KClass

11− = Valid Event String

14+ = Valid Event ByteString

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

1316 -- stream are also provided.

1417 | Invalid

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

1619 | Prefix

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

1821 -- 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.

1925 deriving(Show, Eq)

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

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

11{-# Language DeriveGeneric #-}

2+{-# Language StrictData #-}

23module Graphics.Vty.Input.Events where

34

45import Control.DeepSeq

@@ -15,10 +16,10 @@ import GHC.Generics

1516--

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

1718-- KEnter vary by terminal and keyboard.

18−data Key = KEsc | KChar Char | KBS | KEnter

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

1920 | KLeft | KRight | KUp | KDown

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

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

2425

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

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

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

5354 | EvResize Int Int

54− -- ^ If read from 'eventChannel' this is the size at the time of the

55− -- signal. If read from 'nextEvent' this is the size at the time the

56− -- event was processed by Vty. Typically these are the same, but if

57− -- somebody is resizing the terminal quickly they can be different.

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

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

5857 | EvPaste ByteString

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

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

@@ -72,3 +71,13 @@ data Event

7271instance NFData Event

7372

7473type 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+15−13

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

1111import Graphics.Vty.Input.Classify.Parse

1212

1313import Control.Monad.State

14−import Data.List (isPrefixOf)

14+

15+import qualified Data.ByteString.Char8 as BS8

16+import Data.ByteString.Char8 (ByteString)

1517

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

1719-- sequences.

18−requestFocusEvents :: String

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

20+requestFocusEvents :: ByteString

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

2022

2123-- | These sequences disable focus events.

22−disableFocusEvents :: String

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

24+disableFocusEvents :: ByteString

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

2426

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

26−isFocusEvent :: String -> Bool

27−isFocusEvent s = isPrefixOf focusIn s ||

28− isPrefixOf focusOut s

28+isFocusEvent :: ByteString -> Bool

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

30+ BS8.isPrefixOf focusOut s

2931

30−focusIn :: String

31−focusIn = "\ESC[I"

32+focusIn :: ByteString

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

3234

33−focusOut :: String

34−focusOut = "\ESC[O"

35+focusOut :: ByteString

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

3537

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

37−classifyFocusEvent :: String -> KClass

39+classifyFocusEvent :: ByteString -> KClass

3840classifyFocusEvent s = runParser s $ do

3941 when (not $ isFocusEvent s) failParse

4042

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

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

1−{-# LANGUAGE RecordWildCards #-}

2−{-# OPTIONS_HADDOCK hide #-}

1+{-# LANGUAGE CPP #-}

32{-# LANGUAGE NoMonomorphismRestriction #-}

3+{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TemplateHaskell #-}

5−{-# LANGUAGE CPP #-}

6+{-# OPTIONS_HADDOCK hide #-}

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

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

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

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

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

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

3536

36−import Data.Char

37+import qualified Data.ByteString.Char8 as BS8

38+import qualified Data.ByteString as BS

39+import Data.ByteString.Char8 (ByteString)

3740import Data.IORef

3841import Data.Word (Word8)

3942

40−import Foreign ( allocaArray, peekArray, Ptr )

43+import Foreign (allocaArray)

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

45+import Foreign.Ptr (Ptr, castPtr)

4246

4347import System.IO

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

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

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

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

5357 -- is an 'EvResize'.

54− _eventChannel :: TChan Event

58+ _eventChannel :: TChan InternalEvent

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

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

5761 , shutdownInput :: IO ()

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

7680makeLenses ''InputBuffer

7781

7882data InputState = InputState

79− { _unprocessedBytes :: String

83+ { _unprocessedBytes :: ByteString

84+ , _classifierState :: ClassifierState

8085 , _appliedConfig :: Config

8186 , _inputBuffer :: InputBuffer

82− , _classifier :: String -> KClass

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

8388 }

8489

8590makeLenses ''InputState

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

104109 dropInvalid

105110 loopInputProcessor

106111

107−addBytesToProcess :: String -> InputM ()

112+addBytesToProcess :: ByteString -> InputM ()

108113addBytesToProcess block = unprocessedBytes <>= block

109114

110115emit :: Event -> InputM ()

111116emit event = do

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

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

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

114119

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

116121-- device.

117122--

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

119124-- forkOS thread. That case satisfies precondition.

120−readFromDevice :: InputM String

125+readFromDevice :: InputM ByteString

121126readFromDevice = do

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

123128 oldConfig <- use appliedConfig

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

137142 threadWaitRead fd

138143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

139144 if bytesRead > 0

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

141− else return []

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

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

146+ else return BS.empty

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

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

143149 return stringRep

144150

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

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

150156parseEvent :: InputM Event

151157parseEvent = do

152158 c <- use classifier

159+ s <- use classifierState

153160 b <- use unprocessedBytes

154− case c b of

161+ case c s b of

155162 Valid e remaining -> do

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

157164 logMsg $ "remaining: " ++ show remaining

165+ classifierState .= ClassifierStart

158166 unprocessedBytes .= remaining

159167 return e

160− _ -> mzero

168+ _ -> mzero

161169

162170dropInvalid :: InputM ()

163171dropInvalid = do

164172 c <- use classifier

173+ s <- use classifierState

165174 b <- use unprocessedBytes

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

167− logMsg "dropping input bytes"

168− 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

183+ logMsg "dropping input bytes"

184+ classifierState .= ClassifierStart

185+ unprocessedBytes .= BS8.empty

186+ _ -> return ()

169187

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

171189runInputProcessorLoop classifyTable input = do

172190 let bufferSize = 1024

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

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

175− <*> pure (InputBuffer bufferPtr bufferSize)

176− <*> pure (classify classifyTable)

192+ s0 <- InputState BS8.empty ClassifierStart

193+ <$> readIORef (_configRef input)

194+ <*> pure (InputBuffer bufferPtr bufferSize)

195+ <*> pure (classify classifyTable)

177196 runReaderT (evalStateT loopInputProcessor s0) input

178197

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

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

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

1515import Graphics.Vty.Input.Classify.Parse

1616

1717import Control.Monad.State

18−import Data.List (isPrefixOf)

1918import Data.Maybe (catMaybes)

2019import Data.Bits ((.&.))

2120

21+import qualified Data.ByteString.Char8 as BS8

22+import Data.ByteString.Char8 (ByteString)

23+

2224-- A mouse event in SGR extended mode is

2325--

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

@@ -32,28 +34,28 @@ import Data.Bits ((.&.))

3234

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

3436-- sequences.

35−requestMouseEvents :: String

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

37+requestMouseEvents :: ByteString

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

3739

3840-- | These sequences disable mouse events.

39−disableMouseEvents :: String

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

41+disableMouseEvents :: ByteString

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

4143

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

43−isMouseEvent :: String -> Bool

45+isMouseEvent :: ByteString -> Bool

4446isMouseEvent s = isSGREvent s || isNormalEvent s

4547

46−isSGREvent :: String -> Bool

47−isSGREvent = isPrefixOf sgrPrefix

48+isSGREvent :: ByteString -> Bool

49+isSGREvent = BS8.isPrefixOf sgrPrefix

4850

49−sgrPrefix :: String

50−sgrPrefix = "\ESC[M"

51+sgrPrefix :: ByteString

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

5153

52−isNormalEvent :: String -> Bool

53−isNormalEvent = isPrefixOf normalPrefix

54+isNormalEvent :: ByteString -> Bool

55+isNormalEvent = BS8.isPrefixOf normalPrefix

5456

55−normalPrefix :: String

56−normalPrefix = "\ESC[<"

57+normalPrefix :: ByteString

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

5759

5860-- Modifier bits:

5961shiftBit :: Int

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

8789hasBitSet :: Int -> Int -> Bool

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

8991

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

91−classifyMouseEvent :: String -> KClass

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

93+classifyMouseEvent :: ByteString -> KClass

9294classifyMouseEvent s = runParser s $ do

9395 when (not $ isMouseEvent s) failParse

9496

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

100102 'M' -> classifyNormalMouseEvent

101103 _ -> failParse

102104

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

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

104106getSGRButton :: Int -> Parser Button

105107getSGRButton mods =

106108 let buttonMap = [ (leftButton, BLeft)

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

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

99where

1010

1111import qualified Data.ByteString.Char8 as BS8

12+import Data.ByteString.Char8 (ByteString)

1213

1314import Graphics.Vty.Input.Events

1415import Graphics.Vty.Input.Classify.Types

1516

16−import Data.List (isPrefixOf, isInfixOf)

17+bracketedPasteStart :: ByteString

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

1719

18−bracketedPasteStart :: String

19−bracketedPasteStart = "\ESC[200~"

20−

21−bracketedPasteEnd :: String

22−bracketedPasteEnd = "\ESC[201~"

20+bracketedPasteEnd :: ByteString

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

2322

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

25−bracketedPasteStarted :: String -> Bool

26−bracketedPasteStarted = isPrefixOf bracketedPasteStart

24+bracketedPasteStarted :: ByteString -> Bool

25+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart

2726

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

29−bracketedPasteFinished :: String -> Bool

30−bracketedPasteFinished = isInfixOf bracketedPasteEnd

28+bracketedPasteFinished :: ByteString -> Bool

29+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd

3130

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

3332-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

3433-- 'True'.

35−parseBracketedPaste :: String -> KClass

34+parseBracketedPaste :: ByteString -> KClass

3635parseBracketedPaste 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

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

42−

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

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

45−takeUntil cs sub

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)

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

37+ where

38+ startLen = BS8.length bracketedPasteStart

39+ endLen = BS8.length bracketedPasteEnd

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

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

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

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

9191 -- special support for ESC

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

9393 -- Special support for backspace

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

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

9595 -- Special support for Enter

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

9797 -- explicit support for tab

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

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

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

5959-- * otherwise use the TerminfoBased driver.

6060outputForConfig :: Config -> IO Output

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

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

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

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

63− then XTermColor.reserveTerminal termName fd

64+ then XTermColor.reserveTerminal termName fd colorMode

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

65− else TerminfoBased.reserveTerminal termName fd

66+ else TerminfoBased.reserveTerminal termName fd colorMode

6667

6768 case mouseMode of

6869 Just s -> setMode t Mouse s

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

7778

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

7980--

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

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

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

8283-- width.

8384--

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

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

33{-# LANGUAGE ExistentialQuantification #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

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

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

89module Graphics.Vty.Output.Interface

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

7879 , displayBounds :: IO DisplayRegion

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

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

81− -- | Specifies the maximum number of colors supported by the

82− -- context.

83− , contextColorCount :: Int

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

8583 , supportsCursorVisibility :: Bool

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

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

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

117115 -- desired.

118116 , supportsStrikethrough :: IO Bool

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

118+ , outputColorMode :: ColorMode

119119 }

120120

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

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

309309 where

310310 clampColor Default = Default

311311 clampColor KeepCurrent = KeepCurrent

312− clampColor (SetTo c) = clampColor' c

313− clampColor' (ISOColor v)

314− | contextColorCount t < 8 = Default

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

316− | otherwise = SetTo $ ISOColor v

317− clampColor' (Color240 v)

318− -- Should we choose closest ISO color?

319− | contextColorCount t < 8 = Default

320− | contextColorCount t < 16 = Default

321− | contextColorCount t <= 256 = SetTo $ Color240 v

322− | otherwise

323− = let p :: Double = fromIntegral v / 240.0

324− v' = floor $ p * (fromIntegral $ contextColorCount t)

325− in SetTo $ Color240 v'

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

313+

314+ clampColor' NoColor _ = Default

315+

316+ clampColor' ColorMode8 (ISOColor v)

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

318+ | otherwise = SetTo $ ISOColor v

319+ clampColor' ColorMode8 _ = Default

320+

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

322+ clampColor' ColorMode16 _ = Default

323+

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

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

326+ | n <= colorCount = SetTo c

327+ | otherwise = Default

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

329+ clampColor' colorMode (color240 r g b)

330+

331+ clampColor' FullColor c = SetTo c

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

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

1111where

1212

1313import Graphics.Vty.Image (DisplayRegion)

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

1415import Graphics.Vty.Output.Interface

1516

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

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

3031-- without considering terminal specific issues.

3132--

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

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

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

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

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

3637-- terminal operations.

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

5556 , outputByteBuffer = \bytes -> do

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

5758 writeIORef outRef $ UTF8.fromRep bytes

58− , contextColorCount = 16

5959 , supportsCursorVisibility = True

6060 , supportsMode = const False

6161 , setMode = const $ const $ return ()

6262 , getModeStatus = const $ return False

6363 , assumedStateRef = newAssumedStateRef

64+ , outputColorMode = ColorMode16

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

6566 { contextRegion = rActual

6667 , contextDevice = tActual

src/Graphics/Vty/Output/TerminfoBased.hs+66−33

@@ -25,7 +25,7 @@ import Graphics.Vty.Image (DisplayRegion)

2525import Graphics.Vty.DisplayAttributes

2626import Graphics.Vty.Output.Interface

2727

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

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

2929

3030import Data.IORef

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

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

4949 , cup :: CapExpression

5050 , cnorm :: Maybe CapExpression

5151 , civis :: Maybe CapExpression

52− , supportsNoColors :: Bool

5352 , useAltColorMap :: Bool

5453 , setForeColor :: CapExpression

5554 , setBackColor :: CapExpression

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

104103--

105104-- * Providing independent string capabilities for all display

106105-- attributes.

107−reserveTerminal :: String -> Fd -> IO Output

108−reserveTerminal termName outFd = do

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

107+reserveTerminal termName outFd colorMode = do

109108 ti <- Terminfo.setupTerm termName

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

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

112111 -- attributes are filtered.

113112 msetaf <- probeCap ti "setaf"

114113 msetf <- probeCap ti "setf"

115− let (noColors, useAlt, setForeCap)

114+ let (useAlt, setForeCap)

116115 = case msetaf of

117− Just setaf -> (False, False, setaf)

116+ Just setaf -> (False, setaf)

118117 Nothing -> case msetf of

119− Just setf -> (False, True, setf)

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

118+ Just setf -> (True, setf)

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

121120 msetab <- probeCap ti "setab"

122121 msetb <- probeCap ti "setb"

123− let set_back_cap

122+ let setBackCap

124123 = case msetab of

124+ Just setab -> setab

125125 Nothing -> case msetb of

126126 Just setb -> setb

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

128− Just setab -> setab

129128

130129 hyperlinkModeStatus <- newIORef False

131130 newAssumedStateRef <- newIORef initialAssumedState

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

151150 <*> requireCap ti "cup"

152151 <*> probeCap ti "cnorm"

153152 <*> probeCap ti "civis"

154− <*> pure noColors

155153 <*> pure useAlt

156154 <*> pure setForeCap

157− <*> pure set_back_cap

155+ <*> pure setBackCap

158156 <*> requireCap ti "sgr0"

159157 <*> requireCap ti "clear"

160158 <*> requireCap ti "el"

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

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

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

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

197− , contextColorCount

198− = case supportsNoColors terminfoCaps of

199− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

200− Nothing -> 8

201− Just v -> toEnum v

202− True -> 1

203195 , supportsCursorVisibility = isJust $ civis terminfoCaps

204196 , supportsMode = terminfoModeSupported

205197 , setMode = terminfoSetMode

206198 , getModeStatus = terminfoModeStatus

207199 , assumedStateRef = newAssumedStateRef

200+ , outputColorMode = colorMode

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

209202 -- reference. I was having issues tho.

210203 , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

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

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

303296--

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

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

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

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

307300--

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

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

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

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

343336 -- capability.

344− True -> do

337+ True -> do

345338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

346− (fixedStyle attr )

339+ (fixedStyle attr)

347340 (styleToApplySeq $ fixedStyle attr) of

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

349342 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

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

376369 -- applied states.

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

378371 `mappend`

379− writeColorDiff setForeColor (foreColorDiff diffs)

372+ writeColorDiff Foreground (foreColorDiff diffs)

380373 `mappend`

381− writeColorDiff setBackColor (backColorDiff diffs)

374+ writeColorDiff Background (backColorDiff diffs)

382375 -- implicitly resets the colors to the defaults

383376 SetState state -> writeCapExpr (fromJust $ setAttrStates

384377 $ displayAttrCaps terminfoCaps

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

410403 | otherwise = mempty

411404 setColors =

412405 (case fixedForeColor attr of

413− Just c -> writeCapExpr (setForeColor terminfoCaps)

414− [toEnum $ colorMap c]

406+ Just c -> writeColor Foreground c

415407 Nothing -> mempty)

416408 `mappend`

417409 (case fixedBackColor attr of

418− Just c -> writeCapExpr (setBackColor terminfoCaps)

419− [toEnum $ colorMap c]

410+ Just c -> writeColor Background c

420411 Nothing -> mempty)

421− writeColorDiff _f NoColorChange

412+ writeColorDiff _side NoColorChange

422413 = mempty

423− writeColorDiff _f ColorToDefault

414+ writeColorDiff _side ColorToDefault

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

425− writeColorDiff f (SetColor c)

426− = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]

416+ writeColorDiff side (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]

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"

427452

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

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

430455--

431−-- This takes a Color which clearly identifies which pallete to use and

432−-- computes the index into the full 256 color pallete.

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

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

433458ansiColorIndex :: Color -> Int

434459ansiColorIndex (ISOColor v) = fromEnum v

435460ansiColorIndex (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+ ]

436465

437466-- | For terminals without setaf/setab

438467--

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

449478altColorIndex (ISOColor 7) = 7

450479altColorIndex (ISOColor v) = fromEnum v

451480altColorIndex (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+ ]

452485

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

454487 - according to these rules.

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

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

1010import Graphics.Vty.Output.Interface

1111import Graphics.Vty.Input.Mouse

1212import Graphics.Vty.Input.Focus

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

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

1415

1516import Blaze.ByteString.Builder (writeToByteString)

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

1718

19+import qualified Data.ByteString.Char8 as BS8

20+import Data.ByteString.Char8 (ByteString)

21+import Foreign.Ptr (castPtr)

22+

1823import Control.Monad (void, when)

1924import Control.Monad.Trans

2025import Data.Char (toLower)

2126import Data.IORef

2227

23−import System.Posix.IO (fdWrite)

24−import System.Posix.Types (Fd)

28+import System.Posix.IO (fdWriteBuf)

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

2530import System.Posix.Env (getEnv)

2631

2732import Data.List (isInfixOf)

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

3136import Data.Monoid ((<>))

3237#endif

3338

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+

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

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

36−reserveTerminal variant outFd = liftIO $ do

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

47+reserveTerminal variant outFd colorMode = liftIO $ do

3748 let flushedPut = void . fdWrite outFd

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

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

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

4152

4253 utf8a <- utf8Active

4354 when (not utf8a) $ flushedPut setUtf8CharSet

44− t <- TerminfoBased.reserveTerminal variant' outFd

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

4556

4657 mouseModeStatus <- newIORef False

4758 focusModeStatus <- newIORef False

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

100111

101112-- | Enable bracketed paste mode:

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

103−enableBracketedPastes :: String

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

114+enableBracketedPastes :: ByteString

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

105116

106117-- | Disable bracketed paste mode:

107−disableBracketedPastes :: String

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

118+disableBracketedPastes :: ByteString

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

109120

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

111122--

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

113−setUtf8CharSet, setDefaultCharSet :: String

114−setUtf8CharSet = "\ESC%G"

115−setDefaultCharSet = "\ESC%@"

124+setUtf8CharSet, setDefaultCharSet :: ByteString

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

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

116127

117128xtermInlineHack :: Output -> IO ()

118129xtermInlineHack t = do

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

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

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

7373-- of the image.

7474--

75−-- largerly used only for debugging.

75+-- largely used only for debugging.

7676displayOpsForImage :: Image -> DisplayOps

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

7878

test/VerifyEmptyImageProps.hs+1

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

1+{-# LANGUAGE ScopedTypeVariables #-}

12module VerifyEmptyImageProps where

23

34import Verify

test/VerifyEvalTerminfoCaps.hs+1

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

11{-# LANGUAGE BangPatterns #-}

22{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

34module VerifyEvalTerminfoCaps where

45

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

test/VerifyImageOps.hs+2−1

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

1+{-# LANGUAGE ScopedTypeVariables #-}

12module VerifyImageOps where

23

34import Graphics.Vty.Attributes

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

136137cropBottomLimitsHeight i v = v >= 0 ==>

137138 v >= imageHeight (cropBottom v i)

138139

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

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

140141canShowImage :: Image -> Bool

141142canShowImage i = length (show i) > 0

142143

test/VerifyOutput.hs+7−2

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

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

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

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

33-- for the terminals of interest.

4+{-# LANGUAGE ScopedTypeVariables #-}

45module VerifyOutput where

56

67import Verify

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

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

3536smokeTestTerm termName i = do

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

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

38+ t <- outputForConfig $ defaultConfig

39+ { outputFd = Just nullOut

40+ , termName = Just termName

41+ , colorMode = Just NoColor

42+ }

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

3944 reserveDisplay t

4045 dc <- displayContext t (100,100)

test/VerifyParseTerminfoCaps.hs+1

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

11{-# LANGUAGE NamedFieldPuns #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

23module VerifyParseTerminfoCaps where

34

45import Prelude hiding ( catch )

test/VerifyUsingMockInput.hs+4−1

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

11{-# LANGUAGE MultiParamTypeClasses #-}

22{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

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

45-- Verify the events produced are as expected.

56module Main where

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

131132 readLoop 0 = return ()

132133 readLoop n = do

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

134− modifyIORef eventsRef ((:) e)

135+ case e of

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

137+ ResumeAfterSignal -> return ()

135138 readLoop (n - 1)

136139 genEventsUsingIoActions maxDuration writeWaitClose readEvents

137140 outEvents <- reverse <$> readIORef eventsRef

test/interactive_terminal_test.hs+1−1

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

364364|]

365365 defaultSuccessConfirmResults

366366

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

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

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

369369--

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

vty.cabal+3−21

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

11name: vty

2−version: 5.34

2+version: 5.35.1

33license: BSD3

44license-file: LICENSE

55author: AUTHORS

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

117117

118118 hs-source-dirs: src

119119

120− default-extensions: ScopedTypeVariables

121−

122120 ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10

123121

124122 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10

@@ -143,7 +141,6 @@ executable vty-mode-demo

143141 hs-source-dirs: demos

144142

145143 default-language: Haskell2010

146− default-extensions: ScopedTypeVariables

147144 ghc-options: -threaded

148145

149146 build-depends: vty,

@@ -158,7 +155,6 @@ executable vty-demo

158155 hs-source-dirs: demos

159156

160157 default-language: Haskell2010

161− default-extensions: ScopedTypeVariables

162158 ghc-options: -threaded

163159

164160 build-depends: vty,

@@ -170,7 +166,6 @@ executable vty-demo

170166

171167test-suite verify-using-mock-terminal

172168 default-language: Haskell2010

173− default-extensions: ScopedTypeVariables

174169

175170 type: detailed-0.9

176171

@@ -203,7 +198,6 @@ test-suite verify-using-mock-terminal

203198

204199test-suite verify-terminal

205200 default-language: Haskell2010

206− default-extensions: ScopedTypeVariables

207201

208202 type: detailed-0.9

209203

@@ -236,7 +230,6 @@ test-suite verify-terminal

236230

237231test-suite verify-display-attributes

238232 default-language: Haskell2010

239− default-extensions: ScopedTypeVariables

240233

241234 type: detailed-0.9

242235

@@ -268,7 +261,6 @@ test-suite verify-display-attributes

268261

269262test-suite verify-empty-image-props

270263 default-language: Haskell2010

271− default-extensions: ScopedTypeVariables

272264

273265 type: detailed-0.9

274266

@@ -294,7 +286,6 @@ test-suite verify-empty-image-props

294286

295287test-suite verify-eval-terminfo-caps

296288 default-language: Haskell2010

297− default-extensions: ScopedTypeVariables

298289

299290 type: detailed-0.9

300291

@@ -323,7 +314,6 @@ test-suite verify-eval-terminfo-caps

323314

324315test-suite verify-image-ops

325316 default-language: Haskell2010

326− default-extensions: ScopedTypeVariables

327317

328318 type: detailed-0.9

329319

@@ -351,7 +341,6 @@ test-suite verify-image-ops

351341

352342test-suite verify-image-trans

353343 default-language: Haskell2010

354− default-extensions: ScopedTypeVariables

355344

356345 type: detailed-0.9

357346

@@ -379,7 +368,6 @@ test-suite verify-image-trans

379368

380369test-suite verify-inline

381370 default-language: Haskell2010

382− default-extensions: ScopedTypeVariables

383371

384372 type: detailed-0.9

385373

@@ -406,7 +394,6 @@ test-suite verify-inline

406394

407395test-suite verify-parse-terminfo-caps

408396 default-language: Haskell2010

409− default-extensions: ScopedTypeVariables

410397

411398 type: detailed-0.9

412399

@@ -435,7 +422,6 @@ test-suite verify-parse-terminfo-caps

435422

436423test-suite verify-simple-span-generation

437424 default-language: Haskell2010

438− default-extensions: ScopedTypeVariables

439425

440426 type: detailed-0.9

441427

@@ -467,7 +453,6 @@ test-suite verify-simple-span-generation

467453

468454test-suite verify-crop-span-generation

469455 default-language: Haskell2010

470− default-extensions: ScopedTypeVariables

471456

472457 type: detailed-0.9

473458

@@ -499,7 +484,6 @@ test-suite verify-crop-span-generation

499484

500485test-suite verify-layers-span-generation

501486 default-language: Haskell2010

502− default-extensions: ScopedTypeVariables

503487

504488 type: detailed-0.9

505489

@@ -530,7 +514,6 @@ test-suite verify-layers-span-generation

530514

531515test-suite verify-color-mapping

532516 default-language: Haskell2010

533− default-extensions: ScopedTypeVariables

534517

535518 type: detailed-0.9

536519

@@ -556,7 +539,6 @@ test-suite verify-color-mapping

556539

557540test-suite verify-utf8-width

558541 default-language: Haskell2010

559− default-extensions: ScopedTypeVariables

560542

561543 type: detailed-0.9

562544

@@ -582,7 +564,6 @@ test-suite verify-utf8-width

582564

583565test-suite verify-using-mock-input

584566 default-language: Haskell2010

585− default-extensions: ScopedTypeVariables

586567

587568 type: exitcode-stdio-1.0

588569

@@ -590,6 +571,8 @@ test-suite verify-using-mock-input

590571

591572 main-is: VerifyUsingMockInput.hs

592573

574+ other-modules: Verify.Graphics.Vty.Output

575+

593576 build-depends: vty,

594577 Cabal >= 1.20,

595578 QuickCheck >= 2.7,

@@ -616,7 +599,6 @@ test-suite verify-using-mock-input

616599

617600test-suite verify-config

618601 default-language: Haskell2010

619− default-extensions: ScopedTypeVariables

620602

621603 type: exitcode-stdio-1.0

622604