0d2226c..master · vty · git.iko.soy

CHANGELOG.md+152

since splitsnapshots

unifiedsplit

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

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+

85+5.32

86+----

87+

88+New features:

89+ * Meta-PageUp and Meta-PageDown are now supported (#193)

90+ * Added `supportsItalics` and `supportsStrikethrough` functions to

91+ check for feature support in terminfo

92+

93+Bug fixes:

94+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka

95+ Nkurumeh)

96+

97+5.31

98+----

99+

100+New features and API changes:

101+ * Added support for strikethrough mode. This change adds a new

102+ `strikethrough` `Style` value and uses the `smxx` and `rmxx`

103+ Terminfo capabilities to activate and deactivate strikethrough mode,

104+ respectively. If the terminfo does not report those capabilities,

105+ this style is ignored.

106+ * `Output`: added the `setDisplayBounds` field to set the output

107+ dimensions of the output handle; added an implementation of this for

108+ the `TerminfoBased` backend.

109+

110+Other changes:

111+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.

112+

113+5.30

114+----

115+

116+New features:

117+ * Added `Graphics.Vty.setWindowTitle` to emit an escape

118+ sequence to set the window title, provide the terminal emulator

119+ accepts Xterm-style title sequences. For details, see:

120+ https://tldp.org/HOWTO/Xterm-Title-3.html

121+

122+5.29

123+----

124+

125+API changes:

126+ * The Input type got a new field, 'restoreInputState'. This field

127+ allows the end user to have direct access to the logic needed to

128+ restore the terminal's input state flags. Prior to having this field,

129+ this state restoration logic could only be invoked as part of calling

130+ 'shutdownInput', but since that function does other things (like

131+ killing threads) it is not advisable to call it repeatedly (which is

132+ necessary in the use case this change is intended to support). This

133+ can be called directly to restore the input state flags as needed,

134+ although this is not required if 'shutdown' (or 'shutdownInput') is

135+ called.

136+

137+Other changes:

138+ * attributeControl: explicitly enable the ICRNL terminal mode flag (see

139+ #187 and c572ad).

140+

141+5.28.2

142+------

143+

144+Bug fixes:

145+ * Added a package dependency on `semigroups` for the

146+ `vty-build-width-table` tool on older GHCs (#185)

147+

148+5.28.1

149+------

150+

151+Bug fixes:

152+ * `installUnicodeWidthTable`: use `throwIO`, not `throw`

153+

25.28

1545.28

3----

155----

4

156

LICENSE+2

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

1+BSD 3-Clause License

2+

1Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009

3Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009

2

4

3All rights reserved.

5All rights reserved.

cbits/gwinsz.c+14−5

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

1#include <sys/ioctl.h>

2

3unsigned long vty_c_get_window_size(int fd) {

4− struct winsize w;

4+ struct winsize w;

5− if (ioctl (fd, TIOCGWINSZ, &w) >= 0)

5+ if (ioctl (fd, TIOCGWINSZ, &w) >= 0)

6− return (w.ws_row << 16) + w.ws_col;

6+ return (w.ws_row << 16) + w.ws_col;

7− else

7+ else

8− return 0x190050;

8+ return 0x190050;

9+}

10+

11+void vty_c_set_window_size(int fd, unsigned long val) {

12+ struct winsize w;

13+ if (ioctl(fd, TIOCGWINSZ, &w) >= 0) {

14+ w.ws_row = val >> 16;

15+ w.ws_col = val & 0xFFFF;

16+ ioctl(fd, TIOCSWINSZ, &w);

17+ }

9}

18}

cbits/gwinsz.h+2−1

@@ -1 +1,2 @@

1−unsigned long vty_c_get_window_size(void);

1+unsigned long vty_c_get_window_size(int fd);

2+unsigned long vty_c_set_window_size(int fd, unsigned long val);

demos/Demo.hs+12−4

@@ -31,7 +31,8 @@ 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 pallete."

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

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

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

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

36 , "claims 240 colors are not supported."

37 , "claims 240 colors are not supported."

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

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

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

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

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

43 ]

44 ]

44

45

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+

45colorbox_240 :: Image

55colorbox_240 :: Image

46colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

56colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages

47 where

57 where

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

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

49− splitColorImages [] = []

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

51

59

52colorbox_16 :: Image

60colorbox_16 :: Image

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

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

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

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

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

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

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

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

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

74 vty <- ask

82 vty <- ask

75 liftIO $ update vty pic

83 liftIO $ update vty pic

76

84

src/Codec/Binary/UTF8/Debug.hs+1−2

@@ -14,5 +14,4 @@ utf8FromIso :: [Int] -> [Word8]

14utf8FromIso = encode . map toEnum

15

16ppUtf8 :: [Int] -> IO ()

17−ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso

17+ppUtf8 = print . map (`showHex` "") . utf8FromIso

18−

src/Data/Sequence/Extra.hs+1−1

@@ -7,7 +7,7 @@ import Data.Sequence

7import Control.Parallel.Strategies

8

9instance NFData a => NFData (Seq a) where

10− rnf = \v -> rnf' (viewl v)

10+ rnf = rnf' . viewl

11 where

12 rnf' EmptyL = ()

13 rnf' (a :< r) = rnf a >| rnf' (viewl r)

src/Data/Terminfo/Eval.hs+3−3

@@ -42,7 +42,7 @@ pop = do

42

43readParam :: Word -> Eval CapParam

44readParam pn = do

45− !params <- get >>= return . evalParams

45+ !params <- evalParams <$> get

46 return $! genericIndex params pn

47

48push :: CapParam -> Eval ()

@@ -64,11 +64,11 @@ writeCapExpr cap params =

64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)

65

66writeCapOps :: CapOps -> Eval ()

67−writeCapOps ops = mapM_ writeCapOp ops

67+writeCapOps = mapM_ writeCapOp

68

69writeCapOp :: CapOp -> Eval ()

70writeCapOp (Bytes !offset !count) = do

71− !cap <- get >>= return . evalExpression

71+ !cap <- evalExpression <$> get

72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap)

73 Vector.forM_ bytes $ tell.writeWord8

74writeCapOp DecOut = do

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

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

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

