7475b75 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

Merge pull request #182 from u-quark/directcolor

7475b75Jonathan Daugherty5 years ago

demos/Demo.hs+11−3

compare with master

unifiedsplit

@@ -32,6 +32,7 @@ introText = vertCat $ map (string defAttr)

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

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 ]

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

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

src/Graphics/Vty/Attributes/Color.hs+66−2

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

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveAnyClass #-}

3+{-# LANGUAGE MultiWayIf #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4module Graphics.Vty.Attributes.Color

6module Graphics.Vty.Attributes.Color

5 ( Color(..)

7 ( Color(..)

8+ , ColorMode(..)

10+ -- * Detecting Terminal Color Support

11+ , detectColorMode

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

44import Graphics.Vty.Attributes.Color240

58import Graphics.Vty.Attributes.Color240

@@ -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/Config.hs+10−1

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

@@ -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/Output.hs+4−3

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

67 case mouseMode of

68 case mouseMode of

68 Just s -> setMode t Mouse s

69 Just s -> setMode t Mouse s

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

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

79 , displayBounds :: IO DisplayRegion

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

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

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

83− -- context.

84− , contextColorCount :: Int

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

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

86 , supportsCursorVisibility :: Bool

83 , supportsCursorVisibility :: Bool

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

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

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

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

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

118 -- desired.

115 -- desired.

119 , supportsStrikethrough :: IO Bool

116 , supportsStrikethrough :: IO Bool

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

118+ , outputColorMode :: ColorMode

120 }

119 }

121

120

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

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

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

310 where

309 where

311 clampColor Default = Default

310 clampColor Default = Default

312 clampColor KeepCurrent = KeepCurrent

311 clampColor KeepCurrent = KeepCurrent

313− clampColor (SetTo c) = clampColor' c

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

313+

314− clampColor' (ISOColor v)

314+ clampColor' NoColor _ = Default

315− | contextColorCount t < 8 = Default

315+

316+ clampColor' ColorMode8 (ISOColor v)

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

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

317− | otherwise = SetTo $ ISOColor v

318+ | otherwise = SetTo $ ISOColor v

318− clampColor' (Color240 v)

319+ clampColor' ColorMode8 _ = Default

319− -- Should we choose closest ISO color?

320+

320− | contextColorCount t < 8 = Default

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

321− | contextColorCount t < 16 = Default

322+ clampColor' ColorMode16 _ = Default

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

323− | otherwise

327+ | otherwise = Default

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

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

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

329+ clampColor' colorMode (color240 r g b)

326− in SetTo $ Color240 v'

330+

331+ clampColor' FullColor c = SetTo c

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

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

11where

13import Graphics.Vty.Image (DisplayRegion)

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

14import Graphics.Vty.Output.Interface

15import Graphics.Vty.Output.Interface

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

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

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

55 , outputByteBuffer = \bytes -> do

56 , outputByteBuffer = \bytes -> do

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

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

57 writeIORef outRef $ UTF8.fromRep bytes

58 writeIORef outRef $ UTF8.fromRep bytes

58− , contextColorCount = 16

59 , supportsCursorVisibility = True

60 , supportsMode = const False

61 , setMode = const $ const $ return ()

62 , getModeStatus = const $ return False

63 , assumedStateRef = newAssumedStateRef

64+ , outputColorMode = ColorMode16

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

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

65 { contextRegion = rActual

66 { contextRegion = rActual

66 , contextDevice = tActual

67 , contextDevice = tActual

src/Graphics/Vty/Output/TerminfoBased.hs+64−31

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

25import Graphics.Vty.DisplayAttributes

26import Graphics.Vty.Output.Interface

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

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

30import Data.IORef

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

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

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

104--

103--

105-- * Providing independent string capabilities for all display

104-- * Providing independent string capabilities for all display

106-- attributes.

105-- attributes.

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

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

108−reserveTerminal termName outFd = do

107+reserveTerminal termName outFd colorMode = do

109 ti <- Terminfo.setupTerm termName

108 ti <- Terminfo.setupTerm termName

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

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

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

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

112 -- attributes are filtered.

111 -- attributes are filtered.

113 msetaf <- probeCap ti "setaf"

112 msetaf <- probeCap ti "setaf"

114 msetf <- probeCap ti "setf"

113 msetf <- probeCap ti "setf"

115− let (noColors, useAlt, setForeCap)

114+ let (useAlt, setForeCap)

116 = case msetaf of

115 = case msetaf of

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

116+ Just setaf -> (False, setaf)

118 Nothing -> case msetf of

117 Nothing -> case msetf of

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

118+ Just setf -> (True, setf)

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

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

121 msetab <- probeCap ti "setab"

120 msetab <- probeCap ti "setab"

122 msetb <- probeCap ti "setb"

121 msetb <- probeCap ti "setb"

123− let set_back_cap

122+ let setBackCap

124 = case msetab of

123 = case msetab of

124+ Just setab -> setab

125 Nothing -> case msetb of

126 Just setb -> setb

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

128− Just setab -> setab

129

128

130 hyperlinkModeStatus <- newIORef False

129 hyperlinkModeStatus <- newIORef False

131 newAssumedStateRef <- newIORef initialAssumedState

130 newAssumedStateRef <- newIORef initialAssumedState

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

151 <*> requireCap ti "cup"

150 <*> requireCap ti "cup"

152 <*> probeCap ti "cnorm"

151 <*> probeCap ti "cnorm"

153 <*> probeCap ti "civis"

152 <*> probeCap ti "civis"

154− <*> pure noColors

155 <*> pure useAlt

153 <*> pure useAlt

156 <*> pure setForeCap

154 <*> pure setForeCap

157− <*> pure set_back_cap

155+ <*> pure setBackCap

158 <*> requireCap ti "sgr0"

156 <*> requireCap ti "sgr0"

159 <*> requireCap ti "clear"

157 <*> requireCap ti "clear"

160 <*> requireCap ti "el"

158 <*> requireCap ti "el"

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

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

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

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

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

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

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

197− , contextColorCount

198− = case supportsNoColors terminfoCaps of

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

200− Nothing -> 8

201− Just v -> toEnum v

202− True -> 1

203 , supportsCursorVisibility = isJust $ civis terminfoCaps

195 , supportsCursorVisibility = isJust $ civis terminfoCaps

204 , supportsMode = terminfoModeSupported

196 , supportsMode = terminfoModeSupported

205 , setMode = terminfoSetMode

197 , setMode = terminfoSetMode

206 , getModeStatus = terminfoModeStatus

198 , getModeStatus = terminfoModeStatus

207 , assumedStateRef = newAssumedStateRef

199 , assumedStateRef = newAssumedStateRef

200+ , outputColorMode = colorMode

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

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

209 -- reference. I was having issues tho.

202 -- reference. I was having issues tho.

210 , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

203 , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)

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

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

303--

296--

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

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

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

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

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

307--

300--

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

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

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

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

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

343 -- capability.

336 -- capability.

344− True -> do

337+ True -> do

345 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

346− (fixedStyle attr )

339+ (fixedStyle attr)

347 (styleToApplySeq $ fixedStyle attr) of

340 (styleToApplySeq $ fixedStyle attr) of

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

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

349 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

342 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled

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

376 -- applied states.

369 -- applied states.

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

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

378 `mappend`

371 `mappend`

379− writeColorDiff setForeColor (foreColorDiff diffs)

372+ writeColorDiff Foreground (foreColorDiff diffs)

380 `mappend`

373 `mappend`

381− writeColorDiff setBackColor (backColorDiff diffs)

374+ writeColorDiff Background (backColorDiff diffs)

382 -- implicitly resets the colors to the defaults

375 -- implicitly resets the colors to the defaults

383 SetState state -> writeCapExpr (fromJust $ setAttrStates

376 SetState state -> writeCapExpr (fromJust $ setAttrStates

384 $ displayAttrCaps terminfoCaps

377 $ displayAttrCaps terminfoCaps

@@ -410,20 +403,52 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

410 | otherwise = mempty

403 | otherwise = mempty

411 setColors =

404 setColors =

412 (case fixedForeColor attr of

405 (case fixedForeColor attr of

413− Just c -> writeCapExpr (setForeColor terminfoCaps)

406+ Just c -> writeColor Foreground c

414− [toEnum $ colorMap c]

415 Nothing -> mempty)

407 Nothing -> mempty)

416 `mappend`

408 `mappend`

417 (case fixedBackColor attr of

409 (case fixedBackColor attr of

418− Just c -> writeCapExpr (setBackColor terminfoCaps)

410+ Just c -> writeColor Background c

419− [toEnum $ colorMap c]

420 Nothing -> mempty)

411 Nothing -> mempty)

421− writeColorDiff _f NoColorChange

412+ writeColorDiff _side NoColorChange

422 = mempty

413 = mempty

423− writeColorDiff _f ColorToDefault

414+ writeColorDiff _side ColorToDefault

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

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

425− 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 =

426− = 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"

427

452

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

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

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

@@ -433,6 +458,10 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =

433ansiColorIndex :: Color -> Int

458ansiColorIndex :: Color -> Int

434ansiColorIndex (ISOColor v) = fromEnum v

459ansiColorIndex (ISOColor v) = fromEnum v

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

436

465

437-- | For terminals without setaf/setab

466-- | For terminals without setaf/setab

438--

467--

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

449altColorIndex (ISOColor 7) = 7

478altColorIndex (ISOColor 7) = 7

450altColorIndex (ISOColor v) = fromEnum v

479altColorIndex (ISOColor v) = fromEnum v

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

452

485

453{- | 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

454 - according to these rules.

487 - according to these rules.

src/Graphics/Vty/Output/XTermColor.hs+4−3

@@ -10,6 +10,7 @@ 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

15import Blaze.ByteString.Builder (writeToByteString)

16import Blaze.ByteString.Builder (writeToByteString)

@@ -42,8 +43,8 @@ fdWrite fd s =

42 fdWriteBuf fd (castPtr buf) (fromIntegral len)

43 fdWriteBuf fd (castPtr buf) (fromIntegral len)

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

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

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

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

46−reserveTerminal variant outFd = liftIO $ do

47+reserveTerminal variant outFd colorMode = liftIO $ do

47 let flushedPut = void . fdWrite outFd

48 let flushedPut = void . fdWrite outFd

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

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

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

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

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

52 utf8a <- utf8Active

53 utf8a <- utf8Active

53 when (not utf8a) $ flushedPut setUtf8CharSet

54 when (not utf8a) $ flushedPut setUtf8CharSet

54− t <- TerminfoBased.reserveTerminal variant' outFd

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

56 mouseModeStatus <- newIORef False

57 mouseModeStatus <- newIORef False

57 focusModeStatus <- newIORef False

58 focusModeStatus <- newIORef False

test/VerifyOutput.hs+5−1

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

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

36smokeTestTerm termName i = do

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

38− 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+ }

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

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

40 reserveDisplay t

44 reserveDisplay t

41 dc <- displayContext t (100,100)

45 dc <- displayContext t (100,100)