@@ -1,3 +1,4 @@
1+{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE FlexibleInstances #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE CPP #-}
@@ -14,7 +15,7 @@ module Graphics.Vty.Output.TerminfoBased
1415where
1516
1617import Control.Monad (when)
17−import Data.Bits (shiftL, (.&.))
18+import Data.Bits (shiftL)
1819import qualified Data.ByteString as BS
1920import Data.ByteString.Internal (toForeignPtr)
2021import Data.Terminfo.Parse
@@ -25,8 +26,9 @@ import Graphics.Vty.Image (DisplayRegion)
2526import Graphics.Vty.DisplayAttributes
2627import Graphics.Vty.Output.Interface
2728
28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
29+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)
2930
31+import Data.Bits ((.&.))
3032import Data.IORef
3133import Data.Maybe (isJust, isNothing, fromJust)
3234import Data.Word
@@ -49,6 +51,7 @@ data TerminfoCaps = TerminfoCaps
4951 , cup :: CapExpression
5052 , cnorm :: Maybe CapExpression
5153 , civis :: Maybe CapExpression
54+ , supportsNoColors :: Bool
5255 , useAltColorMap :: Bool
5356 , setForeColor :: CapExpression
5457 , setBackColor :: CapExpression
@@ -65,8 +68,6 @@ data DisplayAttrCaps = DisplayAttrCaps
6568 , exitStandout :: Maybe CapExpression
6669 , enterItalic :: Maybe CapExpression
6770 , exitItalic :: Maybe CapExpression
68− , enterStrikethrough :: Maybe CapExpression
69− , exitStrikethrough :: Maybe CapExpression
7071 , enterUnderline :: Maybe CapExpression
7172 , exitUnderline :: Maybe CapExpression
7273 , enterReverseVideo :: Maybe CapExpression
@@ -103,28 +104,28 @@ sendCapToTerminal t cap capParams = do
103104--
104105-- * Providing independent string capabilities for all display
105106-- attributes.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
107−reserveTerminal termName outFd colorMode = do
107+reserveTerminal :: String -> Fd -> IO Output
108+reserveTerminal termName outFd = do
108109 ti <- Terminfo.setupTerm termName
109110 -- assumes set foreground always implies set background exists.
110111 -- if set foreground is not set then all color changing style
111112 -- attributes are filtered.
112113 msetaf <- probeCap ti "setaf"
113114 msetf <- probeCap ti "setf"
114− let (useAlt, setForeCap)
115+ let (noColors, useAlt, setForeCap)
115116 = case msetaf of
116− Just setaf -> (False, setaf)
117+ Just setaf -> (False, False, setaf)
117118 Nothing -> case msetf of
118− Just setf -> (True, setf)
119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
119+ Just setf -> (False, True, setf)
120+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
120121 msetab <- probeCap ti "setab"
121122 msetb <- probeCap ti "setb"
122− let setBackCap
123+ let set_back_cap
123124 = case msetab of
124− Just setab -> setab
125125 Nothing -> case msetb of
126126 Just setb -> setb
127127 Nothing -> error $ "no back color support for terminal " ++ termName
128+ Just setab -> setab
128129
129130 hyperlinkModeStatus <- newIORef False
130131 newAssumedStateRef <- newIORef initialAssumedState
@@ -150,9 +151,10 @@ reserveTerminal termName outFd colorMode = do
150151 <*> requireCap ti "cup"
151152 <*> probeCap ti "cnorm"
152153 <*> probeCap ti "civis"
154+ <*> pure noColors
153155 <*> pure useAlt
154156 <*> pure setForeCap
155− <*> pure setBackCap
157+ <*> pure set_back_cap
156158 <*> requireCap ti "sgr0"
157159 <*> requireCap ti "clear"
158160 <*> requireCap ti "el"
@@ -164,10 +166,6 @@ reserveTerminal termName outFd colorMode = do
164166 sendCap setDefaultAttr []
165167 maybeSendCap cnorm []
166168 , 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))
171169 , ringTerminalBell = maybeSendCap ringBellAudio []
172170 , reserveDisplay = do
173171 -- If there is no support for smcup: Clear the screen
@@ -192,15 +190,20 @@ reserveTerminal termName outFd colorMode = do
192190 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
193191 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
194192 ++ " Please report this bug to vty project."
193+ , contextColorCount
194+ = case supportsNoColors terminfoCaps of
195+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
196+ Nothing -> 8
197+ Just v -> toEnum v
198+ True -> 1
195199 , supportsCursorVisibility = isJust $ civis terminfoCaps
196200 , supportsMode = terminfoModeSupported
197201 , setMode = terminfoSetMode
198202 , getModeStatus = terminfoModeStatus
199203 , assumedStateRef = newAssumedStateRef
200− , outputColorMode = colorMode
201204 -- I think fix would help assure tActual is the only
202205 -- reference. I was having issues tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
206+ , mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps
204207 }
205208 sendCap s = sendCapToTerminal t (s terminfoCaps)
206209 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
@@ -232,8 +235,6 @@ currentDisplayAttrCaps ti
232235 <*> probeCap ti "rmso"
233236 <*> probeCap ti "sitm"
234237 <*> probeCap ti "ritm"
235− <*> probeCap ti "smxx"
236− <*> probeCap ti "rmxx"
237238 <*> probeCap ti "smul"
238239 <*> probeCap ti "rmul"
239240 <*> probeCap ti "rev"
@@ -269,11 +270,7 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
269270 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270271 , writeDefaultAttr = \urlsEnabled ->
271272 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274− Just cap -> writeCapExpr cap []
275− Nothing -> mempty
276− )
273+ (if urlsEnabled then writeURLEscapes EndLink else mempty)
277274 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
278275 , inlineHack = return ()
279276 }
@@ -295,7 +292,7 @@ writeURLEscapes NoLinkChange =
295292-- | Portably setting the display attributes is a giant pain in the ass.
296293--
297294-- If the terminal supports the sgr capability (which sets the on/off
298−-- state of each style directly; and, for no good reason, resets the
295+-- state of each style directly ; and, for no good reason, resets the
299296-- colors to the default) this procedure is used:
300297--
301298-- 0. set the style attributes. This resets the fore and back color.
@@ -334,9 +331,9 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
334331 -- The only way to reset either color, portably, to the default
335332 -- is to use either the set state capability or the set default
336333 -- capability.
337− True -> do
334+ True -> do
338335 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
339− (fixedStyle attr)
336+ (fixedStyle attr )
340337 (styleToApplySeq $ fixedStyle attr) of
341338 -- only way to reset a color to the defaults
342339 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
@@ -346,11 +343,11 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
346343 setColors
347344 -- implicitly resets the colors to the defaults
348345 SetState state -> writeCapExpr (fromJust $ setAttrStates
349− $ displayAttrCaps terminfoCaps
346+ $ displayAttrCaps
347+ $ terminfoCaps
350348 )
351349 (sgrArgsForState state)
352350 `mappend` setItalics
353− `mappend` setStrikethrough
354351 `mappend` setColors
355352 -- Otherwise the display colors are not changing or changing
356353 -- between two non-default points.
@@ -369,16 +366,15 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
369366 -- applied states.
370367 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
371368 `mappend`
372− writeColorDiff Foreground (foreColorDiff diffs)
369+ writeColorDiff setForeColor (foreColorDiff diffs)
373370 `mappend`
374− writeColorDiff Background (backColorDiff diffs)
371+ writeColorDiff setBackColor (backColorDiff diffs)
375372 -- implicitly resets the colors to the defaults
376373 SetState state -> writeCapExpr (fromJust $ setAttrStates
377374 $ displayAttrCaps terminfoCaps
378375 )
379376 (sgrArgsForState state)
380377 `mappend` setItalics
381− `mappend` setStrikethrough
382378 `mappend` setColors
383379 where
384380 urlAttrs True = writeURLEscapes (urlDiff diffs)
@@ -396,72 +392,31 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
396392 , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
397393 = writeCapExpr sitm []
398394 | otherwise = mempty
399− setStrikethrough
400− | hasStyle (fixedStyle attr) strikethrough
401− , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
402− = writeCapExpr smxx []
403− | otherwise = mempty
404395 setColors =
405396 (case fixedForeColor attr of
406− Just c -> writeColor Foreground c
397+ Just c -> writeCapExpr (setForeColor terminfoCaps)
398+ [toEnum $ colorMap c]
407399 Nothing -> mempty)
408400 `mappend`
409401 (case fixedBackColor attr of
410− Just c -> writeColor Background c
402+ Just c -> writeCapExpr (setBackColor terminfoCaps)
403+ [toEnum $ colorMap c]
411404 Nothing -> mempty)
412− writeColorDiff _side NoColorChange
405+ writeColorDiff _f NoColorChange
413406 = mempty
414− writeColorDiff _side ColorToDefault
407+ writeColorDiff _f ColorToDefault
415408 = error "ColorToDefault is not a possible case for applyColorDiffs"
416− writeColorDiff side (SetColor c)
417− = writeColor side c
418−
419− writeColor side (RGBColor r g b) =
420− case outputColorMode (contextDevice dc) of
421− FullColor ->
422− hardcodeColor side (r, g, b)
423− _ ->
424− error "clampColor should remove rgb colors in standard mode"
425− writeColor side c =
426− writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]
427−
428−-- a color can either be in the foreground or the background
429−data ColorSide = Foreground | Background
430−
431−-- get the capability for drawing a color on a specific side
432−setSideColor :: ColorSide -> TerminfoCaps -> CapExpression
433−setSideColor Foreground = setForeColor
434−setSideColor Background = setBackColor
435−
436−hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write
437−hardcodeColor side (r, g, b) =
438− -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"
439− mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter
440− , writeColor r, delimiter, writeColor g, delimiter, writeColor b
441− , writeChar 'm']
442− where
443− writeChar = writeWord8 . fromIntegral . fromEnum
444− writeStr = mconcat . map writeChar
445− writeColor = writeStr . show
446− delimiter = writeChar ';'
447− -- 38/48 are used to set whether we should write to the
448− -- foreground/background. I really don't want to know why.
449− sideCode = case side of
450− Foreground -> writeStr "38"
451− Background -> writeStr "48"
409+ writeColorDiff f (SetColor c)
410+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
452411
453412-- | The color table used by a terminal is a 16 color set followed by a
454413-- 240 color set that might not be supported by the terminal.
455414--
456−-- This takes a Color which clearly identifies which palette to use and
457−-- computes the index into the full 256 color palette.
415+-- This takes a Color which clearly identifies which pallete to use and
416+-- computes the index into the full 256 color pallete.
458417ansiColorIndex :: Color -> Int
459418ansiColorIndex (ISOColor v) = fromEnum v
460419ansiColorIndex (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− ]
465420
466421-- | For terminals without setaf/setab
467422--
@@ -478,10 +433,6 @@ altColorIndex (ISOColor 6) = 3
478433altColorIndex (ISOColor 7) = 7
479434altColorIndex (ISOColor v) = fromEnum v
480435altColorIndex (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− ]
485436
486437{- | The sequence of terminfo caps to apply a given style are determined
487438 - according to these rules.
@@ -509,7 +460,6 @@ data DisplayAttrState = DisplayAttrState
509460 { applyStandout :: Bool
510461 , applyUnderline :: Bool
511462 , applyItalic :: Bool
512− , applyStrikethrough :: Bool
513463 , applyReverseVideo :: Bool
514464 , applyBlink :: Bool
515465 , applyDim :: Bool
@@ -546,8 +496,6 @@ reqDisplayCapSeqFor caps s diffs
546496 -- set state cap then just use the set state cap.
547497 ( True, True ) -> SetState $ stateForStyle s
548498 where
549− noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps
550− noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps
551499 noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
552500 noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
553501 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
@@ -562,8 +510,6 @@ reqDisplayCapSeqFor caps s diffs
562510 noEnterExitCap RemoveDim = True
563511 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
564512 noEnterExitCap RemoveBold = True
565− enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
566− enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
567513 enterExitCap ApplyItalic = fromJust $ enterItalic caps
568514 enterExitCap RemoveItalic = fromJust $ exitItalic caps
569515 enterExitCap ApplyStandout = fromJust $ enterStandout caps
@@ -580,7 +526,6 @@ stateForStyle s = DisplayAttrState
580526 { applyStandout = isStyleSet standout
581527 , applyUnderline = isStyleSet underline
582528 , applyItalic = isStyleSet italic
583− , applyStrikethrough = isStyleSet strikethrough
584529 , applyReverseVideo = isStyleSet reverseVideo
585530 , applyBlink = isStyleSet blink
586531 , applyDim = isStyleSet dim
@@ -593,7 +538,6 @@ styleToApplySeq s = concat
593538 [ applyIfRequired ApplyStandout standout
594539 , applyIfRequired ApplyUnderline underline
595540 , applyIfRequired ApplyItalic italic
596− , applyIfRequired ApplyStrikethrough strikethrough
597541 , applyIfRequired ApplyReverseVideo reverseVideo
598542 , applyIfRequired ApplyBlink blink
599543 , applyIfRequired ApplyDim dim