3−{-# OPTIONS_HADDOCK hide #-}

4{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

5−{-# LANGUAGE NamedFieldPuns #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

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

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

6+{-# OPTIONS_HADDOCK hide #-}

7

8module Data.Terminfo.Parse

9 ( module Data.Terminfo.Parse

@@ -39,7 +39,7 @@ instance Show CapExpression where

39 ++ " <= " ++ show (sourceString c)

40 where

41 hexDump :: [Word8] -> String

42− hexDump = foldr (\b s -> showHex b s) ""

42+ hexDump = foldr showHex ""

43

44instance NFData CapExpression where

45 rnf (CapExpression ops !_bytes !str !c !pOps)

@@ -99,7 +99,7 @@ parseCapExpression capString =

99 Left e -> Left e

100 Right buildResults -> Right $ constructCapExpression capString buildResults

101

102−constructCapExpression :: [Char] -> BuildResults -> CapExpression

102+constructCapExpression :: String -> BuildResults -> CapExpression

103constructCapExpression capString buildResults =

104 let expr = CapExpression

105 { capOps = outCapOps buildResults

@@ -128,7 +128,7 @@ paramEscapeParser = do

128literalPercentParser :: CapParser BuildResults

129literalPercentParser = do

130 _ <- char '%'

131− startOffset <- getState >>= return . nextOffset

131+ startOffset <- nextOffset <$> getState

132 incOffset 1

133 return $ BuildResults 0 [Bytes startOffset 1] []

134

@@ -154,7 +154,7 @@ incrementOpParser = do

154pushOpParser :: CapParser BuildResults

155pushOpParser = do

156 _ <- char 'p'

157− paramN <- digit >>= return . (\d -> read [d])

157+ paramN <- read . pure <$> digit

158 incOffset 2

159 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []

160

@@ -299,7 +299,7 @@ compareOpParser

299bytesOpParser :: CapParser BuildResults

300bytesOpParser = do

301 bytes <- many1 $ satisfy (/= '%')

302− startOffset <- getState >>= return . nextOffset

302+ startOffset <- nextOffset <$> getState

303 let !c = length bytes

304 !s <- getState

305 let s' = s { nextOffset = startOffset + c }

@@ -336,9 +336,9 @@ data BuildResults = BuildResults

336instance Semigroup BuildResults where

337 v0 <> v1

338 = BuildResults

339− { outParamCount = (outParamCount v0) `max` (outParamCount v1)

339+ { outParamCount = outParamCount v0 `max` outParamCount v1

340− , outCapOps = (outCapOps v0) <> (outCapOps v1)

340+ , outCapOps = outCapOps v0 <> outCapOps v1

341− , outParamOps = (outParamOps v0) <> (outParamOps v1)

341+ , outParamOps = outParamOps v0 <> outParamOps v1

342 }

343

344instance Monoid BuildResults where

src/Graphics/Vty.hs+39−10

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

2

3

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

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

4-- output.

5-- output.

@@ -33,6 +34,7 @@

33module Graphics.Vty

34module Graphics.Vty

34 ( Vty(..)

35 ( Vty(..)

35 , mkVty

36 , mkVty

37+ , setWindowTitle

36 , Mode(..)

38 , Mode(..)

37 , module Graphics.Vty.Config

39 , module Graphics.Vty.Config

38 , module Graphics.Vty.Input

40 , module Graphics.Vty.Input

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

46

48

47import Graphics.Vty.Config

49import Graphics.Vty.Config

48import Graphics.Vty.Input

50import Graphics.Vty.Input

51+import Graphics.Vty.Input.Events

49import Graphics.Vty.Output

52import Graphics.Vty.Output

50import Graphics.Vty.Output.Interface

53import Graphics.Vty.Output.Interface

51import Graphics.Vty.Picture

54import Graphics.Vty.Picture

@@ -54,6 +57,9 @@ import Graphics.Vty.Attributes

54import Graphics.Vty.UnicodeWidthTable.IO

57import Graphics.Vty.UnicodeWidthTable.IO

55import Graphics.Vty.UnicodeWidthTable.Install

58import Graphics.Vty.UnicodeWidthTable.Install

56

59

60+import Data.Char (isPrint, showLitChar)

61+import qualified Data.ByteString.Char8 as BS8

62+

57import qualified Control.Exception as E

63import qualified Control.Exception as E

58import Control.Monad (when)

64import Control.Monad (when)

59import Control.Concurrent.STM

65import Control.Concurrent.STM

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

162internalMkVty input out = do

168internalMkVty input out = do

163 reserveDisplay out

169 reserveDisplay out

164

170

165− shutdownVar <- atomically $ newTVar False

171+ shutdownVar <- newTVarIO False

166 let shutdownIo = do

172 let shutdownIo = do

167 alreadyShutdown <- atomically $ swapTVar shutdownVar True

173 alreadyShutdown <- atomically $ swapTVar shutdownVar True

168 when (not alreadyShutdown) $ do

174 when (not alreadyShutdown) $ do

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

170 releaseDisplay out

176 releaseDisplay out

171 releaseTerminal out

177 releaseTerminal out

172

178

173− let shutdownStatus = atomically $ readTVar shutdownVar

179+ let shutdownStatus = readTVarIO shutdownVar

174

180

175 lastPicRef <- newIORef Nothing

181 lastPicRef <- newIORef Nothing

176 lastUpdateRef <- newIORef Nothing

182 lastUpdateRef <- newIORef Nothing

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

204 maybe (return ()) innerUpdate mPic

210 maybe (return ()) innerUpdate mPic

205

211

206 let mkResize = uncurry EvResize <$> displayBounds out

212 let mkResize = uncurry EvResize <$> displayBounds out

213+

214+ translateInternalEvent ResumeAfterSignal = mkResize

215+ translateInternalEvent (InputEvent e) = return e

216+

207 gkey = do

217 gkey = do

208− k <- atomically $ readTChan $ _eventChannel input

218+ e <- atomically $ readTChan $ _eventChannel input

209− case k of

219+ translateInternalEvent e

210− (EvResize _ _) -> mkResize

211− _ -> return k

212 gkey' = do

220 gkey' = do

213− k <- atomically $ tryReadTChan $ _eventChannel input

221+ mEv <- atomically $ tryReadTChan $ _eventChannel input

214− case k of

222+ case mEv of

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

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

216− _ -> return k

224+ Nothing -> return Nothing

217

225

218 return $ Vty { update = innerUpdate

226 return $ Vty { update = innerUpdate

219 , nextEvent = gkey

227 , nextEvent = gkey

@@ -224,3 +232,24 @@ internalMkVty input out = do

224 , shutdown = shutdownIo

232 , shutdown = shutdownIo

225 , isShutdown = shutdownStatus

233 , isShutdown = shutdownStatus

226 }

234 }

235+

236+-- | Set the terminal window title string.

237+--

238+-- This function emits an Xterm-compatible escape sequence that we

239+-- anticipate will work for essentially all modern terminal emulators.

240+-- Ideally we'd use a terminal capability for this, but there does not

241+-- seem to exist a termcap for setting window titles. If you find that

242+-- this function does not work for a given terminal emulator, please

243+-- report the issue.

244+--

245+-- For details, see:

246+--

247+-- https://tldp.org/HOWTO/Xterm-Title-3.html

248+setWindowTitle :: Vty -> String -> IO ()

249+setWindowTitle vty title = do

250+ let sanitize :: String -> String

251+ sanitize = concatMap sanitizeChar

252+ sanitizeChar c | not (isPrint c) = showLitChar c ""

253+ | otherwise = [c]

254+ let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007"

255+ outputByteBuffer (outputIface vty) buf

src/Graphics/Vty/Attributes.hs+8−46

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE StandaloneDeriving #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

6{-# LANGUAGE DeriveAnyClass #-}

3{-# LANGUAGE DeriveAnyClass #-}

7

4

@@ -43,6 +40,7 @@ module Graphics.Vty.Attributes

43 , withStyle

40 , withStyle

44 , standout

41 , standout

45 , italic

42 , italic

43+ , strikethrough

46 , underline

44 , underline

47 , reverseVideo

45 , reverseVideo

48 , blink

46 , blink

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

63

61

64import Control.DeepSeq

62import Control.DeepSeq

65import Data.Bits

63import Data.Bits

66−#if !(MIN_VERSION_base(4,11,0))

67−import Data.Semigroup

68−#endif

69import Data.Text (Text)

64import Data.Text (Text)

70import Data.Word

65import Data.Word

71import GHC.Generics

66import GHC.Generics

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

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

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

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

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

120

115

121−instance Semigroup Attr where

122− attr0 <> attr1 =

123− Attr ( attrStyle attr0 <> attrStyle attr1 )

124− ( attrForeColor attr0 <> attrForeColor attr1 )

125− ( attrBackColor attr0 <> attrBackColor attr1 )

126− ( attrURL attr0 <> attrURL attr1 )

127−

128−instance Monoid Attr where

129− mempty = Attr mempty mempty mempty mempty

130−#if !(MIN_VERSION_base(4,11,0))

131− mappend = (<>)

132−#endif

133−

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

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

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

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

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

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

@@ -145,43 +127,20 @@ data FixedAttr = FixedAttr

145-- | The style and color attributes can either be the terminal defaults.

127-- | The style and color attributes can either be the terminal defaults.

146-- Or be equivalent to the previously applied style. Or be a specific

128-- Or be equivalent to the previously applied style. Or be a specific

147-- value.

129-- value.

148−data MaybeDefault v where

130+data MaybeDefault v = Default | KeepCurrent | SetTo !v

149− Default :: MaybeDefault v

131+ deriving (Eq, Read, Show)

150− KeepCurrent :: MaybeDefault v

151− SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v

152

132

153instance (NFData v) => NFData (MaybeDefault v) where

133instance (NFData v) => NFData (MaybeDefault v) where

154 rnf Default = ()

134 rnf Default = ()

155 rnf KeepCurrent = ()

135 rnf KeepCurrent = ()

156 rnf (SetTo v) = rnf v

136 rnf (SetTo v) = rnf v

157

137

158−deriving instance Eq v => Eq (MaybeDefault v)

159−deriving instance Eq v => Show (MaybeDefault v)

160−deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)

161−

162−instance Eq v => Semigroup (MaybeDefault v) where

163− Default <> Default = Default

164− Default <> KeepCurrent = Default

165− Default <> SetTo v = SetTo v

166− KeepCurrent <> Default = Default

167− KeepCurrent <> KeepCurrent = KeepCurrent

168− KeepCurrent <> SetTo v = SetTo v

169− SetTo _v <> Default = Default

170− SetTo v <> KeepCurrent = SetTo v

171− SetTo _ <> SetTo v = SetTo v

172−

173−instance Eq v => Monoid ( MaybeDefault v ) where

174− mempty = KeepCurrent

175−#if !(MIN_VERSION_base(4,11,0))

176− mappend = (<>)

177−#endif

178−

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

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

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

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

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

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

182type Style = Word8

141type Style = Word8

183

142

184−-- | The 7 possible style attributes:

143+-- | Valid style attributes include:

185--

144--

186-- * standout

145-- * standout

187--

146--

@@ -197,9 +156,11 @@ type Style = Word8

197--

156--

198-- * italic

157-- * italic

199--

158--

159+-- * strikethrough (via the smxx/rmxx terminfo capabilities)

160+--

200-- (The invisible, protect, and altcharset display attributes some

161-- (The invisible, protect, and altcharset display attributes some

201-- terminals support are not supported via VTY.)

162-- terminals support are not supported via VTY.)

202−standout, underline, reverseVideo, blink, dim, bold, italic :: Style

163+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style

203standout = 0x01

164standout = 0x01

204underline = 0x02

165underline = 0x02

205reverseVideo = 0x04

166reverseVideo = 0x04

@@ -207,6 +168,7 @@ blink = 0x08

207dim = 0x10

168dim = 0x10

208bold = 0x20

169bold = 0x20

209italic = 0x40

170italic = 0x40

171+strikethrough = 0x80

210

172

211defaultStyleMask :: Style

173defaultStyleMask :: Style

212defaultStyleMask = 0x00

174defaultStyleMask = 0x00

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

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

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveAnyClass #-}

3+{-# LANGUAGE MultiWayIf #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

3

5

4module Graphics.Vty.Attributes.Color

6module Graphics.Vty.Attributes.Color

5 ( Color(..)

7 ( Color(..)

8+ , ColorMode(..)

9+

10+ -- * Detecting Terminal Color Support

11+ , detectColorMode

6

12

7 -- ** Fixed Colors

13 -- ** Fixed Colors

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

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

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

32 , brightCyan

38 , brightCyan

33 , brightWhite

39 , brightWhite

34 -- ** Creating Colors From RGB

40 -- ** Creating Colors From RGB

41+ , linearColor

42+ , srgbColor

35 , rgbColor

43 , rgbColor

44+ , color240

36 , module Graphics.Vty.Attributes.Color240

45 , module Graphics.Vty.Attributes.Color240

37 )

46 )

38where

47where

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

40import Data.Word

49import Data.Word

41import GHC.Generics

50import GHC.Generics

42import Control.DeepSeq

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

43

57

44import Graphics.Vty.Attributes.Color240

58import Graphics.Vty.Attributes.Color240

45

59

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

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

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

82--

96--

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

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

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

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

86-- addressable via the 240 color palette.

100-- addressable via the 240 color palette.

87--

101--

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

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

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

96--

110--

97-- Seriously, terminal color support is INSANE.

111-- Seriously, terminal color support is INSANE.

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

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

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

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

100

114

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+

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

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

102black = ISOColor 0

140black = ISOColor 0

103red = ISOColor 1

141red = ISOColor 1

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

119brightCyan = ISOColor 14

157brightCyan = ISOColor 14

120brightWhite = ISOColor 15

158brightWhite = ISOColor 15

121

159

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)

122

186

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

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

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

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

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

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

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

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

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

191+rgbColor = color240

src/Graphics/Vty/Attributes/Color240.hs+10−218

@@ -39,226 +39,18 @@ rgbColorToColor240 r g b

39 | r == 218 && g == 218 && b == 218 = 237

40 | r == 228 && g == 228 && b == 228 = 238

41 | r == 238 && g == 238 && b == 238 = 239

42− | r <= 0 && g <= 0 && b <= 0 = 0

42+ | otherwise = 36 * go r + 6 * go g + go b

43− | r <= 0 && g <= 0 && b <= 95 = 1

43+ where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."

44− | r <= 0 && g <= 0 && b <= 135 = 2

45− | r <= 0 && g <= 0 && b <= 175 = 3

46− | r <= 0 && g <= 0 && b <= 215 = 4

47− | r <= 0 && g <= 0 && b <= 255 = 5

48− | r <= 0 && g <= 95 && b <= 0 = 6

49− | r <= 0 && g <= 95 && b <= 95 = 7

50− | r <= 0 && g <= 95 && b <= 135 = 8

51− | r <= 0 && g <= 95 && b <= 175 = 9

52− | r <= 0 && g <= 95 && b <= 215 = 10

53− | r <= 0 && g <= 95 && b <= 255 = 11

54− | r <= 0 && g <= 135 && b <= 0 = 12

55− | r <= 0 && g <= 135 && b <= 95 = 13

56− | r <= 0 && g <= 135 && b <= 135 = 14

57− | r <= 0 && g <= 135 && b <= 175 = 15

58− | r <= 0 && g <= 135 && b <= 215 = 16

59− | r <= 0 && g <= 135 && b <= 255 = 17

60− | r <= 0 && g <= 175 && b <= 0 = 18

61− | r <= 0 && g <= 175 && b <= 95 = 19

62− | r <= 0 && g <= 175 && b <= 135 = 20

63− | r <= 0 && g <= 175 && b <= 175 = 21

64− | r <= 0 && g <= 175 && b <= 215 = 22

65− | r <= 0 && g <= 175 && b <= 255 = 23

66− | r <= 0 && g <= 215 && b <= 0 = 24

67− | r <= 0 && g <= 215 && b <= 95 = 25

68− | r <= 0 && g <= 215 && b <= 135 = 26

69− | r <= 0 && g <= 215 && b <= 175 = 27

70− | r <= 0 && g <= 215 && b <= 215 = 28

71− | r <= 0 && g <= 215 && b <= 255 = 29

72− | r <= 0 && g <= 255 && b <= 0 = 30

73− | r <= 0 && g <= 255 && b <= 95 = 31

74− | r <= 0 && g <= 255 && b <= 135 = 32

75− | r <= 0 && g <= 255 && b <= 175 = 33

76− | r <= 0 && g <= 255 && b <= 215 = 34

77− | r <= 0 && g <= 255 && b <= 255 = 35

78− | r <= 95 && g <= 0 && b <= 0 = 36

79− | r <= 95 && g <= 0 && b <= 95 = 37

80− | r <= 95 && g <= 0 && b <= 135 = 38

81− | r <= 95 && g <= 0 && b <= 175 = 39

82− | r <= 95 && g <= 0 && b <= 215 = 40

83− | r <= 95 && g <= 0 && b <= 255 = 41

84− | r <= 95 && g <= 95 && b <= 0 = 42

85− | r <= 95 && g <= 95 && b <= 95 = 43

86− | r <= 95 && g <= 95 && b <= 135 = 44

87− | r <= 95 && g <= 95 && b <= 175 = 45

88− | r <= 95 && g <= 95 && b <= 215 = 46

89− | r <= 95 && g <= 95 && b <= 255 = 47

90− | r <= 95 && g <= 135 && b <= 0 = 48

91− | r <= 95 && g <= 135 && b <= 95 = 49

92− | r <= 95 && g <= 135 && b <= 135 = 50

93− | r <= 95 && g <= 135 && b <= 175 = 51

94− | r <= 95 && g <= 135 && b <= 215 = 52

95− | r <= 95 && g <= 135 && b <= 255 = 53

96− | r <= 95 && g <= 175 && b <= 0 = 54

97− | r <= 95 && g <= 175 && b <= 95 = 55

98− | r <= 95 && g <= 175 && b <= 135 = 56

99− | r <= 95 && g <= 175 && b <= 175 = 57

100− | r <= 95 && g <= 175 && b <= 215 = 58

101− | r <= 95 && g <= 175 && b <= 255 = 59

102− | r <= 95 && g <= 215 && b <= 0 = 60

103− | r <= 95 && g <= 215 && b <= 95 = 61

104− | r <= 95 && g <= 215 && b <= 135 = 62

105− | r <= 95 && g <= 215 && b <= 175 = 63

106− | r <= 95 && g <= 215 && b <= 215 = 64

107− | r <= 95 && g <= 215 && b <= 255 = 65

108− | r <= 95 && g <= 255 && b <= 0 = 66

109− | r <= 95 && g <= 255 && b <= 95 = 67

110− | r <= 95 && g <= 255 && b <= 135 = 68

111− | r <= 95 && g <= 255 && b <= 175 = 69

112− | r <= 95 && g <= 255 && b <= 215 = 70

113− | r <= 95 && g <= 255 && b <= 255 = 71

114− | r <= 135 && g <= 0 && b <= 0 = 72

115− | r <= 135 && g <= 0 && b <= 95 = 73

116− | r <= 135 && g <= 0 && b <= 135 = 74

117− | r <= 135 && g <= 0 && b <= 175 = 75

118− | r <= 135 && g <= 0 && b <= 215 = 76

119− | r <= 135 && g <= 0 && b <= 255 = 77

120− | r <= 135 && g <= 95 && b <= 0 = 78

121− | r <= 135 && g <= 95 && b <= 95 = 79

122− | r <= 135 && g <= 95 && b <= 135 = 80

123− | r <= 135 && g <= 95 && b <= 175 = 81

124− | r <= 135 && g <= 95 && b <= 215 = 82

125− | r <= 135 && g <= 95 && b <= 255 = 83

126− | r <= 135 && g <= 135 && b <= 0 = 84

127− | r <= 135 && g <= 135 && b <= 95 = 85

128− | r <= 135 && g <= 135 && b <= 135 = 86

129− | r <= 135 && g <= 135 && b <= 175 = 87

130− | r <= 135 && g <= 135 && b <= 215 = 88

131− | r <= 135 && g <= 135 && b <= 255 = 89

132− | r <= 135 && g <= 175 && b <= 0 = 90

133− | r <= 135 && g <= 175 && b <= 95 = 91

134− | r <= 135 && g <= 175 && b <= 135 = 92

135− | r <= 135 && g <= 175 && b <= 175 = 93

136− | r <= 135 && g <= 175 && b <= 215 = 94

137− | r <= 135 && g <= 175 && b <= 255 = 95

138− | r <= 135 && g <= 215 && b <= 0 = 96

139− | r <= 135 && g <= 215 && b <= 95 = 97

140− | r <= 135 && g <= 215 && b <= 135 = 98

141− | r <= 135 && g <= 215 && b <= 175 = 99

142− | r <= 135 && g <= 215 && b <= 215 = 100

143− | r <= 135 && g <= 215 && b <= 255 = 101

144− | r <= 135 && g <= 255 && b <= 0 = 102

145− | r <= 135 && g <= 255 && b <= 95 = 103

146− | r <= 135 && g <= 255 && b <= 135 = 104

147− | r <= 135 && g <= 255 && b <= 175 = 105

148− | r <= 135 && g <= 255 && b <= 215 = 106

149− | r <= 135 && g <= 255 && b <= 255 = 107

150− | r <= 175 && g <= 0 && b <= 0 = 108

151− | r <= 175 && g <= 0 && b <= 95 = 109

152− | r <= 175 && g <= 0 && b <= 135 = 110

153− | r <= 175 && g <= 0 && b <= 175 = 111

154− | r <= 175 && g <= 0 && b <= 215 = 112

155− | r <= 175 && g <= 0 && b <= 255 = 113

156− | r <= 175 && g <= 95 && b <= 0 = 114

157− | r <= 175 && g <= 95 && b <= 95 = 115

158− | r <= 175 && g <= 95 && b <= 135 = 116

159− | r <= 175 && g <= 95 && b <= 175 = 117

160− | r <= 175 && g <= 95 && b <= 215 = 118

161− | r <= 175 && g <= 95 && b <= 255 = 119

162− | r <= 175 && g <= 135 && b <= 0 = 120

163− | r <= 175 && g <= 135 && b <= 95 = 121

164− | r <= 175 && g <= 135 && b <= 135 = 122

165− | r <= 175 && g <= 135 && b <= 175 = 123

166− | r <= 175 && g <= 135 && b <= 215 = 124

167− | r <= 175 && g <= 135 && b <= 255 = 125

168− | r <= 175 && g <= 175 && b <= 0 = 126

169− | r <= 175 && g <= 175 && b <= 95 = 127

170− | r <= 175 && g <= 175 && b <= 135 = 128

171− | r <= 175 && g <= 175 && b <= 175 = 129

172− | r <= 175 && g <= 175 && b <= 215 = 130

173− | r <= 175 && g <= 175 && b <= 255 = 131

174− | r <= 175 && g <= 215 && b <= 0 = 132

175− | r <= 175 && g <= 215 && b <= 95 = 133

176− | r <= 175 && g <= 215 && b <= 135 = 134

177− | r <= 175 && g <= 215 && b <= 175 = 135

178− | r <= 175 && g <= 215 && b <= 215 = 136

179− | r <= 175 && g <= 215 && b <= 255 = 137

180− | r <= 175 && g <= 255 && b <= 0 = 138

181− | r <= 175 && g <= 255 && b <= 95 = 139

182− | r <= 175 && g <= 255 && b <= 135 = 140

183− | r <= 175 && g <= 255 && b <= 175 = 141

184− | r <= 175 && g <= 255 && b <= 215 = 142

185− | r <= 175 && g <= 255 && b <= 255 = 143

186− | r <= 215 && g <= 0 && b <= 0 = 144

187− | r <= 215 && g <= 0 && b <= 95 = 145

188− | r <= 215 && g <= 0 && b <= 135 = 146

189− | r <= 215 && g <= 0 && b <= 175 = 147

190− | r <= 215 && g <= 0 && b <= 215 = 148

191− | r <= 215 && g <= 0 && b <= 255 = 149

192− | r <= 215 && g <= 95 && b <= 0 = 150

193− | r <= 215 && g <= 95 && b <= 95 = 151

194− | r <= 215 && g <= 95 && b <= 135 = 152

195− | r <= 215 && g <= 95 && b <= 175 = 153

196− | r <= 215 && g <= 95 && b <= 215 = 154

197− | r <= 215 && g <= 95 && b <= 255 = 155

198− | r <= 215 && g <= 135 && b <= 0 = 156

199− | r <= 215 && g <= 135 && b <= 95 = 157

200− | r <= 215 && g <= 135 && b <= 135 = 158

201− | r <= 215 && g <= 135 && b <= 175 = 159

202− | r <= 215 && g <= 135 && b <= 215 = 160

203− | r <= 215 && g <= 135 && b <= 255 = 161

204− | r <= 215 && g <= 175 && b <= 0 = 162

205− | r <= 215 && g <= 175 && b <= 95 = 163

206− | r <= 215 && g <= 175 && b <= 135 = 164

207− | r <= 215 && g <= 175 && b <= 175 = 165

208− | r <= 215 && g <= 175 && b <= 215 = 166

209− | r <= 215 && g <= 175 && b <= 255 = 167

210− | r <= 215 && g <= 215 && b <= 0 = 168

211− | r <= 215 && g <= 215 && b <= 95 = 169

212− | r <= 215 && g <= 215 && b <= 135 = 170

213− | r <= 215 && g <= 215 && b <= 175 = 171

214− | r <= 215 && g <= 215 && b <= 215 = 172

215− | r <= 215 && g <= 215 && b <= 255 = 173

216− | r <= 215 && g <= 255 && b <= 0 = 174

217− | r <= 215 && g <= 255 && b <= 95 = 175

218− | r <= 215 && g <= 255 && b <= 135 = 176

219− | r <= 215 && g <= 255 && b <= 175 = 177

220− | r <= 215 && g <= 255 && b <= 215 = 178

221− | r <= 215 && g <= 255 && b <= 255 = 179

222− | r <= 255 && g <= 0 && b <= 0 = 180

223− | r <= 255 && g <= 0 && b <= 95 = 181

224− | r <= 255 && g <= 0 && b <= 135 = 182

225− | r <= 255 && g <= 0 && b <= 175 = 183

226− | r <= 255 && g <= 0 && b <= 215 = 184

227− | r <= 255 && g <= 0 && b <= 255 = 185

228− | r <= 255 && g <= 95 && b <= 0 = 186

229− | r <= 255 && g <= 95 && b <= 95 = 187

230− | r <= 255 && g <= 95 && b <= 135 = 188

231− | r <= 255 && g <= 95 && b <= 175 = 189

232− | r <= 255 && g <= 95 && b <= 215 = 190

233− | r <= 255 && g <= 95 && b <= 255 = 191

234− | r <= 255 && g <= 135 && b <= 0 = 192

235− | r <= 255 && g <= 135 && b <= 95 = 193

236− | r <= 255 && g <= 135 && b <= 135 = 194

237− | r <= 255 && g <= 135 && b <= 175 = 195

238− | r <= 255 && g <= 135 && b <= 215 = 196

239− | r <= 255 && g <= 135 && b <= 255 = 197

240− | r <= 255 && g <= 175 && b <= 0 = 198

241− | r <= 255 && g <= 175 && b <= 95 = 199

242− | r <= 255 && g <= 175 && b <= 135 = 200

243− | r <= 255 && g <= 175 && b <= 175 = 201

244− | r <= 255 && g <= 175 && b <= 215 = 202

245− | r <= 255 && g <= 175 && b <= 255 = 203

246− | r <= 255 && g <= 215 && b <= 0 = 204

247− | r <= 255 && g <= 215 && b <= 95 = 205

248− | r <= 255 && g <= 215 && b <= 135 = 206

249− | r <= 255 && g <= 215 && b <= 175 = 207

250− | r <= 255 && g <= 215 && b <= 215 = 208

251− | r <= 255 && g <= 215 && b <= 255 = 209

252− | r <= 255 && g <= 255 && b <= 0 = 210

253− | r <= 255 && g <= 255 && b <= 95 = 211

254− | r <= 255 && g <= 255 && b <= 135 = 212

255− | r <= 255 && g <= 255 && b <= 175 = 213

256− | r <= 255 && g <= 255 && b <= 215 = 214

257− | r <= 255 && g <= 255 && b <= 255 = 215

258− | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."

259 (fromIntegral r :: Int)

44 (fromIntegral r :: Int)

260 (fromIntegral g :: Int)

45 (fromIntegral g :: Int)

261− (fromIntegral b :: Int))

46+ (fromIntegral b :: Int)))

47+

48+simpleColor_ :: Integral i => Word8 -> i -> Word8

49+simpleColor_ e c

50+ | c <= 0 = 0

51+ | c <= 95 = 1

52+ | c <= 255 = fromIntegral ((c-16) `div` 40)

53+ | otherwise = e

262

54

263-- | Create a RGB triple from a value in the Color240 set.

55-- | Create a RGB triple from a value in the Color240 set.

264color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)

56color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)

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

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

3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE ScopedTypeVariables #-}

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

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

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

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

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

8-- application's use of Vty.

9-- application's use of Vty.

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

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

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

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

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

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

57-- 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@.

58--

59--

59-- = Unicode Character Width Maps

60-- = Unicode Character Width Maps

60--

61--

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

122import Data.Typeable (Typeable)

123import Data.Typeable (Typeable)

123

124

124import Graphics.Vty.Input.Events

125import Graphics.Vty.Input.Events

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

125

127

126import GHC.Generics

128import GHC.Generics

127

129

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

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

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

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

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

195 -- will be used.

197 -- will be used.

198+ , colorMode :: Maybe ColorMode

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

200+ -- supports.

196 }

201 }

197 deriving (Show, Eq)

202 deriving (Show, Eq)

198

203

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

214 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

219 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0

215 , allowCustomUnicodeWidthTables =

220 , allowCustomUnicodeWidthTables =

216 allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

221 allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0

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

217 }

223 }

218

224

219instance Monoid Config where

225instance Monoid Config where

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

229 , termName = Nothing

235 , termName = Nothing

230 , termWidthMaps = []

236 , termWidthMaps = []

231 , allowCustomUnicodeWidthTables = Nothing

237 , allowCustomUnicodeWidthTables = Nothing

238+ , colorMode = Nothing

232 }

239 }

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

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

234 mappend = (<>)

241 mappend = (<>)

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

284 mb <- lookupEnv termVariable

291 mb <- lookupEnv termVariable

285 case mb of

292 case mb of

286 Nothing -> throwIO VtyMissingTermEnvVar

293 Nothing -> throwIO VtyMissingTermEnvVar

287− Just t ->

294+ Just t -> do

295+ mcolorMode <- detectColorMode t

288 return defaultConfig

296 return defaultConfig

289 { vmin = Just 1

297 { vmin = Just 1

290 , mouseMode = Just False

298 , mouseMode = Just False

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

293 , inputFd = Just stdInput

301 , inputFd = Just stdInput

294 , outputFd = Just stdOutput

302 , outputFd = Just stdOutput

295 , termName = Just t

303 , termName = Just t

304+ , colorMode = Just mcolorMode

296 }

305 }

297

306

298parseConfigFile :: FilePath -> IO Config

307parseConfigFile :: FilePath -> IO Config

src/Graphics/Vty/DisplayAttributes.hs+3

@@ -96,6 +96,8 @@ data StyleStateChange

96 | RemoveStandout

97 | ApplyItalic

98 | RemoveItalic

99+ | ApplyStrikethrough

100+ | RemoveStrikethrough

99 | ApplyUnderline

101 | ApplyUnderline

100 | RemoveUnderline

102 | RemoveUnderline

101 | ApplyReverseVideo

103 | ApplyReverseVideo

@@ -144,6 +146,7 @@ diffStyles prev cur

144 [ styleDiff standout ApplyStandout RemoveStandout

146 [ styleDiff standout ApplyStandout RemoveStandout

145 , styleDiff underline ApplyUnderline RemoveUnderline

147 , styleDiff underline ApplyUnderline RemoveUnderline

146 , styleDiff italic ApplyItalic RemoveItalic

148 , styleDiff italic ApplyItalic RemoveItalic

149+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough

147 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo

150 , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo

148 , styleDiff blink ApplyBlink RemoveBlink

151 , styleDiff blink ApplyBlink RemoveBlink

149 , styleDiff dim ApplyDim RemoveDim

152 , styleDiff dim ApplyDim RemoveDim

src/Graphics/Vty/Image.hs+11−10

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

2−{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE NamedFieldPuns #-}

4{-# LANGUAGE DisambiguateRecordFields #-}

3{-# LANGUAGE DisambiguateRecordFields #-}

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

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

@@ -117,14 +116,16 @@ horizCat = foldr horizJoin EmptyImage

117vertCat :: [Image] -> Image

116vertCat :: [Image] -> Image

118vertCat = foldr vertJoin EmptyImage

117vertCat = foldr vertJoin EmptyImage

119

118

120−-- | Make an 'Image' from a lazy text value. This function should not be

119+-- | Make an 'Image' from a lazy text value. The text value should be

121−-- given a text value containing escapes.

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

121+-- otherwise layout and attribute problems may result.

122text :: Attr -> TL.Text -> Image

123text a txt = let displayWidth = safeWctlwidth txt

124 in HorizText a txt displayWidth (fromIntegral $! TL.length txt)

125

126−-- | Make an 'Image' from a text value. This function should not be

126+-- | Make an 'Image' from a text value. The text value should be

127−-- given a text value containing escapes.

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

128+-- otherwise layout and attribute problems may result.

128text' :: Attr -> T.Text -> Image

129text' :: Attr -> T.Text -> Image

129text' a txt = let displayWidth = safeWctwidth txt

130text' a txt = let displayWidth = safeWctwidth txt

130 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)

131 in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)

@@ -136,10 +137,11 @@ char a c =

136 let displayWidth = safeWcwidth c

137 let displayWidth = safeWcwidth c

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

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

138

139

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

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

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

141−-- sequence of ISO-10646 characters. This function should not be given a

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

142−-- string containing escapes.

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

144+-- otherwise layout and attribute problems may result.

143--

145--

144-- Note: depending on how the Haskell compiler represents string

146-- Note: depending on how the Haskell compiler represents string

145-- literals, a string literal in a UTF-8 encoded source file, for

147-- literals, a string literal in a UTF-8 encoded source file, for

@@ -156,8 +158,7 @@ iso10646String a str =

156--

158--

157-- This is an alias for iso10646String since the usual case is that a

159-- This is an alias for iso10646String since the usual case is that a

158-- literal string like "foo" is represented internally as a list of ISO

160-- literal string like "foo" is represented internally as a list of ISO

159−-- 10646 31 bit characters. This function should not be given a string

161+-- 10646 31 bit characters.

160−-- containing escapes.

161--

162--

162-- Note: Keep in mind that GHC will compile source encoded as UTF-8

163-- Note: Keep in mind that GHC will compile source encoded as UTF-8

163-- but the literal strings, while UTF-8 encoded in the source, will be

164-- but the literal strings, while UTF-8 encoded in the source, will be

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

@@ -146,7 +146,7 @@ data Image =

146

147-- | pretty print just the structure of an image.

148ppImageStructure :: Image -> String

149−ppImageStructure inImg = go 0 inImg

149+ppImageStructure = go 0

150 where

151 go indent img = tab indent ++ pp indent img

152 tab indent = concat $ replicate indent " "

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

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

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 missmatch

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

263-- will be filled with the background pattern.

264vertJoin :: Image -> Image -> Image

265vertJoin EmptyImage i = i

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

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

1−{-# LANGUAGE BangPatterns #-}

2−

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

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

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

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

5-- used inline with other output systems.

3-- used inline with other output systems.

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

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

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

59backColor :: Color -> InlineM ()

57backColor :: Color -> InlineM ()

60backColor c = modify $ \s ->

58backColor c = modify $ \s ->

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

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

62 }

60 }

63

61

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

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

65foreColor :: Color -> InlineM ()

63foreColor :: Color -> InlineM ()

66foreColor c = modify $ \s ->

64foreColor c = modify $ \s ->

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

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

68 }

66 }

69

67

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

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

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

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

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

74applyStyle :: Style -> InlineM ()

72applyStyle :: Style -> InlineM ()

75applyStyle st = modify $ \s ->

73applyStyle st = modify $ \s ->

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

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

77 }

75 }

78

76

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

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

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

85removeStyle sMask = modify $ \s ->

83removeStyle sMask = modify $ \s ->

86 s { inlineAttr =

84 s { inlineAttr =

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

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

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

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

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

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

90 SetTo st -> st .&. complement sMask

88 SetTo st -> st .&. complement sMask

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

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

92 }

90 }

src/Graphics/Vty/Input.hs+11−22

@@ -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 unambiguiously. UTF-8 input is

80+-- * 7-bit mode: UTF-8 can be input unambiguously. 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 fundemental issues. There is no easy way

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

99-- to reliably resolve these issues.

100--

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

@@ -143,22 +143,8 @@ import Data.Monoid ((<>))

143-- bytes comes from 'classifyMapForTerm' which is then overridden by

144-- the the applicable entries from the configuration's 'inputMap'.

145--

146−-- The terminal device is configured with the attributes:

146+-- The terminal device's mode flags are configured by the

147−--

147+-- 'attributeControl' function.

148−-- * IXON disabled: disables software flow control on outgoing data.

149−-- This stops the process from being suspended if the output terminal

150−-- cannot keep up.

151−--

152−-- * Raw mode is used for input.

153−--

154−-- * ISIG disabled (enables keyboard combinations that result in

155−-- signals)

156−--

157−-- * ECHO disabled (input is not echoed to the output)

158−--

159−-- * ICANON disabled (canonical mode (line mode) input is not used)

160−--

161−-- * IEXTEN disabled (extended functions are disabled)

162inputForConfig :: Config -> IO Input

148inputForConfig :: Config -> IO Input

163inputForConfig config@Config{ termName = Just termName

149inputForConfig config@Config{ termName = Just termName

164 , inputFd = Just termFd

150 , inputFd = Just termFd

@@ -168,20 +154,23 @@ inputForConfig config@Config{ termName = Just termName

168 terminal <- Terminfo.setupTerm termName

154 terminal <- Terminfo.setupTerm termName

169 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]

155 let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]

170 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

156 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

171− (setAttrs,unsetAttrs) <- attributeControl termFd

157+ (setAttrs, unsetAttrs) <- attributeControl termFd

172 setAttrs

158 setAttrs

173 input <- initInput config activeInputMap

159 input <- initInput config activeInputMap

174 let pokeIO = Catch $ do

160 let pokeIO = Catch $ do

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

176 setAttrs

161 setAttrs

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

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

178 _ <- installHandler windowChange pokeIO Nothing

163 _ <- installHandler windowChange pokeIO Nothing

179 _ <- installHandler continueProcess pokeIO Nothing

164 _ <- installHandler continueProcess pokeIO Nothing

165+

166+ let restore = unsetAttrs

167+

180 return $ input

168 return $ input

181 { shutdownInput = do

169 { shutdownInput = do

182 shutdownInput input

170 shutdownInput input

183 _ <- installHandler windowChange Ignore Nothing

171 _ <- installHandler windowChange Ignore Nothing

184 _ <- installHandler continueProcess Ignore Nothing

172 _ <- installHandler continueProcess Ignore Nothing

185− unsetAttrs

173+ restore

174+ , restoreInputState = restoreInputState input >> restore

186 }

175 }

187inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig

176inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig

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

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

1{-# 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

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(..)

8 )

9 )

9where

10where

10

11

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

16

17

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

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

18

19

19−import Data.List (inits)

20+import Control.Arrow (first)

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

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

21import Data.Maybe ( mapMaybe )

22import Data.Maybe ( mapMaybe )

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

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

23

24

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+

27−compile :: ClassifyMap -> [Char] -> KClass

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

28compile table = cl' where

43compile table = cl' where

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

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

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

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

32− eventForInput = M.fromList table

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

33− cl' [] = Prefix

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

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

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

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

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

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

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

37− Just e -> Valid e []

52+ Just e -> Valid e BS8.empty

38 Nothing -> case S.member inputBlock prefixSet of

53 Nothing -> case S.member inputBlock prefixSet of

39 True -> Prefix

54 True -> Prefix

40 -- look up progressively smaller tails of the input

55 -- look up progressively smaller tails of the input

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

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

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

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

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

47 False ->

62 False ->

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

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

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

64 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)

51 -- neither a prefix or a full event.

66 -- neither a prefix or a full event.

52 [] -> Invalid

67 [] -> Invalid

53

68

54−classify :: ClassifyMap -> [Char] -> KClass

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

55−classify table =

70+classify table = process

71+ where

56− let standardClassifier = compile table

72+ standardClassifier = compile table

73+

74+ process ClassifierStart s =

57− in \s -> case s of

75+ case BS.uncons s of

58− _ | bracketedPasteStarted s ->

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 =

59 if bracketedPasteFinished s

86 if bracketedPasteFinished s

60− then parseBracketedPaste s

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

61− else Prefix

88+ else Chunk

62− _ | isMouseEvent s -> classifyMouseEvent s

89+ process ClassifierInChunk{} _ = Invalid

63− _ | isFocusEvent s -> classifyFocusEvent s

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

65− _ -> standardClassifier s

66

90

67−classifyUtf8 :: Char -> [Char] -> KClass

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

68classifyUtf8 c cs =

92classifyUtf8 c cs =

69− let n = utf8Length (ord c)

93+ let n = utf8Length c

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

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

71

95

72 codepoint8 :: [Word8]

96 codepoint8 :: [Word8]

73− codepoint8 = map (fromIntegral . ord) codepoint

97+ codepoint8 = c:BS.unpack codepoint

74

98

75 in case decode codepoint8 of

99 in case decode codepoint8 of

76− _ | n < length codepoint -> Prefix

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

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

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

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

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

79− Nothing -> Invalid

103+ Nothing -> Invalid

80

104

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

105+utf8Length :: Word8 -> Int

82utf8Length c

106utf8Length c

83 | c < 0x80 = 1

107 | c < 0x80 = 1

84 | c < 0xE0 = 2

108 | c < 0xE0 = 2

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

@@ -16,12 +16,15 @@ 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+

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

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

20

23

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

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

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

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

23-- remaining unparsed characters.

26-- remaining unparsed characters.

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

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

25runParser s parser =

28runParser s parser =

26 case runState (runMaybeT parser) s of

29 case runState (runMaybeT parser) s of

27 (Nothing, _) -> Invalid

30 (Nothing, _) -> Invalid

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

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

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

37readInt :: Parser Int

40readInt :: Parser Int

38readInt = do

41readInt = do

39− s <- get

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

40 case (reads :: ReadS Int) s of

43 case (reads :: ReadS Int) s of

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

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

42 _ -> failParse

45 _ -> failParse

43

46

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

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

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

46readChar :: Parser Char

49readChar :: Parser Char

47readChar = do

50readChar = do

48 s <- get

51 s <- get

49− case s of

52+ case BS8.uncons s of

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

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

51− _ -> failParse

54+ Nothing -> failParse

52

55

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

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

54-- not the specified character.

57-- not the specified character.

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

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

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

2-- cycles between other modules that need this.

3+{-# LANGUAGE StrictData #-}

3module Graphics.Vty.Input.Classify.Types

4module Graphics.Vty.Input.Classify.Types

4 ( KClass(..)

5 ( KClass(..)

5 )

6 )

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

7

8

8import Graphics.Vty.Input.Events

9import Graphics.Vty.Input.Events

9

10

11+import Data.ByteString.Char8 (ByteString)

12+

10data KClass

13data KClass

11− = Valid Event [Char]

14+ = Valid Event ByteString

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

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

13 -- stream are also provided.

16 -- stream are also provided.

14 | Invalid

17 | Invalid

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

16 | Prefix

19 | Prefix

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

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

18 -- sequence.

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

19 deriving(Show, Eq)

25 deriving(Show, Eq)

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

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

1{-# Language DeriveGeneric #-}

2+{-# Language StrictData #-}

2module Graphics.Vty.Input.Events where

3module Graphics.Vty.Input.Events where

3

4

5+import Control.DeepSeq

4import Data.ByteString

6import Data.ByteString

5import GHC.Generics

7import GHC.Generics

6

8

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

14--

16--

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

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

16-- KEnter vary by terminal and keyboard.

18-- KEnter vary by terminal and keyboard.

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

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

18 | KLeft | KRight | KUp | KDown

20 | KLeft | KRight | KUp | KDown

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

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

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

23

25

26+instance NFData Key

27+

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

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

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

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

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

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

27data Modifier = MShift | MCtrl | MMeta | MAlt

31data Modifier = MShift | MCtrl | MMeta | MAlt

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

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

29

33

34+instance NFData Modifier

35+

30-- | Mouse buttons.

36-- | Mouse buttons.

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

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

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

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

33

39

40+instance NFData Button

41+

34-- | Events.

42-- | Events.

35data Event

43data Event

36 = EvKey Key [Modifier]

44 = EvKey Key [Modifier]

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

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

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

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

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

46 | EvResize Int Int

54 | EvResize Int Int

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

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

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

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

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

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

51 | EvPaste ByteString

57 | EvPaste ByteString

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

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

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

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

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

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

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

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

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

64

70

71+instance NFData Event

72+

65type ClassifyMap = [(String,Event)]

73type 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

11import Graphics.Vty.Input.Classify.Parse

12

13import Control.Monad.State

14−import Data.List (isPrefixOf)

14+

15+import qualified Data.ByteString.Char8 as BS8

16+import Data.ByteString.Char8 (ByteString)

15

17

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

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

17-- sequences.

19-- sequences.

18−requestFocusEvents :: String

20+requestFocusEvents :: ByteString

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

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

20

22

21-- | These sequences disable focus events.

23-- | These sequences disable focus events.

22−disableFocusEvents :: String

24+disableFocusEvents :: ByteString

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

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

24

26

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

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

26−isFocusEvent :: String -> Bool

28+isFocusEvent :: ByteString -> Bool

27−isFocusEvent s = isPrefixOf focusIn s ||

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

28− isPrefixOf focusOut s

30+ BS8.isPrefixOf focusOut s

29

31

30−focusIn :: String

32+focusIn :: ByteString

31−focusIn = "\ESC[I"

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

32

34

33−focusOut :: String

35+focusOut :: ByteString

34−focusOut = "\ESC[O"

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

35

37

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

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

37−classifyFocusEvent :: String -> KClass

39+classifyFocusEvent :: ByteString -> KClass

38classifyFocusEvent s = runParser s $ do

40classifyFocusEvent s = runParser s $ do

39 when (not $ isFocusEvent s) failParse

41 when (not $ isFocusEvent s) failParse

40

42

src/Graphics/Vty/Input/Loop.hs+86−29

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

1−{-# LANGUAGE RecordWildCards #-}

1+{-# LANGUAGE CPP #-}

2−{-# OPTIONS_HADDOCK hide #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

2{-# LANGUAGE NoMonomorphismRestriction #-}

3+{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE TemplateHaskell #-}

5−{-# LANGUAGE CPP #-}

6+{-# OPTIONS_HADDOCK hide #-}

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

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

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

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

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

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

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

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

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

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

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

35

36

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)

37import Data.IORef

40import Data.IORef

38import Data.Word (Word8)

41import Data.Word (Word8)

39

42

40−import Foreign ( allocaArray, peekArray, Ptr )

43+import Foreign (allocaArray)

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

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

45+import Foreign.Ptr (Ptr, castPtr)

42

46

43import System.IO

47import System.IO

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

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

@@ -51,10 +55,15 @@ data Input = Input

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

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

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

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

53 -- is an 'EvResize'.

57 -- is an 'EvResize'.

54− _eventChannel :: TChan Event

58+ _eventChannel :: TChan InternalEvent

55− -- | Shuts down the input processing. This should return the

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

56− -- terminal input state to before he input initialized.

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

57 , shutdownInput :: IO ()

61 , shutdownInput :: IO ()

62+ -- | Restore the terminal's input state to what it was prior

63+ -- to configuring input for Vty. This should be done as part of

64+ -- 'shutdownInput' but is exposed in case you need to access it

65+ -- directly.

66+ , restoreInputState :: IO ()

58 -- | Changes to this value are reflected after the next event.

67 -- | Changes to this value are reflected after the next event.

59 , _configRef :: IORef Config

68 , _configRef :: IORef Config

60 -- | input debug log

69 -- | input debug log

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

71makeLenses ''InputBuffer

80makeLenses ''InputBuffer

72

81

73data InputState = InputState

82data InputState = InputState

74− { _unprocessedBytes :: String

83+ { _unprocessedBytes :: ByteString

84+ , _classifierState :: ClassifierState

75 , _appliedConfig :: Config

85 , _appliedConfig :: Config

76 , _inputBuffer :: InputBuffer

86 , _inputBuffer :: InputBuffer

77− , _classifier :: String -> KClass

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

78 }

88 }

79

89

80makeLenses ''InputState

90makeLenses ''InputState

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

99 dropInvalid

109 dropInvalid

100 loopInputProcessor

110 loopInputProcessor

101

111

102−addBytesToProcess :: String -> InputM ()

112+addBytesToProcess :: ByteString -> InputM ()

103addBytesToProcess block = unprocessedBytes <>= block

113addBytesToProcess block = unprocessedBytes <>= block

104

114

105emit :: Event -> InputM ()

115emit :: Event -> InputM ()

106emit event = do

116emit event = do

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

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

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

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

109

119

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

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

111-- device.

121-- device.

112--

122--

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

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

114-- forkOS thread. That case satisfies precondition.

124-- forkOS thread. That case satisfies precondition.

115−readFromDevice :: InputM String

125+readFromDevice :: InputM ByteString

116readFromDevice = do

126readFromDevice = do

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

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

118 oldConfig <- use appliedConfig

128 oldConfig <- use appliedConfig

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

132 threadWaitRead fd

142 threadWaitRead fd

133 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

143 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

134 if bytesRead > 0

144 if bytesRead > 0

135− then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr

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

136− else return []

146+ else return BS.empty

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

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

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

138 return stringRep

149 return stringRep

139

150

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

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

@@ -145,41 +156,86 @@ applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configurat

145parseEvent :: InputM Event

156parseEvent :: InputM Event

146parseEvent = do

157parseEvent = do

147 c <- use classifier

158 c <- use classifier

159+ s <- use classifierState

148 b <- use unprocessedBytes

160 b <- use unprocessedBytes

149− case c b of

161+ case c s b of

150 Valid e remaining -> do

162 Valid e remaining -> do

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

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

152 logMsg $ "remaining: " ++ show remaining

164 logMsg $ "remaining: " ++ show remaining

165+ classifierState .= ClassifierStart

153 unprocessedBytes .= remaining

166 unprocessedBytes .= remaining

154 return e

167 return e

155− _ -> mzero

168+ _ -> mzero

156

169

157dropInvalid :: InputM ()

170dropInvalid :: InputM ()

158dropInvalid = do

171dropInvalid = do

159 c <- use classifier

172 c <- use classifier

173+ s <- use classifierState

160 b <- use unprocessedBytes

174 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

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

182+ Invalid -> do

162− logMsg "dropping input bytes"

183+ logMsg "dropping input bytes"

184+ classifierState .= ClassifierStart

163− unprocessedBytes .= []

185+ unprocessedBytes .= BS8.empty

186+ _ -> return ()

164

187

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

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

166runInputProcessorLoop classifyTable input = do

189runInputProcessorLoop classifyTable input = do

167 let bufferSize = 1024

190 let bufferSize = 1024

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

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

192+ s0 <- InputState BS8.empty ClassifierStart

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

193+ <$> readIORef (_configRef input)

170− <*> pure (InputBuffer bufferPtr bufferSize)

194+ <*> pure (InputBuffer bufferPtr bufferSize)

171− <*> pure (classify classifyTable)

195+ <*> pure (classify classifyTable)

172 runReaderT (evalStateT loopInputProcessor s0) input

196 runReaderT (evalStateT loopInputProcessor s0) input

173

197

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

199+-- one to restore the terminal mode flags to the values they had at the

200+-- time this function was called.

201+--

202+-- This function constructs a configuration action to clear the

203+-- following terminal mode flags:

204+--

205+-- * IXON disabled: disables software flow control on outgoing data.

206+-- This stops the process from being suspended if the output terminal

207+-- cannot keep up.

208+--

209+-- * Raw mode is used for input.

210+--

211+-- * ISIG (enables keyboard combinations that result in

212+-- signals)

213+--

214+-- * ECHO (input is not echoed to the output)

215+--

216+-- * ICANON (canonical mode (line mode) input is not used)

217+--

218+-- * IEXTEN (extended functions are disabled)

219+--

220+-- The configuration action also explicitly sets these flags:

221+--

222+-- * ICRNL (input carriage returns are mapped to newlines)

174attributeControl :: Fd -> IO (IO (), IO ())

223attributeControl :: Fd -> IO (IO (), IO ())

175attributeControl fd = do

224attributeControl fd = do

176 original <- getTerminalAttributes fd

225 original <- getTerminalAttributes fd

226+ let vtyMode = foldl withMode clearedFlags flagsToSet

227+ clearedFlags = foldl withoutMode original flagsToUnset

228+ flagsToSet = [ MapCRtoLF -- ICRNL

229+ ]

230+ flagsToUnset = [ StartStopOutput -- IXON

177− let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts

231+ , KeyboardInterrupts -- ISIG

232+ , EnableEcho -- ECHO

233+ , ProcessInput -- ICANON

178− , EnableEcho, ProcessInput, ExtendedFunctions

234+ , ExtendedFunctions -- IEXTEN

179− ]

235+ ]

180 let setAttrs = setTerminalAttributes fd vtyMode Immediately

236 let setAttrs = setTerminalAttributes fd vtyMode Immediately

181 unsetAttrs = setTerminalAttributes fd original Immediately

237 unsetAttrs = setTerminalAttributes fd original Immediately

182− return (setAttrs,unsetAttrs)

238+ return (setAttrs, unsetAttrs)

183

239

184logInitialInputState :: Input -> ClassifyMap -> IO()

240logInitialInputState :: Input -> ClassifyMap -> IO()

185logInitialInputState input classifyTable = case _inputDebug input of

241logInitialInputState input classifyTable = case _inputDebug input of

@@ -187,7 +243,7 @@ logInitialInputState input classifyTable = case _inputDebug input of

187 Just h -> do

243 Just h -> do

188 Config{ vmin = Just theVmin

244 Config{ vmin = Just theVmin

189 , vtime = Just theVtime

245 , vtime = Just theVtime

190− , termName = Just theTerm, .. } <- readIORef $ _configRef input

246+ , termName = Just theTerm } <- readIORef $ _configRef input

191 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))

247 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))

192 forM_ classifyTable $ \i -> case i of

248 forM_ classifyTable $ \i -> case i of

193 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

249 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

@@ -203,6 +259,7 @@ initInput config classifyTable = do

203 applyConfig fd config

259 applyConfig fd config

204 stopSync <- newEmptyMVar

260 stopSync <- newEmptyMVar

205 input <- Input <$> atomically newTChan

261 input <- Input <$> atomically newTChan

262+ <*> pure (return ())

206 <*> pure (return ())

263 <*> pure (return ())

207 <*> newIORef config

264 <*> newIORef config

208 <*> maybe (return Nothing)

265 <*> maybe (return Nothing)

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

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

15import Graphics.Vty.Input.Classify.Parse

16

17import Control.Monad.State

18−import Data.List (isPrefixOf)

19import Data.Maybe (catMaybes)

18import Data.Maybe (catMaybes)

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

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

21

20

21+import qualified Data.ByteString.Char8 as BS8

22+import Data.ByteString.Char8 (ByteString)

23+

22-- A mouse event in SGR extended mode is

24-- A mouse event in SGR extended mode is

23--

25--

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

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

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

32

34

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

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

34-- sequences.

36-- sequences.

35−requestMouseEvents :: String

37+requestMouseEvents :: ByteString

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

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

37

39

38-- | These sequences disable mouse events.

40-- | These sequences disable mouse events.

39−disableMouseEvents :: String

41+disableMouseEvents :: ByteString

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

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

41

43

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

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

43−isMouseEvent :: String -> Bool

45+isMouseEvent :: ByteString -> Bool

44isMouseEvent s = isSGREvent s || isNormalEvent s

46isMouseEvent s = isSGREvent s || isNormalEvent s

45

47

46−isSGREvent :: String -> Bool

48+isSGREvent :: ByteString -> Bool

47−isSGREvent = isPrefixOf sgrPrefix

49+isSGREvent = BS8.isPrefixOf sgrPrefix

48

50

49−sgrPrefix :: String

51+sgrPrefix :: ByteString

50−sgrPrefix = "\ESC[M"

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

51

53

52−isNormalEvent :: String -> Bool

54+isNormalEvent :: ByteString -> Bool

53−isNormalEvent = isPrefixOf normalPrefix

55+isNormalEvent = BS8.isPrefixOf normalPrefix

54

56

55−normalPrefix :: String

57+normalPrefix :: ByteString

56−normalPrefix = "\ESC[<"

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

57

59

58-- Modifier bits:

60-- Modifier bits:

59shiftBit :: Int

61shiftBit :: Int

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

87hasBitSet :: Int -> Int -> Bool

89hasBitSet :: Int -> Int -> Bool

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

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

89

91

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

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

91−classifyMouseEvent :: String -> KClass

93+classifyMouseEvent :: ByteString -> KClass

92classifyMouseEvent s = runParser s $ do

94classifyMouseEvent s = runParser s $ do

93 when (not $ isMouseEvent s) failParse

95 when (not $ isMouseEvent s) failParse

94

96

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

100 'M' -> classifyNormalMouseEvent

102 'M' -> classifyNormalMouseEvent

101 _ -> failParse

103 _ -> failParse

102

104

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

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

104getSGRButton :: Int -> Parser Button

106getSGRButton :: Int -> Parser Button

105getSGRButton mods =

107getSGRButton mods =

106 let buttonMap = [ (leftButton, BLeft)

108 let buttonMap = [ (leftButton, BLeft)

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

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

9where

10

11import qualified Data.ByteString.Char8 as BS8

12+import Data.ByteString.Char8 (ByteString)

12

13

13import Graphics.Vty.Input.Events

14import Graphics.Vty.Input.Events

14import Graphics.Vty.Input.Classify.Types

15import Graphics.Vty.Input.Classify.Types

15

16

16−import Data.List (isPrefixOf, isInfixOf)

17+bracketedPasteStart :: ByteString

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

17

19

18−bracketedPasteStart :: String

19−bracketedPasteStart = "\ESC[200~"

20−

21−bracketedPasteEnd :: String

20+bracketedPasteEnd :: ByteString

22−bracketedPasteEnd = "\ESC[201~"

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

23

22

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

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

25−bracketedPasteStarted :: String -> Bool

24+bracketedPasteStarted :: ByteString -> Bool

26−bracketedPasteStarted = isPrefixOf bracketedPasteStart

25+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart

27

26

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

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

29−bracketedPasteFinished :: String -> Bool

28+bracketedPasteFinished :: ByteString -> Bool

30−bracketedPasteFinished = isInfixOf bracketedPasteEnd

29+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd

31

30

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

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

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

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

34-- 'True'.

33-- 'True'.

35−parseBracketedPaste :: String -> KClass

34+parseBracketedPaste :: ByteString -> KClass

36parseBracketedPaste s =

35parseBracketedPaste 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'

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

42−

37+ where

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

38+ startLen = BS8.length bracketedPasteStart

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

39+ endLen = BS8.length bracketedPasteEnd

45−takeUntil cs sub

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

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

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

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+6−4

@@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])

74ctrlChars :: ClassifyMap

75ctrlChars =

76 [ ([toEnum x],EvKey (KChar y) [MCtrl])

77− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])

77+ | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])

78 , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.

79 , y /= 'h' -- CTRL-h should not hide BS

80 ]

@@ -86,10 +86,12 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars

86-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.

87specialSupportKeys :: ClassifyMap

88specialSupportKeys =

89+ [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])

90+ , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])

89− [ -- special support for ESC

91+ -- special support for ESC

90− ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

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

91 -- Special support for backspace

93 -- Special support for backspace

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

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

93 -- Special support for Enter

95 -- Special support for Enter

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

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

95 -- explicit support for tab

97 -- explicit support for tab

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

@@ -59,7 +59,7 @@ navKeys3 =

59-- This encoding depends on the terminal.

60functionKeys1 :: ClassifyMap

61functionKeys1 =

62− let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in

62+ let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in

63 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

64

65-- | encoding for meta plus char

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

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

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

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

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

3-- or a specific terminal device.

4--

@@ -58,11 +58,12 @@ 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, .. } = do

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

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

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

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

63− then XTermColor.reserveTerminal termName fd

64+ then XTermColor.reserveTerminal termName fd colorMode

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

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

65− else TerminfoBased.reserveTerminal termName fd

66+ else TerminfoBased.reserveTerminal termName fd colorMode

66

67

67 case mouseMode of

68 case mouseMode of

68 Just s -> setMode t Mouse s

69 Just s -> setMode t Mouse s

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

77

78

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

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

79--

80--

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

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

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

82-- width.

83-- width.

83--

84--

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

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

1-- Copyright Corey O'Connor

2−{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# 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

@@ -73,13 +73,12 @@ data Output = Output

73 -- | Return the display to the state before `reserveDisplay` If no

74 -- previous state then set the display state to the initial state.

75 , releaseDisplay :: IO ()

76+ -- | Sets the current display bounds (width, height).

77+ , setDisplayBounds :: (Int, Int) -> IO ()

76 -- | Returns the current display bounds.

78 -- | Returns the current display bounds.

77 , displayBounds :: IO DisplayRegion

79 , displayBounds :: IO DisplayRegion

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

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

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

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

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

81− -- context.

82− , contextColorCount :: Int

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

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

84 , supportsCursorVisibility :: Bool

83 , supportsCursorVisibility :: Bool

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

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

@@ -99,6 +98,24 @@ data Output = Output

99 , ringTerminalBell :: IO ()

98 , ringTerminalBell :: IO ()

100 -- | Returns whether the terminal has an audio bell feature.

99 -- | Returns whether the terminal has an audio bell feature.

101 , supportsBell :: IO Bool

100 , supportsBell :: IO Bool

101+ -- | Returns whether the terminal supports italicized text.

102+ --

103+ -- This is terminal-dependent and should make a best effort to

104+ -- determine whether this feature is supported, but even if the

105+ -- terminal advertises support (e.g. via terminfo) that might not

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

107+ -- desired.

108+ , supportsItalics :: IO Bool

109+ -- | Returns whether the terminal supports strikethrough text.

110+ --

111+ -- This is terminal-dependent and should make a best effort to

112+ -- determine whether this feature is supported, but even if the

113+ -- terminal advertises support (e.g. via terminfo) that might not

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

115+ -- desired.

116+ , supportsStrikethrough :: IO Bool

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

118+ , outputColorMode :: ColorMode

102 }

119 }

103

120

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

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

@@ -189,6 +206,12 @@ outputPicture dc pic = do

189 AbsoluteCursor x y ->

206 AbsoluteCursor x y ->

190 writeShowCursor dc `mappend`

207 writeShowCursor dc `mappend`

191 writeMoveCursor dc (clampX x) (clampY y)

208 writeMoveCursor dc (clampX x) (clampY y)

209+ PositionOnly isAbs x y ->

210+ if isAbs

211+ then writeMoveCursor dc (clampX x) (clampY y)

212+ else let (ox, oy) = charToOutputPos m (clampX x, clampY y)

213+ m = cursorOutputMap ops $ picCursor pic

214+ in writeMoveCursor dc (clampX ox) (clampY oy)

192 Cursor x y ->

215 Cursor x y ->

193 let m = cursorOutputMap ops $ picCursor pic

216 let m = cursorOutputMap ops $ picCursor pic

194 (ox, oy) = charToOutputPos m (clampX x, clampY y)

217 (ox, oy) = charToOutputPos m (clampX x, clampY y)

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

286 where

309 where

287 clampColor Default = Default

310 clampColor Default = Default

288 clampColor KeepCurrent = KeepCurrent

311 clampColor KeepCurrent = KeepCurrent

289− clampColor (SetTo c) = clampColor' c

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

313+

290− clampColor' (ISOColor v)

314+ clampColor' NoColor _ = Default

291− | contextColorCount t < 8 = Default

315+

316+ clampColor' ColorMode8 (ISOColor v)

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

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

293− | otherwise = SetTo $ ISOColor v

318+ | otherwise = SetTo $ ISOColor v

294− clampColor' (Color240 v)

319+ clampColor' ColorMode8 _ = Default

295− -- Should we choose closest ISO color?

320+

296− | contextColorCount t < 8 = Default

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

297− | contextColorCount t < 16 = Default

322+ clampColor' ColorMode16 _ = Default

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

323+

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

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

326+ | n <= colorCount = SetTo c

299− | otherwise

327+ | otherwise = Default

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

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

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

329+ clampColor' colorMode (color240 r g b)

302− in SetTo $ Color240 v'

330+

331+ clampColor' FullColor c = SetTo c

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

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

11where

12

13import Graphics.Vty.Image (DisplayRegion)

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

14import Graphics.Vty.Output.Interface

15import Graphics.Vty.Output.Interface

15

16

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

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

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

30-- without considering terminal specific issues.

31-- without considering terminal specific issues.

31--

32--

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

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

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

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

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

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

36-- terminal operations.

37-- terminal operations.

@@ -48,16 +49,19 @@ mockTerminal r = liftIO $ do

48 , releaseDisplay = return ()

49 , releaseDisplay = return ()

49 , ringTerminalBell = return ()

50 , ringTerminalBell = return ()

50 , supportsBell = return False

51 , supportsBell = return False

52+ , supportsItalics = return False

53+ , supportsStrikethrough = return False

54+ , setDisplayBounds = const $ return ()

51 , displayBounds = return r

55 , displayBounds = return r

52 , outputByteBuffer = \bytes -> do

56 , outputByteBuffer = \bytes -> do

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

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

54 writeIORef outRef $ UTF8.fromRep bytes

58 writeIORef outRef $ UTF8.fromRep bytes

55− , contextColorCount = 16

56 , supportsCursorVisibility = True

59 , supportsCursorVisibility = True

57 , supportsMode = const False

60 , supportsMode = const False

58 , setMode = const $ const $ return ()

61 , setMode = const $ const $ return ()

59 , getModeStatus = const $ return False

62 , getModeStatus = const $ return False

60 , assumedStateRef = newAssumedStateRef

63 , assumedStateRef = newAssumedStateRef

64+ , outputColorMode = ColorMode16

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

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

62 { contextRegion = rActual

66 { contextRegion = rActual

63 , contextDevice = tActual

67 , contextDevice = tActual

src/Graphics/Vty/Output/TerminfoBased.hs+106−39

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

1−{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE FlexibleInstances #-}

1{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

@@ -10,10 +9,12 @@

10-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

11module Graphics.Vty.Output.TerminfoBased

10module Graphics.Vty.Output.TerminfoBased

12 ( reserveTerminal

11 ( reserveTerminal

12+ , setWindowSize

13 )

14where

15

16import Control.Monad (when)

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

17import qualified Data.ByteString as BS

18import qualified Data.ByteString as BS

18import Data.ByteString.Internal (toForeignPtr)

19import Data.ByteString.Internal (toForeignPtr)

19import Data.Terminfo.Parse

20import Data.Terminfo.Parse

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

24import Graphics.Vty.DisplayAttributes

25import Graphics.Vty.DisplayAttributes

25import Graphics.Vty.Output.Interface

26import Graphics.Vty.Output.Interface

26

27

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

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

28

29

29−import Data.Bits ((.&.))

30import Data.IORef

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

32import Data.Word

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

49 , cup :: CapExpression

50 , cnorm :: Maybe CapExpression

51 , civis :: Maybe CapExpression

52− , supportsNoColors :: Bool

53 , useAltColorMap :: Bool

52 , useAltColorMap :: Bool

54 , setForeColor :: CapExpression

53 , setForeColor :: CapExpression

55 , setBackColor :: CapExpression

54 , setBackColor :: CapExpression

@@ -66,6 +65,8 @@ data DisplayAttrCaps = DisplayAttrCaps

66 , exitStandout :: Maybe CapExpression

65 , exitStandout :: Maybe CapExpression

67 , enterItalic :: Maybe CapExpression

66 , enterItalic :: Maybe CapExpression

68 , exitItalic :: Maybe CapExpression

67 , exitItalic :: Maybe CapExpression

68+ , enterStrikethrough :: Maybe CapExpression

69+ , exitStrikethrough :: Maybe CapExpression

69 , enterUnderline :: Maybe CapExpression

70 , enterUnderline :: Maybe CapExpression

70 , exitUnderline :: Maybe CapExpression

71 , exitUnderline :: Maybe CapExpression

71 , enterReverseVideo :: Maybe CapExpression

72 , enterReverseVideo :: Maybe CapExpression

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

102--

103--

103-- * Providing independent string capabilities for all display

104-- * Providing independent string capabilities for all display

104-- attributes.

105-- attributes.

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

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

106−reserveTerminal termName outFd = do

107+reserveTerminal termName outFd colorMode = do

107 ti <- Terminfo.setupTerm termName

108 ti <- Terminfo.setupTerm termName

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

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

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

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

110 -- attributes are filtered.

111 -- attributes are filtered.

111 msetaf <- probeCap ti "setaf"

112 msetaf <- probeCap ti "setaf"

112 msetf <- probeCap ti "setf"

113 msetf <- probeCap ti "setf"

113− let (noColors, useAlt, setForeCap)

114+ let (useAlt, setForeCap)

114 = case msetaf of

115 = case msetaf of

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

116+ Just setaf -> (False, setaf)

116 Nothing -> case msetf of

117 Nothing -> case msetf of

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

118+ Just setf -> (True, setf)

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

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

119 msetab <- probeCap ti "setab"

120 msetab <- probeCap ti "setab"

120 msetb <- probeCap ti "setb"

121 msetb <- probeCap ti "setb"

121− let set_back_cap

122+ let setBackCap

122 = case msetab of

123 = case msetab of

124+ Just setab -> setab

123 Nothing -> case msetb of

125 Nothing -> case msetb of

124 Just setb -> setb

126 Just setb -> setb

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

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

126− Just setab -> setab

127

128

128 hyperlinkModeStatus <- newIORef False

129 hyperlinkModeStatus <- newIORef False

129 newAssumedStateRef <- newIORef initialAssumedState

130 newAssumedStateRef <- newIORef initialAssumedState

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

149 <*> requireCap ti "cup"

150 <*> requireCap ti "cup"

150 <*> probeCap ti "cnorm"

151 <*> probeCap ti "cnorm"

151 <*> probeCap ti "civis"

152 <*> probeCap ti "civis"

152− <*> pure noColors

153 <*> pure useAlt

154 <*> pure setForeCap

155− <*> pure set_back_cap

155+ <*> pure setBackCap

156 <*> requireCap ti "sgr0"

157 <*> requireCap ti "clear"

158 <*> requireCap ti "el"

@@ -164,6 +164,10 @@ reserveTerminal termName outFd = do

164 sendCap setDefaultAttr []

165 maybeSendCap cnorm []

166 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps

167+ , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&

168+ (isJust $ exitItalic (displayAttrCaps terminfoCaps))

169+ , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&

170+ (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))

167 , ringTerminalBell = maybeSendCap ringBellAudio []

171 , ringTerminalBell = maybeSendCap ringBellAudio []

168 , reserveDisplay = do

172 , reserveDisplay = do

169 -- If there is no support for smcup: Clear the screen

173 -- If there is no support for smcup: Clear the screen

@@ -174,6 +178,8 @@ reserveTerminal termName outFd = do

174 , releaseDisplay = do

178 , releaseDisplay = do

175 maybeSendCap rmcup []

179 maybeSendCap rmcup []

176 maybeSendCap cnorm []

180 maybeSendCap cnorm []

181+ , setDisplayBounds = \(w, h) ->

182+ setWindowSize outFd (w, h)

177 , displayBounds = do

183 , displayBounds = do

178 rawSize <- getWindowSize outFd

184 rawSize <- getWindowSize outFd

179 case rawSize of

185 case rawSize of

@@ -186,20 +192,15 @@ reserveTerminal termName outFd = do

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

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

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

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

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

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

189− , contextColorCount

190− = case supportsNoColors terminfoCaps of

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

192− Nothing -> 8

193− Just v -> toEnum v

194− True -> 1

195 , supportsCursorVisibility = isJust $ civis terminfoCaps

196 , supportsMode = terminfoModeSupported

197 , setMode = terminfoSetMode

198 , getModeStatus = terminfoModeStatus

199 , assumedStateRef = newAssumedStateRef

200+ , outputColorMode = colorMode

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

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

201 -- reference. I was having issues tho.

202 -- reference. I was having issues tho.

202− , mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps

203+ , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

203 }

204 }

204 sendCap s = sendCapToTerminal t (s terminfoCaps)

205 sendCap s = sendCapToTerminal t (s terminfoCaps)

205 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)

206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)

@@ -231,6 +232,8 @@ currentDisplayAttrCaps ti

231 <*> probeCap ti "rmso"

232 <*> probeCap ti "rmso"

232 <*> probeCap ti "sitm"

233 <*> probeCap ti "sitm"

233 <*> probeCap ti "ritm"

234 <*> probeCap ti "ritm"

235+ <*> probeCap ti "smxx"

236+ <*> probeCap ti "rmxx"

234 <*> probeCap ti "smul"

237 <*> probeCap ti "smul"

235 <*> probeCap ti "rmul"

238 <*> probeCap ti "rmul"

236 <*> probeCap ti "rev"

239 <*> probeCap ti "rev"

@@ -244,6 +247,13 @@ getWindowSize fd = do

244 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd

247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd

245 return (fromIntegral b, fromIntegral a)

248 return (fromIntegral b, fromIntegral a)

246

249

250+foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO ()

251+

252+setWindowSize :: Fd -> (Int, Int) -> IO ()

253+setWindowSize fd (w, h) = do

254+ let val = (h `shiftL` 16) + w

255+ c_setWindowSize fd $ fromIntegral val

256+

247terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

248terminfoDisplayContext tActual terminfoCaps r = return dc

258terminfoDisplayContext tActual terminfoCaps r = return dc

249 where dc = DisplayContext

259 where dc = DisplayContext

@@ -259,7 +269,11 @@ terminfoDisplayContext tActual terminfoCaps r = return dc

259 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps

269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps

260 , writeDefaultAttr = \urlsEnabled ->

270 , writeDefaultAttr = \urlsEnabled ->

261 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`

271 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`

262− (if urlsEnabled then writeURLEscapes EndLink else mempty)

272+ (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`

273+ (case exitStrikethrough $ displayAttrCaps terminfoCaps of

274+ Just cap -> writeCapExpr cap []

275+ Nothing -> mempty

276+ )

263 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []

277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []

264 , inlineHack = return ()

278 , inlineHack = return ()

265 }

279 }

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

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

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

282--

296--

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

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

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

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

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

286--

300--

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

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

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

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

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

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

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

322 -- capability.

336 -- capability.

323− True -> do

337+ True -> do

324 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

325− (fixedStyle attr )

339+ (fixedStyle attr)

326 (styleToApplySeq $ fixedStyle attr) of

340 (styleToApplySeq $ fixedStyle attr) of

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

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

328 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

342 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

@@ -332,11 +346,11 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

332 setColors

346 setColors

333 -- implicitly resets the colors to the defaults

347 -- implicitly resets the colors to the defaults

334 SetState state -> writeCapExpr (fromJust $ setAttrStates

348 SetState state -> writeCapExpr (fromJust $ setAttrStates

335− $ displayAttrCaps

349+ $ displayAttrCaps terminfoCaps

336− $ terminfoCaps

337 )

350 )

338 (sgrArgsForState state)

351 (sgrArgsForState state)

339 `mappend` setItalics

352 `mappend` setItalics

353+ `mappend` setStrikethrough

340 `mappend` setColors

354 `mappend` setColors

341 -- Otherwise the display colors are not changing or changing

355 -- Otherwise the display colors are not changing or changing

342 -- between two non-default points.

356 -- between two non-default points.

@@ -355,15 +369,16 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

355 -- applied states.

369 -- applied states.

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

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

357 `mappend`

371 `mappend`

358− writeColorDiff setForeColor (foreColorDiff diffs)

372+ writeColorDiff Foreground (foreColorDiff diffs)

359 `mappend`

373 `mappend`

360− writeColorDiff setBackColor (backColorDiff diffs)

374+ writeColorDiff Background (backColorDiff diffs)

361 -- implicitly resets the colors to the defaults

375 -- implicitly resets the colors to the defaults

362 SetState state -> writeCapExpr (fromJust $ setAttrStates

376 SetState state -> writeCapExpr (fromJust $ setAttrStates

363 $ displayAttrCaps terminfoCaps

377 $ displayAttrCaps terminfoCaps

364 )

378 )

365 (sgrArgsForState state)

379 (sgrArgsForState state)

366 `mappend` setItalics

380 `mappend` setItalics

381+ `mappend` setStrikethrough

367 `mappend` setColors

382 `mappend` setColors

368 where

383 where

369 urlAttrs True = writeURLEscapes (urlDiff diffs)

384 urlAttrs True = writeURLEscapes (urlDiff diffs)

@@ -381,31 +396,72 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

381 , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)

396 , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)

382 = writeCapExpr sitm []

397 = writeCapExpr sitm []

383 | otherwise = mempty

398 | otherwise = mempty

399+ setStrikethrough

400+ | hasStyle (fixedStyle attr) strikethrough

401+ , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)

402+ = writeCapExpr smxx []

403+ | otherwise = mempty

384 setColors =

404 setColors =

385 (case fixedForeColor attr of

405 (case fixedForeColor attr of

386− Just c -> writeCapExpr (setForeColor terminfoCaps)

406+ Just c -> writeColor Foreground c

387− [toEnum $ colorMap c]

388 Nothing -> mempty)

407 Nothing -> mempty)

389 `mappend`

408 `mappend`

390 (case fixedBackColor attr of

409 (case fixedBackColor attr of

391− Just c -> writeCapExpr (setBackColor terminfoCaps)

410+ Just c -> writeColor Background c

392− [toEnum $ colorMap c]

393 Nothing -> mempty)

411 Nothing -> mempty)

394− writeColorDiff _f NoColorChange

412+ writeColorDiff _side NoColorChange

395 = mempty

413 = mempty

396− writeColorDiff _f ColorToDefault

414+ writeColorDiff _side ColorToDefault

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

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

398− writeColorDiff f (SetColor 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 =

399− = writeCapExpr (f terminfoCaps) [toEnum $ colorMap 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"

400

452

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

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

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

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

403--

455--

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

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

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

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

406ansiColorIndex :: Color -> Int

458ansiColorIndex :: Color -> Int

407ansiColorIndex (ISOColor v) = fromEnum v

459ansiColorIndex (ISOColor v) = fromEnum v

408ansiColorIndex (Color240 v) = 16 + fromEnum v

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

409

465

410-- | For terminals without setaf/setab

466-- | For terminals without setaf/setab

411--

467--

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

422altColorIndex (ISOColor 7) = 7

478altColorIndex (ISOColor 7) = 7

423altColorIndex (ISOColor v) = fromEnum v

479altColorIndex (ISOColor v) = fromEnum v

424altColorIndex (Color240 v) = 16 + fromEnum v

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

425

485

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

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

427 - according to these rules.

487 - according to these rules.

@@ -449,6 +509,7 @@ data DisplayAttrState = DisplayAttrState

449 { applyStandout :: Bool

509 { applyStandout :: Bool

450 , applyUnderline :: Bool

510 , applyUnderline :: Bool

451 , applyItalic :: Bool

511 , applyItalic :: Bool

512+ , applyStrikethrough :: Bool

452 , applyReverseVideo :: Bool

513 , applyReverseVideo :: Bool

453 , applyBlink :: Bool

514 , applyBlink :: Bool

454 , applyDim :: Bool

515 , applyDim :: Bool

@@ -485,6 +546,8 @@ reqDisplayCapSeqFor caps s diffs

485 -- set state cap then just use the set state cap.

546 -- set state cap then just use the set state cap.

486 ( True, True ) -> SetState $ stateForStyle s

547 ( True, True ) -> SetState $ stateForStyle s

487 where

548 where

549+ noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps

550+ noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps

488 noEnterExitCap ApplyItalic = isNothing $ enterItalic caps

551 noEnterExitCap ApplyItalic = isNothing $ enterItalic caps

489 noEnterExitCap RemoveItalic = isNothing $ exitItalic caps

552 noEnterExitCap RemoveItalic = isNothing $ exitItalic caps

490 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps

553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps

@@ -499,6 +562,8 @@ reqDisplayCapSeqFor caps s diffs

499 noEnterExitCap RemoveDim = True

562 noEnterExitCap RemoveDim = True

500 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps

563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps

501 noEnterExitCap RemoveBold = True

564 noEnterExitCap RemoveBold = True

565+ enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps

566+ enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps

502 enterExitCap ApplyItalic = fromJust $ enterItalic caps

567 enterExitCap ApplyItalic = fromJust $ enterItalic caps

503 enterExitCap RemoveItalic = fromJust $ exitItalic caps

568 enterExitCap RemoveItalic = fromJust $ exitItalic caps

504 enterExitCap ApplyStandout = fromJust $ enterStandout caps

569 enterExitCap ApplyStandout = fromJust $ enterStandout caps

@@ -515,6 +580,7 @@ stateForStyle s = DisplayAttrState

515 { applyStandout = isStyleSet standout

580 { applyStandout = isStyleSet standout

516 , applyUnderline = isStyleSet underline

581 , applyUnderline = isStyleSet underline

517 , applyItalic = isStyleSet italic

582 , applyItalic = isStyleSet italic

583+ , applyStrikethrough = isStyleSet strikethrough

518 , applyReverseVideo = isStyleSet reverseVideo

584 , applyReverseVideo = isStyleSet reverseVideo

519 , applyBlink = isStyleSet blink

585 , applyBlink = isStyleSet blink

520 , applyDim = isStyleSet dim

586 , applyDim = isStyleSet dim

@@ -527,6 +593,7 @@ styleToApplySeq s = concat

527 [ applyIfRequired ApplyStandout standout

593 [ applyIfRequired ApplyStandout standout

528 , applyIfRequired ApplyUnderline underline

594 , applyIfRequired ApplyUnderline underline

529 , applyIfRequired ApplyItalic italic

595 , applyIfRequired ApplyItalic italic

596+ , applyIfRequired ApplyStrikethrough strikethrough

530 , applyIfRequired ApplyReverseVideo reverseVideo

597 , applyIfRequired ApplyReverseVideo reverseVideo

531 , applyIfRequired ApplyBlink blink

598 , applyIfRequired ApplyBlink blink

532 , applyIfRequired ApplyDim dim

599 , applyIfRequired ApplyDim dim

src/Graphics/Vty/Output/XTermColor.hs+27−18

@@ -10,17 +10,23 @@ where

10import Graphics.Vty.Output.Interface

11import Graphics.Vty.Input.Mouse

12import Graphics.Vty.Input.Focus

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

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

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

14

15

15import Blaze.ByteString.Builder (writeToByteString)

16import Blaze.ByteString.Builder (writeToByteString)

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

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

17

18

19+import qualified Data.ByteString.Char8 as BS8

20+import Data.ByteString.Char8 (ByteString)

21+import Foreign.Ptr (castPtr)

22+

18import Control.Monad (void, when)

23import Control.Monad (void, when)

19import Control.Monad.Trans

24import Control.Monad.Trans

25+import Data.Char (toLower)

20import Data.IORef

26import Data.IORef

21

27

22−import System.Posix.IO (fdWrite)

28+import System.Posix.IO (fdWriteBuf)

23−import System.Posix.Types (Fd)

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

24import System.Posix.Env (getEnv)

30import System.Posix.Env (getEnv)

25

31

26import Data.List (isInfixOf)

32import Data.List (isInfixOf)

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

30import Data.Monoid ((<>))

36import Data.Monoid ((<>))

31#endif

37#endif

32

38

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+

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

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

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

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

35−reserveTerminal variant outFd = liftIO $ do

47+reserveTerminal variant outFd colorMode = liftIO $ do

36 let flushedPut = void . fdWrite outFd

48 let flushedPut = void . fdWrite outFd

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

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

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

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

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

40

52

41 utf8a <- utf8Active

53 utf8a <- utf8Active

42 when (not utf8a) $ flushedPut setUtf8CharSet

54 when (not utf8a) $ flushedPut setUtf8CharSet

43− t <- TerminfoBased.reserveTerminal variant' outFd

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

44

56

45 mouseModeStatus <- newIORef False

57 mouseModeStatus <- newIORef False

46 focusModeStatus <- newIORef False

58 focusModeStatus <- newIORef False

@@ -92,30 +104,27 @@ reserveTerminal variant outFd = liftIO $ do

92utf8Active :: IO Bool

104utf8Active :: IO Bool

93utf8Active = do

105utf8Active = do

94 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]

106 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]

95− results <- catMaybes <$> mapM getEnv vars

107+ results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars

96− let matches = filter ("UTF8" `isInfixOf`) results <>

108+ let matches = filter ("utf8" `isInfixOf`) results <>

97− filter ("UTF-8" `isInfixOf`) results

109+ filter ("utf-8" `isInfixOf`) results

98 return $ not $ null matches

110 return $ not $ null matches

99

111

100-- | Enable bracketed paste mode:

112-- | Enable bracketed paste mode:

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

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

102−enableBracketedPastes :: String

114+enableBracketedPastes :: ByteString

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

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

104

116

105-- | Disable bracketed paste mode:

117-- | Disable bracketed paste mode:

106−disableBracketedPastes :: String

118+disableBracketedPastes :: ByteString

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

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

108

120

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

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

110--

122--

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

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

112−setUtf8CharSet, setDefaultCharSet :: String

124+setUtf8CharSet, setDefaultCharSet :: ByteString

113−setUtf8CharSet = "\ESC%G"

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

114−setDefaultCharSet = "\ESC%@"

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

115

127

116−-- | I think xterm is broken: Reseting the background color as the first

117−-- bytes serialized on a new line does not effect the background color

118−-- xterm uses to clear the line. Which is used *after* the next newline.

119xtermInlineHack :: Output -> IO ()

128xtermInlineHack :: Output -> IO ()

120xtermInlineHack t = do

129xtermInlineHack t = do

121 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

130 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

src/Graphics/Vty/Picture.hs+8−1

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

1−{-# LANGUAGE BangPatterns #-}

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

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

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

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

4-- view.

3-- view.

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

80data Cursor =

79data Cursor =

81 -- | Hide the cursor

80 -- | Hide the cursor

82 NoCursor

81 NoCursor

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

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

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

85+ -- not want to show a block cursor in that location for cosmetic

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

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

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

89+ | PositionOnly !Bool !Int !Int

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

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

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

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

85 | Cursor !Int !Int

92 | Cursor !Int !Int

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

@@ -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−-- largerly used only for debugging.

75+-- largely used only for debugging.

76displayOpsForImage :: Image -> DisplayOps

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

78

@@ -81,7 +81,7 @@ combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)

81combinedOpsForLayers pic r

82 | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0

83 | otherwise = do

84− layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)

84+ layerOps <- mapM (`buildSpans` r) (picLayers pic)

85 case layerOps of

86 [] -> fail "empty picture"

87 [ops] -> substituteSkips (picBackground pic) ops

@@ -136,8 +136,8 @@ mergeUnder upper lower = do

136 return upper

137

138mergeRowUnder :: SpanOps -> SpanOps -> SpanOps

139−mergeRowUnder upperRowOps lowerRowOps =

139+mergeRowUnder upperRowOps =

140− onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps

140+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)

141 where

142 -- H: it will never be the case that we are out of upper ops

143 -- before lower ops.

src/Graphics/Vty/Span.hs+2−4

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

1-- Copyright Corey O'Connor

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE NamedFieldPuns #-}

4{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

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

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

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

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

@@ -52,7 +50,7 @@ dropOps :: Int -> SpanOps -> SpanOps

52dropOps w = snd . splitOpsAt w

50dropOps w = snd . splitOpsAt w

53

51

54splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)

52splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)

55−splitOpsAt inW inOps = splitOpsAt' inW inOps

53+splitOpsAt = splitOpsAt'

56 where

54 where

57 splitOpsAt' 0 ops = (Vector.empty, ops)

55 splitOpsAt' 0 ops = (Vector.empty, ops)

58 splitOpsAt' remainingColumns ops = case Vector.head ops of

56 splitOpsAt' remainingColumns ops = case Vector.head ops of

@@ -103,7 +101,7 @@ displayOpsColumns ops

103

101

104-- | The number of rows the DisplayOps are defined for.

102-- | The number of rows the DisplayOps are defined for.

105displayOpsRows :: DisplayOps -> Int

103displayOpsRows :: DisplayOps -> Int

106−displayOpsRows ops = Vector.length ops

104+displayOpsRows = Vector.length

107

105

108affectedRegion :: DisplayOps -> DisplayRegion

106affectedRegion :: DisplayOps -> DisplayRegion

109affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)

107affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)

src/Graphics/Vty/UnicodeWidthTable/Install.hs+3−9

@@ -9,7 +9,8 @@ where

9

10import Control.Monad (when, forM_)

11import qualified Control.Exception as E

12+import GHC.Conc.Sync (withMVar)

12−import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)

13+import Control.Concurrent.MVar (MVar, newMVar)

13import Data.Word (Word8, Word32)

14import Data.Word (Word8, Word32)

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

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

15import Data.Semigroup ((<>))

16import Data.Semigroup ((<>))

@@ -31,14 +32,7 @@ isCustomTableReady :: IO Bool

31isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady

32isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady

32

33

33withInstallLock :: IO a -> IO a

34withInstallLock :: IO a -> IO a

34−withInstallLock act =

35+withInstallLock act = withMVar installLock $ const act

35− E.bracket takeInstallLock (const releaseInstallLock) $ const act

36−

37−takeInstallLock :: IO ()

38−takeInstallLock = takeMVar installLock

39−

40−releaseInstallLock :: IO ()

41−releaseInstallLock = putMVar installLock ()

42

36

43-- This is the size of the allocated custom character width table, in

37-- This is the size of the allocated custom character width table, in

44-- character slots. It's important that this be large enough to hold all

38-- character slots. It's important that this be large enough to hold all

test/VerifyColor240.hsnew file+269

@@ -0,0 +1,269 @@

1+module VerifyColor240 where

2+

3+import Data.Word(Word8)

4+import Verify

5+

6+import Graphics.Vty.Attributes.Color240(rgbColorToColor240)

7+

8+oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8

9+oldRgbColorToColor240 r g b

10+ | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"

11+ | r == 8 && g == 8 && b == 8 = 216

12+ | r == 18 && g == 18 && b == 18 = 217

13+ | r == 28 && g == 28 && b == 28 = 218

14+ | r == 38 && g == 38 && b == 38 = 219

15+ | r == 48 && g == 48 && b == 48 = 220

16+ | r == 58 && g == 58 && b == 58 = 221

17+ | r == 68 && g == 68 && b == 68 = 222

18+ | r == 78 && g == 78 && b == 78 = 223

19+ | r == 88 && g == 88 && b == 88 = 224

20+ | r == 98 && g == 98 && b == 98 = 225

21+ | r == 108 && g == 108 && b == 108 = 226

22+ | r == 118 && g == 118 && b == 118 = 227

23+ | r == 128 && g == 128 && b == 128 = 228

24+ | r == 138 && g == 138 && b == 138 = 229

25+ | r == 148 && g == 148 && b == 148 = 230

26+ | r == 158 && g == 158 && b == 158 = 231

27+ | r == 168 && g == 168 && b == 168 = 232

28+ | r == 178 && g == 178 && b == 178 = 233

29+ | r == 188 && g == 188 && b == 188 = 234

30+ | r == 198 && g == 198 && b == 198 = 235

31+ | r == 208 && g == 208 && b == 208 = 236

32+ | r == 218 && g == 218 && b == 218 = 237

33+ | r == 228 && g == 228 && b == 228 = 238

34+ | r == 238 && g == 238 && b == 238 = 239

35+ | r <= 0 && g <= 0 && b <= 0 = 0

36+ | r <= 0 && g <= 0 && b <= 95 = 1

37+ | r <= 0 && g <= 0 && b <= 135 = 2

38+ | r <= 0 && g <= 0 && b <= 175 = 3

39+ | r <= 0 && g <= 0 && b <= 215 = 4

40+ | r <= 0 && g <= 0 && b <= 255 = 5

41+ | r <= 0 && g <= 95 && b <= 0 = 6

42+ | r <= 0 && g <= 95 && b <= 95 = 7

43+ | r <= 0 && g <= 95 && b <= 135 = 8

44+ | r <= 0 && g <= 95 && b <= 175 = 9

45+ | r <= 0 && g <= 95 && b <= 215 = 10

46+ | r <= 0 && g <= 95 && b <= 255 = 11

47+ | r <= 0 && g <= 135 && b <= 0 = 12

48+ | r <= 0 && g <= 135 && b <= 95 = 13

49+ | r <= 0 && g <= 135 && b <= 135 = 14

50+ | r <= 0 && g <= 135 && b <= 175 = 15

51+ | r <= 0 && g <= 135 && b <= 215 = 16

52+ | r <= 0 && g <= 135 && b <= 255 = 17

53+ | r <= 0 && g <= 175 && b <= 0 = 18

54+ | r <= 0 && g <= 175 && b <= 95 = 19

55+ | r <= 0 && g <= 175 && b <= 135 = 20

56+ | r <= 0 && g <= 175 && b <= 175 = 21

57+ | r <= 0 && g <= 175 && b <= 215 = 22

58+ | r <= 0 && g <= 175 && b <= 255 = 23

59+ | r <= 0 && g <= 215 && b <= 0 = 24

60+ | r <= 0 && g <= 215 && b <= 95 = 25

61+ | r <= 0 && g <= 215 && b <= 135 = 26

62+ | r <= 0 && g <= 215 && b <= 175 = 27

63+ | r <= 0 && g <= 215 && b <= 215 = 28

64+ | r <= 0 && g <= 215 && b <= 255 = 29

65+ | r <= 0 && g <= 255 && b <= 0 = 30

66+ | r <= 0 && g <= 255 && b <= 95 = 31

67+ | r <= 0 && g <= 255 && b <= 135 = 32

68+ | r <= 0 && g <= 255 && b <= 175 = 33

69+ | r <= 0 && g <= 255 && b <= 215 = 34

70+ | r <= 0 && g <= 255 && b <= 255 = 35

71+ | r <= 95 && g <= 0 && b <= 0 = 36

72+ | r <= 95 && g <= 0 && b <= 95 = 37

73+ | r <= 95 && g <= 0 && b <= 135 = 38

74+ | r <= 95 && g <= 0 && b <= 175 = 39

75+ | r <= 95 && g <= 0 && b <= 215 = 40

76+ | r <= 95 && g <= 0 && b <= 255 = 41

77+ | r <= 95 && g <= 95 && b <= 0 = 42

78+ | r <= 95 && g <= 95 && b <= 95 = 43

79+ | r <= 95 && g <= 95 && b <= 135 = 44

80+ | r <= 95 && g <= 95 && b <= 175 = 45

81+ | r <= 95 && g <= 95 && b <= 215 = 46

82+ | r <= 95 && g <= 95 && b <= 255 = 47

83+ | r <= 95 && g <= 135 && b <= 0 = 48

84+ | r <= 95 && g <= 135 && b <= 95 = 49

85+ | r <= 95 && g <= 135 && b <= 135 = 50

86+ | r <= 95 && g <= 135 && b <= 175 = 51

87+ | r <= 95 && g <= 135 && b <= 215 = 52

88+ | r <= 95 && g <= 135 && b <= 255 = 53

89+ | r <= 95 && g <= 175 && b <= 0 = 54

90+ | r <= 95 && g <= 175 && b <= 95 = 55

91+ | r <= 95 && g <= 175 && b <= 135 = 56

92+ | r <= 95 && g <= 175 && b <= 175 = 57

93+ | r <= 95 && g <= 175 && b <= 215 = 58

94+ | r <= 95 && g <= 175 && b <= 255 = 59

95+ | r <= 95 && g <= 215 && b <= 0 = 60

96+ | r <= 95 && g <= 215 && b <= 95 = 61

97+ | r <= 95 && g <= 215 && b <= 135 = 62

98+ | r <= 95 && g <= 215 && b <= 175 = 63

99+ | r <= 95 && g <= 215 && b <= 215 = 64

100+ | r <= 95 && g <= 215 && b <= 255 = 65

101+ | r <= 95 && g <= 255 && b <= 0 = 66

102+ | r <= 95 && g <= 255 && b <= 95 = 67

103+ | r <= 95 && g <= 255 && b <= 135 = 68

104+ | r <= 95 && g <= 255 && b <= 175 = 69

105+ | r <= 95 && g <= 255 && b <= 215 = 70

106+ | r <= 95 && g <= 255 && b <= 255 = 71

107+ | r <= 135 && g <= 0 && b <= 0 = 72

108+ | r <= 135 && g <= 0 && b <= 95 = 73

109+ | r <= 135 && g <= 0 && b <= 135 = 74

110+ | r <= 135 && g <= 0 && b <= 175 = 75

111+ | r <= 135 && g <= 0 && b <= 215 = 76

112+ | r <= 135 && g <= 0 && b <= 255 = 77

113+ | r <= 135 && g <= 95 && b <= 0 = 78

114+ | r <= 135 && g <= 95 && b <= 95 = 79

115+ | r <= 135 && g <= 95 && b <= 135 = 80

116+ | r <= 135 && g <= 95 && b <= 175 = 81

117+ | r <= 135 && g <= 95 && b <= 215 = 82

118+ | r <= 135 && g <= 95 && b <= 255 = 83

119+ | r <= 135 && g <= 135 && b <= 0 = 84

120+ | r <= 135 && g <= 135 && b <= 95 = 85

121+ | r <= 135 && g <= 135 && b <= 135 = 86

122+ | r <= 135 && g <= 135 && b <= 175 = 87

123+ | r <= 135 && g <= 135 && b <= 215 = 88

124+ | r <= 135 && g <= 135 && b <= 255 = 89

125+ | r <= 135 && g <= 175 && b <= 0 = 90

126+ | r <= 135 && g <= 175 && b <= 95 = 91

127+ | r <= 135 && g <= 175 && b <= 135 = 92

128+ | r <= 135 && g <= 175 && b <= 175 = 93

129+ | r <= 135 && g <= 175 && b <= 215 = 94

130+ | r <= 135 && g <= 175 && b <= 255 = 95

131+ | r <= 135 && g <= 215 && b <= 0 = 96

132+ | r <= 135 && g <= 215 && b <= 95 = 97

133+ | r <= 135 && g <= 215 && b <= 135 = 98

134+ | r <= 135 && g <= 215 && b <= 175 = 99

135+ | r <= 135 && g <= 215 && b <= 215 = 100

136+ | r <= 135 && g <= 215 && b <= 255 = 101

137+ | r <= 135 && g <= 255 && b <= 0 = 102

138+ | r <= 135 && g <= 255 && b <= 95 = 103

139+ | r <= 135 && g <= 255 && b <= 135 = 104

140+ | r <= 135 && g <= 255 && b <= 175 = 105

141+ | r <= 135 && g <= 255 && b <= 215 = 106

142+ | r <= 135 && g <= 255 && b <= 255 = 107

143+ | r <= 175 && g <= 0 && b <= 0 = 108

144+ | r <= 175 && g <= 0 && b <= 95 = 109

145+ | r <= 175 && g <= 0 && b <= 135 = 110

146+ | r <= 175 && g <= 0 && b <= 175 = 111

147+ | r <= 175 && g <= 0 && b <= 215 = 112

148+ | r <= 175 && g <= 0 && b <= 255 = 113

149+ | r <= 175 && g <= 95 && b <= 0 = 114

150+ | r <= 175 && g <= 95 && b <= 95 = 115

151+ | r <= 175 && g <= 95 && b <= 135 = 116

152+ | r <= 175 && g <= 95 && b <= 175 = 117

153+ | r <= 175 && g <= 95 && b <= 215 = 118

154+ | r <= 175 && g <= 95 && b <= 255 = 119

155+ | r <= 175 && g <= 135 && b <= 0 = 120

156+ | r <= 175 && g <= 135 && b <= 95 = 121

157+ | r <= 175 && g <= 135 && b <= 135 = 122

158+ | r <= 175 && g <= 135 && b <= 175 = 123

159+ | r <= 175 && g <= 135 && b <= 215 = 124

160+ | r <= 175 && g <= 135 && b <= 255 = 125

161+ | r <= 175 && g <= 175 && b <= 0 = 126

162+ | r <= 175 && g <= 175 && b <= 95 = 127

163+ | r <= 175 && g <= 175 && b <= 135 = 128

164+ | r <= 175 && g <= 175 && b <= 175 = 129

165+ | r <= 175 && g <= 175 && b <= 215 = 130

166+ | r <= 175 && g <= 175 && b <= 255 = 131

167+ | r <= 175 && g <= 215 && b <= 0 = 132

168+ | r <= 175 && g <= 215 && b <= 95 = 133

169+ | r <= 175 && g <= 215 && b <= 135 = 134

170+ | r <= 175 && g <= 215 && b <= 175 = 135

171+ | r <= 175 && g <= 215 && b <= 215 = 136

172+ | r <= 175 && g <= 215 && b <= 255 = 137

173+ | r <= 175 && g <= 255 && b <= 0 = 138

174+ | r <= 175 && g <= 255 && b <= 95 = 139

175+ | r <= 175 && g <= 255 && b <= 135 = 140

176+ | r <= 175 && g <= 255 && b <= 175 = 141

177+ | r <= 175 && g <= 255 && b <= 215 = 142

178+ | r <= 175 && g <= 255 && b <= 255 = 143

179+ | r <= 215 && g <= 0 && b <= 0 = 144

180+ | r <= 215 && g <= 0 && b <= 95 = 145

181+ | r <= 215 && g <= 0 && b <= 135 = 146

182+ | r <= 215 && g <= 0 && b <= 175 = 147

183+ | r <= 215 && g <= 0 && b <= 215 = 148

184+ | r <= 215 && g <= 0 && b <= 255 = 149

185+ | r <= 215 && g <= 95 && b <= 0 = 150

186+ | r <= 215 && g <= 95 && b <= 95 = 151

187+ | r <= 215 && g <= 95 && b <= 135 = 152

188+ | r <= 215 && g <= 95 && b <= 175 = 153

189+ | r <= 215 && g <= 95 && b <= 215 = 154

190+ | r <= 215 && g <= 95 && b <= 255 = 155

191+ | r <= 215 && g <= 135 && b <= 0 = 156

192+ | r <= 215 && g <= 135 && b <= 95 = 157

193+ | r <= 215 && g <= 135 && b <= 135 = 158

194+ | r <= 215 && g <= 135 && b <= 175 = 159

195+ | r <= 215 && g <= 135 && b <= 215 = 160

196+ | r <= 215 && g <= 135 && b <= 255 = 161

197+ | r <= 215 && g <= 175 && b <= 0 = 162

198+ | r <= 215 && g <= 175 && b <= 95 = 163

199+ | r <= 215 && g <= 175 && b <= 135 = 164

200+ | r <= 215 && g <= 175 && b <= 175 = 165

201+ | r <= 215 && g <= 175 && b <= 215 = 166

202+ | r <= 215 && g <= 175 && b <= 255 = 167

203+ | r <= 215 && g <= 215 && b <= 0 = 168

204+ | r <= 215 && g <= 215 && b <= 95 = 169

205+ | r <= 215 && g <= 215 && b <= 135 = 170

206+ | r <= 215 && g <= 215 && b <= 175 = 171

207+ | r <= 215 && g <= 215 && b <= 215 = 172

208+ | r <= 215 && g <= 215 && b <= 255 = 173

209+ | r <= 215 && g <= 255 && b <= 0 = 174

210+ | r <= 215 && g <= 255 && b <= 95 = 175

211+ | r <= 215 && g <= 255 && b <= 135 = 176

212+ | r <= 215 && g <= 255 && b <= 175 = 177

213+ | r <= 215 && g <= 255 && b <= 215 = 178

214+ | r <= 215 && g <= 255 && b <= 255 = 179

215+ | r <= 255 && g <= 0 && b <= 0 = 180

216+ | r <= 255 && g <= 0 && b <= 95 = 181

217+ | r <= 255 && g <= 0 && b <= 135 = 182

218+ | r <= 255 && g <= 0 && b <= 175 = 183

219+ | r <= 255 && g <= 0 && b <= 215 = 184

220+ | r <= 255 && g <= 0 && b <= 255 = 185

221+ | r <= 255 && g <= 95 && b <= 0 = 186

222+ | r <= 255 && g <= 95 && b <= 95 = 187

223+ | r <= 255 && g <= 95 && b <= 135 = 188

224+ | r <= 255 && g <= 95 && b <= 175 = 189

225+ | r <= 255 && g <= 95 && b <= 215 = 190

226+ | r <= 255 && g <= 95 && b <= 255 = 191

227+ | r <= 255 && g <= 135 && b <= 0 = 192

228+ | r <= 255 && g <= 135 && b <= 95 = 193

229+ | r <= 255 && g <= 135 && b <= 135 = 194

230+ | r <= 255 && g <= 135 && b <= 175 = 195

231+ | r <= 255 && g <= 135 && b <= 215 = 196

232+ | r <= 255 && g <= 135 && b <= 255 = 197

233+ | r <= 255 && g <= 175 && b <= 0 = 198

234+ | r <= 255 && g <= 175 && b <= 95 = 199

235+ | r <= 255 && g <= 175 && b <= 135 = 200

236+ | r <= 255 && g <= 175 && b <= 175 = 201

237+ | r <= 255 && g <= 175 && b <= 215 = 202

238+ | r <= 255 && g <= 175 && b <= 255 = 203

239+ | r <= 255 && g <= 215 && b <= 0 = 204

240+ | r <= 255 && g <= 215 && b <= 95 = 205

241+ | r <= 255 && g <= 215 && b <= 135 = 206

242+ | r <= 255 && g <= 215 && b <= 175 = 207

243+ | r <= 255 && g <= 215 && b <= 215 = 208

244+ | r <= 255 && g <= 215 && b <= 255 = 209

245+ | r <= 255 && g <= 255 && b <= 0 = 210

246+ | r <= 255 && g <= 255 && b <= 95 = 211

247+ | r <= 255 && g <= 255 && b <= 135 = 212

248+ | r <= 255 && g <= 255 && b <= 175 = 213

249+ | r <= 255 && g <= 255 && b <= 215 = 214

250+ | r <= 255 && g <= 255 && b <= 255 = 215

251+ | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."

252+ (fromIntegral r :: Int)

253+ (fromIntegral g :: Int)

254+ (fromIntegral b :: Int))

255+

256+sameColor :: Int -> Int -> Int -> Bool

257+sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b

258+

259+genVal :: Gen Int

260+genVal = chooseInt (0, 255)

261+

262+sameColorCheck :: Property

263+sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g)))

264+

265+tests :: IO [Test]

266+tests = return

267+ [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck

268+ ]

269+

test/VerifyEmptyImageProps.hs+1

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

1+{-# LANGUAGE ScopedTypeVariables #-}

1module VerifyEmptyImageProps where

2module VerifyEmptyImageProps where

2

3

3import Verify

4import Verify

test/VerifyEvalTerminfoCaps.hs+1

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

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

3module VerifyEvalTerminfoCaps where

4module VerifyEvalTerminfoCaps where

4

5

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

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

test/VerifyImageOps.hs+2−1

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

1+{-# LANGUAGE ScopedTypeVariables #-}

1module VerifyImageOps where

2module VerifyImageOps where

2

3

3import Graphics.Vty.Attributes

4import Graphics.Vty.Attributes

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

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

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

137 v >= imageHeight (cropBottom v i)

138 v >= imageHeight (cropBottom v i)

138

139

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

140canShowImage :: Image -> Bool

141canShowImage :: Image -> Bool

141canShowImage i = length (show i) > 0

142canShowImage i = length (show i) > 0

142

143

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.

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

3-- for the terminals of interest.

4+{-# LANGUAGE ScopedTypeVariables #-}

4module VerifyOutput where

5module VerifyOutput where

5

6

6import Verify

7import Verify

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

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

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

35smokeTestTerm termName i = do

36smokeTestTerm termName i = do

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

37 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+ }

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

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

39 reserveDisplay t

44 reserveDisplay t

40 dc <- displayContext t (100,100)

45 dc <- displayContext t (100,100)

test/VerifyParseTerminfoCaps.hs+1

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

1{-# LANGUAGE NamedFieldPuns #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyParseTerminfoCaps where

3module VerifyParseTerminfoCaps where

3

4

4import Prelude hiding ( catch )

5import Prelude hiding ( catch )

test/VerifyUsingMockInput.hs+4−1

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

1{-# LANGUAGE MultiParamTypeClasses #-}

2{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

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

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

4-- Verify the events produced are as expected.

5-- Verify the events produced are as expected.

5module Main where

6module Main where

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

131 readLoop 0 = return ()

132 readLoop 0 = return ()

132 readLoop n = do

133 readLoop n = do

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

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

135+ case e of

134− modifyIORef eventsRef ((:) e)

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

137+ ResumeAfterSignal -> return ()

135 readLoop (n - 1)

138 readLoop (n - 1)

136 genEventsUsingIoActions maxDuration writeWaitClose readEvents

139 genEventsUsingIoActions maxDuration writeWaitClose readEvents

137 outEvents <- reverse <$> readIORef eventsRef

140 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−-- Explicitely definethe bytes that encode each example text.

367+-- Explicitly define the 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+49−38

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

1name: vty

2−version: 5.28

2+version: 5.35.1

3license: BSD3

4license-file: LICENSE

5author: AUTHORS

@@ -45,7 +45,7 @@ library

45 deepseq >= 1.1 && < 1.5,

46 directory,

47 filepath >= 1.0 && < 2.0,

48− microlens < 0.4.12,

48+ microlens < 0.4.13,

49 microlens-mtl,

50 microlens-th,

51 hashable >= 1.2,

@@ -69,6 +69,7 @@ library

69 exposed-modules: Graphics.Vty

70 Graphics.Vty.Attributes

71 Graphics.Vty.Attributes.Color

72+ Graphics.Vty.Attributes.Color240

72 Graphics.Vty.Config

73 Graphics.Vty.Config

73 Graphics.Vty.Error

74 Graphics.Vty.Error

74 Graphics.Vty.Image

75 Graphics.Vty.Image

@@ -104,8 +105,7 @@ library

104 Graphics.Vty.UnicodeWidthTable.Query

105 Graphics.Vty.UnicodeWidthTable.Query

105 Graphics.Vty.UnicodeWidthTable.Install

106 Graphics.Vty.UnicodeWidthTable.Install

106

107

107− other-modules: Graphics.Vty.Attributes.Color240

108+ other-modules: Graphics.Vty.Debug.Image

108− Graphics.Vty.Debug.Image

109 Graphics.Vty.Input.Terminfo.ANSIVT

110

111 c-sources: cbits/gwinsz.c

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

117

118 hs-source-dirs: src

119

120− default-extensions: ScopedTypeVariables

121−

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

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

123

121

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

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

@@ -130,6 +128,9 @@ executable vty-build-width-table

130 default-language: Haskell2010

128 default-language: Haskell2010

131 ghc-options: -threaded -Wall

129 ghc-options: -threaded -Wall

132

130

131+ if !impl(ghc >= 8.0)

132+ build-depends: semigroups >= 0.16

133+

133 build-depends: vty,

134 build-depends: vty,

134 directory,

135 directory,

135 filepath,

136 filepath,

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

140 hs-source-dirs: demos

141 hs-source-dirs: demos

141

142

142 default-language: Haskell2010

143 default-language: Haskell2010

143− default-extensions: ScopedTypeVariables

144 ghc-options: -threaded

145

146 build-depends: vty,

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

155 hs-source-dirs: demos

156

157 default-language: Haskell2010

158− default-extensions: ScopedTypeVariables

159 ghc-options: -threaded

158 ghc-options: -threaded

160

159

161 build-depends: vty,

160 build-depends: vty,

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

167

166

168test-suite verify-using-mock-terminal

167test-suite verify-using-mock-terminal

169 default-language: Haskell2010

168 default-language: Haskell2010

170− default-extensions: ScopedTypeVariables

171

169

172 type: detailed-0.9

170 type: detailed-0.9

173

171

@@ -186,7 +184,7 @@ test-suite verify-using-mock-terminal

186 build-depends: vty,

184 build-depends: vty,

187 Cabal >= 1.20,

185 Cabal >= 1.20,

188 QuickCheck >= 2.7,

186 QuickCheck >= 2.7,

189− random >= 1.0 && < 1.2,

187+ random >= 1.0 && < 1.3,

190 base >= 4.8 && < 5,

188 base >= 4.8 && < 5,

191 bytestring,

189 bytestring,

192 containers,

190 containers,

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

200

198

201test-suite verify-terminal

199test-suite verify-terminal

202 default-language: Haskell2010

200 default-language: Haskell2010

203− default-extensions: ScopedTypeVariables

204

201

205 type: detailed-0.9

202 type: detailed-0.9

206

203

@@ -219,7 +216,7 @@ test-suite verify-terminal

219 build-depends: vty,

216 build-depends: vty,

220 Cabal >= 1.20,

217 Cabal >= 1.20,

221 QuickCheck >= 2.7,

218 QuickCheck >= 2.7,

222− random >= 1.0 && < 1.2,

219+ random >= 1.0 && < 1.3,

223 base >= 4.8 && < 5,

220 base >= 4.8 && < 5,

224 bytestring,

221 bytestring,

225 containers,

222 containers,

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

233

230

234test-suite verify-display-attributes

231test-suite verify-display-attributes

235 default-language: Haskell2010

232 default-language: Haskell2010

236− default-extensions: ScopedTypeVariables

237

233

238 type: detailed-0.9

234 type: detailed-0.9

239

235

@@ -252,7 +248,7 @@ test-suite verify-display-attributes

252 build-depends: vty,

248 build-depends: vty,

253 Cabal >= 1.20,

249 Cabal >= 1.20,

254 QuickCheck >= 2.7,

250 QuickCheck >= 2.7,

255− random >= 1.0 && < 1.2,

251+ random >= 1.0 && < 1.3,

256 base >= 4.8 && < 5,

252 base >= 4.8 && < 5,

257 bytestring,

253 bytestring,

258 containers,

254 containers,

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

265

261

266test-suite verify-empty-image-props

262test-suite verify-empty-image-props

267 default-language: Haskell2010

263 default-language: Haskell2010

268− default-extensions: ScopedTypeVariables

269

264

270 type: detailed-0.9

265 type: detailed-0.9

271

266

@@ -278,7 +273,7 @@ test-suite verify-empty-image-props

278 build-depends: vty,

273 build-depends: vty,

279 Cabal >= 1.20,

274 Cabal >= 1.20,

280 QuickCheck >= 2.7,

275 QuickCheck >= 2.7,

281− random >= 1.0 && < 1.2,

276+ random >= 1.0 && < 1.3,

282 base >= 4.8 && < 5,

277 base >= 4.8 && < 5,

283 bytestring,

278 bytestring,

284 containers,

279 containers,

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

291

286

292test-suite verify-eval-terminfo-caps

287test-suite verify-eval-terminfo-caps

293 default-language: Haskell2010

288 default-language: Haskell2010

294− default-extensions: ScopedTypeVariables

295

289

296 type: detailed-0.9

290 type: detailed-0.9

297

291

@@ -305,7 +299,7 @@ test-suite verify-eval-terminfo-caps

305 build-depends: vty,

299 build-depends: vty,

306 Cabal >= 1.20,

300 Cabal >= 1.20,

307 QuickCheck >= 2.7,

301 QuickCheck >= 2.7,

308− random >= 1.0 && < 1.2,

302+ random >= 1.0 && < 1.3,

309 base >= 4.8 && < 5,

303 base >= 4.8 && < 5,

310 blaze-builder >= 0.3.3.2 && < 0.5,

304 blaze-builder >= 0.3.3.2 && < 0.5,

311 bytestring,

305 bytestring,

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

320

314

321test-suite verify-image-ops

315test-suite verify-image-ops

322 default-language: Haskell2010

316 default-language: Haskell2010

323− default-extensions: ScopedTypeVariables

324

317

325 type: detailed-0.9

318 type: detailed-0.9

326

319

@@ -335,7 +328,7 @@ test-suite verify-image-ops

335 build-depends: vty,

328 build-depends: vty,

336 Cabal >= 1.20,

329 Cabal >= 1.20,

337 QuickCheck >= 2.7,

330 QuickCheck >= 2.7,

338− random >= 1.0 && < 1.2,

331+ random >= 1.0 && < 1.3,

339 base >= 4.8 && < 5,

332 base >= 4.8 && < 5,

340 bytestring,

333 bytestring,

341 containers,

334 containers,

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

348

341

349test-suite verify-image-trans

342test-suite verify-image-trans

350 default-language: Haskell2010

343 default-language: Haskell2010

351− default-extensions: ScopedTypeVariables

352

344

353 type: detailed-0.9

345 type: detailed-0.9

354

346

@@ -363,7 +355,7 @@ test-suite verify-image-trans

363 build-depends: vty,

355 build-depends: vty,

364 Cabal >= 1.20,

356 Cabal >= 1.20,

365 QuickCheck >= 2.7,

357 QuickCheck >= 2.7,

366− random >= 1.0 && < 1.2,

358+ random >= 1.0 && < 1.3,

367 base >= 4.8 && < 5,

359 base >= 4.8 && < 5,

368 bytestring,

360 bytestring,

369 containers,

361 containers,

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

376

368

377test-suite verify-inline

369test-suite verify-inline

378 default-language: Haskell2010

370 default-language: Haskell2010

379− default-extensions: ScopedTypeVariables

380

371

381 type: detailed-0.9

372 type: detailed-0.9

382

373

@@ -390,7 +381,7 @@ test-suite verify-inline

390 build-depends: vty,

381 build-depends: vty,

391 Cabal >= 1.20,

382 Cabal >= 1.20,

392 QuickCheck >= 2.7,

383 QuickCheck >= 2.7,

393− random >= 1.0 && < 1.2,

384+ random >= 1.0 && < 1.3,

394 base >= 4.8 && < 5,

385 base >= 4.8 && < 5,

395 bytestring,

386 bytestring,

396 containers,

387 containers,

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

403

394

404test-suite verify-parse-terminfo-caps

395test-suite verify-parse-terminfo-caps

405 default-language: Haskell2010

396 default-language: Haskell2010

406− default-extensions: ScopedTypeVariables

407

397

408 type: detailed-0.9

398 type: detailed-0.9

409

399

@@ -418,7 +408,7 @@ test-suite verify-parse-terminfo-caps

418 build-depends: vty,

408 build-depends: vty,

419 Cabal >= 1.20,

409 Cabal >= 1.20,

420 QuickCheck >= 2.7,

410 QuickCheck >= 2.7,

421− random >= 1.0 && < 1.2,

411+ random >= 1.0 && < 1.3,

422 base >= 4.8 && < 5,

412 base >= 4.8 && < 5,

423 bytestring,

413 bytestring,

424 containers,

414 containers,

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

432

422

433test-suite verify-simple-span-generation

423test-suite verify-simple-span-generation

434 default-language: Haskell2010

424 default-language: Haskell2010

435− default-extensions: ScopedTypeVariables

436

425

437 type: detailed-0.9

426 type: detailed-0.9

438

427

@@ -450,7 +439,7 @@ test-suite verify-simple-span-generation

450 build-depends: vty,

439 build-depends: vty,

451 Cabal >= 1.20,

440 Cabal >= 1.20,

452 QuickCheck >= 2.7,

441 QuickCheck >= 2.7,

453− random >= 1.0 && < 1.2,

442+ random >= 1.0 && < 1.3,

454 base >= 4.8 && < 5,

443 base >= 4.8 && < 5,

455 bytestring,

444 bytestring,

456 containers,

445 containers,

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

464

453

465test-suite verify-crop-span-generation

454test-suite verify-crop-span-generation

466 default-language: Haskell2010

455 default-language: Haskell2010

467− default-extensions: ScopedTypeVariables

468

456

469 type: detailed-0.9

457 type: detailed-0.9

470

458

@@ -482,7 +470,7 @@ test-suite verify-crop-span-generation

482 build-depends: vty,

470 build-depends: vty,

483 Cabal >= 1.20,

471 Cabal >= 1.20,

484 QuickCheck >= 2.7,

472 QuickCheck >= 2.7,

485− random >= 1.0 && < 1.2,

473+ random >= 1.0 && < 1.3,

486 base >= 4.8 && < 5,

474 base >= 4.8 && < 5,

487 bytestring,

475 bytestring,

488 containers,

476 containers,

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

496

484

497test-suite verify-layers-span-generation

485test-suite verify-layers-span-generation

498 default-language: Haskell2010

486 default-language: Haskell2010

499− default-extensions: ScopedTypeVariables

500

487

501 type: detailed-0.9

488 type: detailed-0.9

502

489

@@ -514,7 +501,32 @@ test-suite verify-layers-span-generation

514 build-depends: vty,

501 build-depends: vty,

515 Cabal >= 1.20,

502 Cabal >= 1.20,

516 QuickCheck >= 2.7,

503 QuickCheck >= 2.7,

517− random >= 1.0 && < 1.2,

504+ random >= 1.0 && < 1.3,

505+ base >= 4.8 && < 5,

506+ bytestring,

507+ containers,

508+ deepseq >= 1.1 && < 1.5,

509+ mtl >= 1.1.1.0 && < 2.3,

510+ text >= 0.11.3,

511+ unix,

512+ utf8-string >= 0.3 && < 1.1,

513+ vector >= 0.7

514+

515+test-suite verify-color-mapping

516+ default-language: Haskell2010

517+

518+ type: detailed-0.9

519+

520+ hs-source-dirs: test

521+

522+ test-module: VerifyColor240

523+

524+ other-modules: Verify

525+

526+ build-depends: vty,

527+ Cabal >= 1.20,

528+ QuickCheck >= 2.7,

529+ random >= 1.0 && < 1.3,

518 base >= 4.8 && < 5,

530 base >= 4.8 && < 5,

519 bytestring,

531 bytestring,

520 containers,

532 containers,

@@ -527,7 +539,6 @@ test-suite verify-layers-span-generation

527

539

528test-suite verify-utf8-width

540test-suite verify-utf8-width

529 default-language: Haskell2010

541 default-language: Haskell2010

530− default-extensions: ScopedTypeVariables

531

542

532 type: detailed-0.9

543 type: detailed-0.9

533

544

@@ -540,7 +551,7 @@ test-suite verify-utf8-width

540 build-depends: vty,

551 build-depends: vty,

541 Cabal >= 1.20,

552 Cabal >= 1.20,

542 QuickCheck >= 2.7,

553 QuickCheck >= 2.7,

543− random >= 1.0 && < 1.2,

554+ random >= 1.0 && < 1.3,

544 base >= 4.8 && < 5,

555 base >= 4.8 && < 5,

545 bytestring,

556 bytestring,

546 containers,

557 containers,

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

553

564

554test-suite verify-using-mock-input

565test-suite verify-using-mock-input

555 default-language: Haskell2010

566 default-language: Haskell2010

556− default-extensions: ScopedTypeVariables

557

567

558 type: exitcode-stdio-1.0

568 type: exitcode-stdio-1.0

559

569

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

561

571

562 main-is: VerifyUsingMockInput.hs

572 main-is: VerifyUsingMockInput.hs

563

573

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

575+

564 build-depends: vty,

576 build-depends: vty,

565 Cabal >= 1.20,

577 Cabal >= 1.20,

566 QuickCheck >= 2.7,

578 QuickCheck >= 2.7,

@@ -568,7 +580,7 @@ test-suite verify-using-mock-input

568 quickcheck-assertions >= 0.1.1,

580 quickcheck-assertions >= 0.1.1,

569 test-framework == 0.8.*,

581 test-framework == 0.8.*,

570 test-framework-smallcheck == 0.2.*,

582 test-framework-smallcheck == 0.2.*,

571− random >= 1.0 && < 1.2,

583+ random >= 1.0 && < 1.3,

572 base >= 4.8 && < 5,

584 base >= 4.8 && < 5,

573 bytestring,

585 bytestring,

574 containers,

586 containers,

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

587

599

588test-suite verify-config

600test-suite verify-config

589 default-language: Haskell2010

601 default-language: Haskell2010

590− default-extensions: ScopedTypeVariables

591

602

592 type: exitcode-stdio-1.0

603 type: exitcode-stdio-1.0

593

604

@@ -604,7 +615,7 @@ test-suite verify-config

604 test-framework == 0.8.*,

615 test-framework == 0.8.*,

605 test-framework-smallcheck == 0.2.*,

616 test-framework-smallcheck == 0.2.*,

606 test-framework-hunit,

617 test-framework-hunit,

607− random >= 1.0 && < 1.2,

618+ random >= 1.0 && < 1.3,

608 base >= 4.8 && < 5,

619 base >= 4.8 && < 5,

609 bytestring,

620 bytestring,

610 containers,

621 containers,