@@ -1,54 +1,52 @@
1−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleInstances #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
7−-- | Terminfo-based terminal output driver.
6+-- | Terminfo based terminal handling.
8+-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
9+-- have easy access to then color support is entirely based of the docs. Probably with some
10+-- assumptions mixed in.
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10−module Graphics.Vty.Output.TerminfoBased
13+module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )
16+import Graphics.Vty.Prelude
16−import Control.Monad (when)
17−import Data.Bits (shiftL, (.&.))
18−import qualified Data.ByteString as BS
19import Data.ByteString.Internal (toForeignPtr)
18import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
19import Data.Terminfo.Parse
21import Data.Terminfo.Eval
20import Data.Terminfo.Eval
23import Graphics.Vty.Attributes
22import Graphics.Vty.Attributes
24−import Graphics.Vty.Image (DisplayRegion)
25import Graphics.Vty.DisplayAttributes
23import Graphics.Vty.DisplayAttributes
26import Graphics.Vty.Output.Interface
24import Graphics.Vty.Output.Interface
28−import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
26+import Blaze.ByteString.Builder (Write, writeToByteString)
30−import Data.IORef
28+import Control.Monad.Trans
31−import Data.Maybe (isJust, isNothing, fromJust)
34−#if !MIN_VERSION_base(4,8,0)
30+import Data.Bits ((.&.))
35import Data.Foldable (foldMap)
31import Data.Foldable (foldMap)
36−#endif
32+import Data.IORef
33+import Data.Maybe (isJust, isNothing, fromJust)
38import Foreign.C.Types ( CInt(..), CLong(..) )
36import Foreign.C.Types ( CInt(..), CLong(..) )
39import Foreign.ForeignPtr (withForeignPtr)
37import Foreign.ForeignPtr (withForeignPtr)
40−import Foreign.Ptr (Ptr, plusPtr)
42import qualified System.Console.Terminfo as Terminfo
39import qualified System.Console.Terminfo as Terminfo
43import System.Posix.IO (fdWriteBuf)
40import System.Posix.IO (fdWriteBuf)
44import System.Posix.Types (Fd(..))
41import System.Posix.Types (Fd(..))
46−data TerminfoCaps = TerminfoCaps
43+data TerminfoCaps = TerminfoCaps
47 { smcup :: Maybe CapExpression
44 { smcup :: Maybe CapExpression
48 , rmcup :: Maybe CapExpression
45 , rmcup :: Maybe CapExpression
49 , cup :: CapExpression
46 , cup :: CapExpression
50 , cnorm :: Maybe CapExpression
47 , cnorm :: Maybe CapExpression
51 , civis :: Maybe CapExpression
48 , civis :: Maybe CapExpression
49+ , supportsNoColors :: Bool
52 , useAltColorMap :: Bool
50 , useAltColorMap :: Bool
53 , setForeColor :: CapExpression
51 , setForeColor :: CapExpression
54 , setBackColor :: CapExpression
52 , setBackColor :: CapExpression
@@ -56,184 +54,135 @@ data TerminfoCaps = TerminfoCaps
56 , clearScreen :: CapExpression
54 , clearScreen :: CapExpression
57 , clearEol :: CapExpression
55 , clearEol :: CapExpression
58 , displayAttrCaps :: DisplayAttrCaps
56 , displayAttrCaps :: DisplayAttrCaps
59− , ringBellAudio :: Maybe CapExpression
62data DisplayAttrCaps = DisplayAttrCaps
59data DisplayAttrCaps = DisplayAttrCaps
63 { setAttrStates :: Maybe CapExpression
60 { setAttrStates :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
61 , enterStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
62 , exitStandout :: Maybe CapExpression
66− , enterItalic :: Maybe CapExpression
67− , exitItalic :: Maybe CapExpression
68− , enterStrikethrough :: Maybe CapExpression
69− , exitStrikethrough :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
63 , enterUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
64 , exitUnderline :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
65 , enterReverseVideo :: Maybe CapExpression
73 , enterDimMode :: Maybe CapExpression
66 , enterDimMode :: Maybe CapExpression
74 , enterBoldMode :: Maybe CapExpression
67 , enterBoldMode :: Maybe CapExpression
78−-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
79−-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
80−-- the write will be retried.
81−fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
82−fdWriteAll outFd ptr len count
83− | len < 0 = fail "fdWriteAll: len is less than 0"
84− | len == 0 = return count
86− writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)
87− let len' = len - writeCount
88− ptr' = ptr `plusPtr` writeCount
89− count' = count + writeCount
90− fdWriteAll outFd ptr' len' count'
92sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
70sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
93sendCapToTerminal t cap capParams = do
71sendCapToTerminal t cap capParams = do
94 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
72 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
96−-- | Constructs an output driver that uses terminfo for all control
97−-- codes. While this should provide the most compatible terminal,
74+{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
98−-- terminfo does not support some features that would increase
75+ - terminfo does not support some features that would increase efficiency and improve compatibility:
99−-- efficiency and improve compatibility:
76+ -
101−-- * determining the character encoding supported by the terminal.
77+ - * determine the character encoding supported by the terminal. Should this be taken from the LANG
102−-- Should this be taken from the LANG environment variable?
78+ - environment variable?
104−-- * Providing independent string capabilities for all display
80+ - * Provide independent string capabilities for all display attributes.
82+ - todo: Some display attributes like underline and bold have independent string capabilities that
83+ - should be used instead of the generic "sgr" string capability.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
85+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
107−reserveTerminal termName outFd colorMode = do
86+reserveTerminal termName outFd = liftIO $ do
108 ti <- Terminfo.setupTerm termName
87 ti <- Terminfo.setupTerm termName
109 -- assumes set foreground always implies set background exists.
88 -- assumes set foreground always implies set background exists.
110− -- if set foreground is not set then all color changing style
89+ -- if set foreground is not set then all color changing style attributes are filtered.
111− -- attributes are filtered.
112 msetaf <- probeCap ti "setaf"
90 msetaf <- probeCap ti "setaf"
113 msetf <- probeCap ti "setf"
91 msetf <- probeCap ti "setf"
114− let (useAlt, setForeCap)
92+ let (noColors, useAlt, setForeCap)
115 = case msetaf of
93 = case msetaf of
116− Just setaf -> (False, setaf)
94+ Just setaf -> (False, False, setaf)
117 Nothing -> case msetf of
95 Nothing -> case msetf of
118− Just setf -> (True, setf)
96+ Just setf -> (False, True, setf)
119− Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
97+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
120 msetab <- probeCap ti "setab"
98 msetab <- probeCap ti "setab"
121 msetb <- probeCap ti "setb"
99 msetb <- probeCap ti "setb"
122− let setBackCap
100+ let set_back_cap
123 = case msetab of
101 = case msetab of
125 Nothing -> case msetb of
102 Nothing -> case msetb of
126 Just setb -> setb
103 Just setb -> setb
127 Nothing -> error $ "no back color support for terminal " ++ termName
104 Nothing -> error $ "no back color support for terminal " ++ termName
128−
105+ Just setab -> setab
129− hyperlinkModeStatus <- newIORef False
130− newAssumedStateRef <- newIORef initialAssumedState
132− let terminfoSetMode m newStatus = do
133− curStatus <- terminfoModeStatus m
134− when (newStatus /= curStatus) $
137− writeIORef hyperlinkModeStatus newStatus
138− writeIORef newAssumedStateRef initialAssumedState
140− terminfoModeStatus m =
142− Hyperlink -> readIORef hyperlinkModeStatus
144− terminfoModeSupported Hyperlink = True
145− terminfoModeSupported _ = False
147 terminfoCaps <- pure TerminfoCaps
106 terminfoCaps <- pure TerminfoCaps
148 <*> probeCap ti "smcup"
107 <*> probeCap ti "smcup"
149 <*> probeCap ti "rmcup"
108 <*> probeCap ti "rmcup"
150 <*> requireCap ti "cup"
109 <*> requireCap ti "cup"
151 <*> probeCap ti "cnorm"
110 <*> probeCap ti "cnorm"
152 <*> probeCap ti "civis"
111 <*> probeCap ti "civis"
153 <*> pure useAlt
113 <*> pure useAlt
154 <*> pure setForeCap
114 <*> pure setForeCap
155− <*> pure setBackCap
115+ <*> pure set_back_cap
156 <*> requireCap ti "sgr0"
116 <*> requireCap ti "sgr0"
157 <*> requireCap ti "clear"
117 <*> requireCap ti "clear"
158 <*> requireCap ti "el"
118 <*> requireCap ti "el"
159 <*> currentDisplayAttrCaps ti
119 <*> currentDisplayAttrCaps ti
160− <*> probeCap ti "bel"
120+ newAssumedStateRef <- newIORef initialAssumedState
161 let t = Output
121 let t = Output
162 { terminalID = termName
122 { terminalID = termName
163− , releaseTerminal = do
123+ , releaseTerminal = liftIO $ do
164 sendCap setDefaultAttr []
124 sendCap setDefaultAttr []
165 maybeSendCap cnorm []
125 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))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
172− , reserveDisplay = do
126+ , reserveDisplay = liftIO $ do
173− -- If there is no support for smcup: Clear the screen
127+ -- If there is no support for smcup: Clear the screen and then move the mouse to the
174− -- and then move the mouse to the home position to
175− -- approximate the behavior.
128+ -- home position to approximate the behavior.
176 maybeSendCap smcup []
129 maybeSendCap smcup []
177 sendCap clearScreen []
130 sendCap clearScreen []
178− , releaseDisplay = do
131+ , releaseDisplay = liftIO $ do
179 maybeSendCap rmcup []
132 maybeSendCap rmcup []
180 maybeSendCap cnorm []
133 maybeSendCap cnorm []
181− , setDisplayBounds = \(w, h) ->
182− setWindowSize outFd (w, h)
183 , displayBounds = do
134 , displayBounds = do
184− rawSize <- getWindowSize outFd
135+ rawSize <- liftIO $ getWindowSize outFd
185 case rawSize of
136 case rawSize of
186 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
137 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
187 | otherwise -> return (w,h)
138 | otherwise -> return (w,h)
188 , outputByteBuffer = \outBytes -> do
139 , outputByteBuffer = \outBytes -> do
189− let (fptr, offset, len) = toForeignPtr outBytes
140+ let (fptr, _offset, len) = toForeignPtr outBytes
190− actualLen <- withForeignPtr fptr
141+ actualLen <- withForeignPtr fptr $ \ptr -> fdWriteBuf outFd ptr (toEnum len)
191− $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0
192− when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
142+ when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer length "
193− ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
194− ++ " Please report this bug to vty project."
143+ ++ "mismatch. Please report a bug to vty project."
145+ = case supportsNoColors terminfoCaps of
146+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
150 , supportsCursorVisibility = isJust $ civis terminfoCaps
196− , supportsMode = terminfoModeSupported
197− , setMode = terminfoSetMode
198− , getModeStatus = terminfoModeStatus
199 , assumedStateRef = newAssumedStateRef
151 , assumedStateRef = newAssumedStateRef
200− , outputColorMode = colorMode
201− -- I think fix would help assure tActual is the only
152+ -- I think fix would help assure tActual is the only reference. I was having issues
202− -- reference. I was having issues tho.
153+ -- tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
154+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
156 sendCap s = sendCapToTerminal t (s terminfoCaps)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
157 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
209−requireCap :: Terminfo.Terminal -> String -> IO CapExpression
160+requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
210−requireCap ti capName
161+requireCap ti capName
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
162 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
163 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
213 Just capStr -> parseCap capStr
164 Just capStr -> parseCap capStr
215−probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
166+probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
216−probeCap ti capName
167+probeCap ti capName
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
168 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
218 Nothing -> return Nothing
169 Nothing -> return Nothing
219 Just capStr -> Just <$> parseCap capStr
170 Just capStr -> Just <$> parseCap capStr
221−parseCap :: String -> IO CapExpression
172+parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
222parseCap capStr = do
173parseCap capStr = do
223 case parseCapExpression capStr of
174 case parseCapExpression capStr of
224 Left e -> fail $ show e
175 Left e -> fail $ show e
225 Right cap -> return cap
176 Right cap -> return cap
227−currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
178+currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
179+ => Terminfo.Terminal
180+ -> m DisplayAttrCaps
228−currentDisplayAttrCaps ti
181+currentDisplayAttrCaps ti
229− = pure DisplayAttrCaps
182+ = pure DisplayAttrCaps
230 <*> probeCap ti "sgr"
183 <*> probeCap ti "sgr"
231 <*> probeCap ti "smso"
184 <*> probeCap ti "smso"
232 <*> probeCap ti "rmso"
185 <*> probeCap ti "rmso"
233− <*> probeCap ti "sitm"
234− <*> probeCap ti "ritm"
235− <*> probeCap ti "smxx"
236− <*> probeCap ti "rmxx"
237 <*> probeCap ti "smul"
186 <*> probeCap ti "smul"
238 <*> probeCap ti "rmul"
187 <*> probeCap ti "rmul"
239 <*> probeCap ti "rev"
188 <*> probeCap ti "rev"
@@ -243,17 +192,10 @@ currentDisplayAttrCaps ti
243foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
192foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
245getWindowSize :: Fd -> IO (Int,Int)
194getWindowSize :: Fd -> IO (Int,Int)
246−getWindowSize fd = do
195+getWindowSize fd = do
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
196 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
248 return (fromIntegral b, fromIntegral a)
197 return (fromIntegral b, fromIntegral a)
250−foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO ()
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
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
199terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
258terminfoDisplayContext tActual terminfoCaps r = return dc
200terminfoDisplayContext tActual terminfoCaps r = return dc
259 where dc = DisplayContext
201 where dc = DisplayContext
@@ -267,204 +209,123 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
267 Nothing -> error "this terminal does not support hide cursor"
209 Nothing -> error "this terminal does not support hide cursor"
268 Just c -> writeCapExpr c []
210 Just c -> writeCapExpr c []
269 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
211 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
270− , writeDefaultAttr = \urlsEnabled ->
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
212+ , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274− Just cap -> writeCapExpr cap []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
213 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
278 , inlineHack = return ()
214 , inlineHack = return ()
281−-- | Write the escape sequences that are used in some terminals to
282−-- include embedded hyperlinks. As of yet, this information isn't
283−-- included in termcap or terminfo, so this writes them directly
284−-- instead of looking up the appropriate capabilities.
285−writeURLEscapes :: URLDiff -> Write
286−writeURLEscapes (LinkTo url) =
287− foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
288− foldMap writeStorable (BS.unpack url) `mappend`
289− writeStorable (0x07 :: Word8)
290−writeURLEscapes EndLink =
291− foldMap writeStorable (BS.unpack "\x1b]8;;\a")
292−writeURLEscapes NoLinkChange =
295-- | Portably setting the display attributes is a giant pain in the ass.
217-- | Portably setting the display attributes is a giant pain in the ass.
297−-- If the terminal supports the sgr capability (which sets the on/off
219+-- If the terminal supports the sgr capability (which sets the on/off state of each style
298−-- state of each style directly; and, for no good reason, resets the
299−-- colors to the default) this procedure is used:
220+-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
301-- 0. set the style attributes. This resets the fore and back color.
222-- 0. set the style attributes. This resets the fore and back color.
303-- 1, If a foreground color is to be set then set the foreground color
224-- 1, If a foreground color is to be set then set the foreground color
305-- 2. likewise with the background color
226-- 2. likewise with the background color
228+-- If the terminal does not support the sgr cap then:
229+-- if there is a change from an applied color to the default (in either the fore or back color)
307−-- If the terminal does not support the sgr cap then: if there is a
308−-- change from an applied color to the default (in either the fore or
311−-- 0. reset all display attributes (sgr0)
232+-- 0. reset all display attributes (sgr0)
313−-- 1. enter required style modes
234+-- 1. enter required style modes
315−-- 2. set the fore color if required
236+-- 2. set the fore color if required
317−-- 3. set the back color if required
238+-- 3. set the back color if required
319−-- Entering the required style modes could require a reset of the
240+-- Entering the required style modes could require a reset of the display attributes. If this is
320−-- display attributes. If this is the case then the back and fore colors
321−-- always need to be set if not default.
241+-- the case then the back and fore colors always need to be set if not default.
323-- This equation implements the above logic.
243-- This equation implements the above logic.
325−-- Note that this assumes the removal of color changes in the
245+-- \todo This assumes the removal of color changes in the display attributes is done as expected
326−-- display attributes is done as expected with noColors == True. See
246+-- with noColors == True. See `limit_attr_for_display`
327−-- `limitAttrForDisplay`.
329−-- Note that this optimizes for fewer state changes followed by fewer
248+-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
330−-- bytes.
249+-- haven't measured this or even examined terminal implementations. *shrug*
331−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
250+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
332−terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
251+terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
333− urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
252+ case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
334− -- The only way to reset either color, portably, to the default
253+ -- The only way to reset either color, portably, to the default is to use either the set
335− -- is to use either the set state capability or the set default
254+ -- state capability or the set default capability.
337− True -> do
255+ True -> do
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
256 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
339− (fixedStyle attr)
257+ (fixedStyle attr )
340 (styleToApplySeq $ fixedStyle attr) of
258 (styleToApplySeq $ fixedStyle attr) of
341 -- only way to reset a color to the defaults
259 -- only way to reset a color to the defaults
342− EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
260+ EnterExitSeq caps -> writeDefaultAttr dc
343− `mappend`
261+ `mappend`
344 foldMap (\cap -> writeCapExpr cap []) caps
262 foldMap (\cap -> writeCapExpr cap []) caps
345 `mappend`
263 `mappend`
346 setColors
264 setColors
347 -- implicitly resets the colors to the defaults
265 -- implicitly resets the colors to the defaults
348− SetState state -> writeCapExpr (fromJust $ setAttrStates
266+ SetState state -> writeCapExpr (fromJust $ setAttrStates
349− $ displayAttrCaps terminfoCaps
267+ $ displayAttrCaps
351 (sgrArgsForState state)
270 (sgrArgsForState state)
352− `mappend` setItalics
271+ `mappend`
353− `mappend` setStrikethrough
354− `mappend` setColors
272+ setColors
355− -- Otherwise the display colors are not changing or changing
273+ -- Otherwise the display colors are not changing or changing between two non-default
356− -- between two non-default points.
274+ -- points.
357 False -> do
275 False -> do
358− -- Still, it could be the case that the change in display
276+ -- Still, it could be the case that the change in display attributes requires the
359− -- attributes requires the colors to be reset because the
360− -- required capability was not available.
277+ -- colors to be reset because the required capability was not available.
361 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
278 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
362 (fixedStyle attr)
279 (fixedStyle attr)
363 (styleDiffs diffs) of
280 (styleDiffs diffs) of
364− -- Really, if terminals were re-implemented with modern
281+ -- Really, if terminals were re-implemented with modern concepts instead of bowing
365− -- concepts instead of bowing down to 40 yr old dumb
366− -- terminal requirements this would be the only case
282+ -- down to 40 yr old dumb terminal requirements this would be the only case ever
367− -- ever reached! Changes the style and color states
283+ -- reached! Changes the style and color states according to the differences with
368− -- according to the differences with the currently
369− -- applied states.
284+ -- the currently applied states.
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
285 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
371 `mappend`
286 `mappend`
372− writeColorDiff Foreground (foreColorDiff diffs)
287+ writeColorDiff setForeColor (foreColorDiff diffs)
373 `mappend`
288 `mappend`
374− writeColorDiff Background (backColorDiff diffs)
289+ writeColorDiff setBackColor (backColorDiff diffs)
375 -- implicitly resets the colors to the defaults
290 -- implicitly resets the colors to the defaults
376− SetState state -> writeCapExpr (fromJust $ setAttrStates
291+ SetState state -> writeCapExpr (fromJust $ setAttrStates
377 $ displayAttrCaps terminfoCaps
292 $ displayAttrCaps terminfoCaps
379 (sgrArgsForState state)
294 (sgrArgsForState state)
380− `mappend` setItalics
381− `mappend` setStrikethrough
382 `mappend` setColors
295 `mappend` setColors
384− urlAttrs True = writeURLEscapes (urlDiff diffs)
385− urlAttrs False = mempty
386 colorMap = case useAltColorMap terminfoCaps of
297 colorMap = case useAltColorMap terminfoCaps of
387 False -> ansiColorIndex
298 False -> ansiColorIndex
388 True -> altColorIndex
299 True -> altColorIndex
389 attr = fixDisplayAttr prevAttr reqAttr
300 attr = fixDisplayAttr prevAttr reqAttr
391− -- italics can't be set via SGR, so here we manually
392− -- apply the enter and exit sequences as needed after
395− | hasStyle (fixedStyle attr) italic
396− , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
397− = writeCapExpr sitm []
398− | otherwise = mempty
400− | hasStyle (fixedStyle attr) strikethrough
401− , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
402− = writeCapExpr smxx []
403− | otherwise = mempty
404 setColors =
301 setColors =
405 (case fixedForeColor attr of
302 (case fixedForeColor attr of
406− Just c -> writeColor Foreground c
303+ Just c -> writeCapExpr (setForeColor terminfoCaps)
304+ [toEnum $ colorMap c]
407 Nothing -> mempty)
305 Nothing -> mempty)
408 `mappend`
306 `mappend`
409 (case fixedBackColor attr of
307 (case fixedBackColor attr of
410− Just c -> writeColor Background c
308+ Just c -> writeCapExpr (setBackColor terminfoCaps)
309+ [toEnum $ colorMap c]
411 Nothing -> mempty)
310 Nothing -> mempty)
412− writeColorDiff _side NoColorChange
311+ writeColorDiff _f NoColorChange
414− writeColorDiff _side ColorToDefault
313+ writeColorDiff _f ColorToDefault
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
314 = error "ColorToDefault is not a possible case for applyColorDiffs"
416− writeColorDiff side (SetColor c)
315+ writeColorDiff f (SetColor c)
419− writeColor side (RGBColor r g b) =
420− case outputColorMode (contextDevice dc) of
422− hardcodeColor side (r, g, b)
424− error "clampColor should remove rgb colors in standard mode"
426− writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]
316+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
428−-- a color can either be in the foreground or the background
429−data ColorSide = Foreground | Background
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
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
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"
453−-- | The color table used by a terminal is a 16 color set followed by a
318+-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
454−-- 240 color set that might not be supported by the terminal.
319+-- be supported by the terminal.
456−-- This takes a Color which clearly identifies which palette to use and
321+-- This takes a Color which clearly identifies which pallete to use and computes the index
457−-- computes the index into the full 256 color palette.
322+-- into the full 256 color pallete.
458ansiColorIndex :: Color -> Int
323ansiColorIndex :: Color -> Int
459ansiColorIndex (ISOColor v) = fromEnum v
324ansiColorIndex (ISOColor v) = fromEnum v
460ansiColorIndex (Color240 v) = 16 + fromEnum v
325ansiColorIndex (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"
466-- | For terminals without setaf/setab
327-- | For terminals without setaf/setab
468-- See table in `man terminfo`
329-- See table in `man terminfo`
469-- Will error if not in table.
330-- Will error if not in table.
470altColorIndex :: Color -> Int
331altColorIndex :: Color -> Int
@@ -478,28 +339,21 @@ altColorIndex (ISOColor 6) = 3
478altColorIndex (ISOColor 7) = 7
339altColorIndex (ISOColor 7) = 7
479altColorIndex (ISOColor v) = fromEnum v
340altColorIndex (ISOColor v) = fromEnum v
480altColorIndex (Color240 v) = 16 + fromEnum v
341altColorIndex (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"
486−{- | The sequence of terminfo caps to apply a given style are determined
343+{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
487− - according to these rules.
344+ -
345+ - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
346+ - the full set display attribute state capability.
489− - 1. The assumption is that it's preferable to use the simpler
348+ - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
490− - enter/exit mode capabilities than the full set display attribute
349+ - display attributes are reset to defaults then the display attribute state is set.
493− - 2. If a mode is supposed to be removed but there is not an exit
351+ - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
494− - capability defined then the display attributes are reset to defaults
495− - then the display attribute state is set.
352+ - display attribute state is set if possible. Otherwise the mode is not applied.
497− - 3. If a mode is supposed to be applied but there is not an enter
498− - capability defined then then display attribute state is set if
354+ - 4. If the display attribute state is being set then just update the arguments to that for any
499− - possible. Otherwise the mode is not applied.
355+ - apply/remove.
501− - 4. If the display attribute state is being set then just update the
502− - arguments to that for any apply/remove.
504data DisplayAttrSeq
358data DisplayAttrSeq
505 = EnterExitSeq [CapExpression]
359 = EnterExitSeq [CapExpression]
@@ -508,8 +362,6 @@ data DisplayAttrSeq
508data DisplayAttrState = DisplayAttrState
362data DisplayAttrState = DisplayAttrState
509 { applyStandout :: Bool
363 { applyStandout :: Bool
510 , applyUnderline :: Bool
364 , applyUnderline :: Bool
511− , applyItalic :: Bool
512− , applyStrikethrough :: Bool
513 , applyReverseVideo :: Bool
365 , applyReverseVideo :: Bool
514 , applyBlink :: Bool
366 , applyBlink :: Bool
515 , applyDim :: Bool
367 , applyDim :: Bool
@@ -531,25 +383,19 @@ sgrArgsForState attrState = map (\b -> if b then 1 else 0)
532reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
384reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
533reqDisplayCapSeqFor caps s diffs
385reqDisplayCapSeqFor caps s diffs
534− -- if the state transition implied by any diff cannot be supported
386+ -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
535− -- with an enter/exit mode cap then either the state needs to be set
536− -- or the attribute change ignored.
387+ -- then either the state needs to be set or the attribute change ignored.
537 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
388 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
538 -- If all the diffs have an enter-exit cap then just use those
389 -- If all the diffs have an enter-exit cap then just use those
539 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
390 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
540− -- If not all the diffs have an enter-exit cap and there is no
391+ -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
541− -- set state cap then filter out all unsupported diffs and just
392+ -- all unsupported diffs and just apply the rest
543− ( True, False ) -> EnterExitSeq $ map enterExitCap
393+ ( True, False ) -> EnterExitSeq $ map enterExitCap
544 $ filter (not . noEnterExitCap) diffs
394 $ filter (not . noEnterExitCap) diffs
545− -- if not all the diffs have an enter-exit can and there is a
395+ -- if not all the diffs have an enter-exit can and there is a set state cap then just use
546− -- set state cap then just use the set state cap.
396+ -- the set state cap.
547 ( True, True ) -> SetState $ stateForStyle s
397 ( True, True ) -> SetState $ stateForStyle s
549− noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps
550− noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps
551− noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
552− noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
399 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
400 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
401 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -562,10 +408,6 @@ reqDisplayCapSeqFor caps s diffs
562 noEnterExitCap RemoveDim = True
408 noEnterExitCap RemoveDim = True
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
409 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
564 noEnterExitCap RemoveBold = True
410 noEnterExitCap RemoveBold = True
565− enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
566− enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
567− enterExitCap ApplyItalic = fromJust $ enterItalic caps
568− enterExitCap RemoveItalic = fromJust $ exitItalic caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
411 enterExitCap ApplyStandout = fromJust $ enterStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
412 enterExitCap RemoveStandout = fromJust $ exitStandout caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
413 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -579,8 +421,6 @@ stateForStyle :: Style -> DisplayAttrState
579stateForStyle s = DisplayAttrState
421stateForStyle s = DisplayAttrState
580 { applyStandout = isStyleSet standout
422 { applyStandout = isStyleSet standout
581 , applyUnderline = isStyleSet underline
423 , applyUnderline = isStyleSet underline
582− , applyItalic = isStyleSet italic
583− , applyStrikethrough = isStyleSet strikethrough
584 , applyReverseVideo = isStyleSet reverseVideo
424 , applyReverseVideo = isStyleSet reverseVideo
585 , applyBlink = isStyleSet blink
425 , applyBlink = isStyleSet blink
586 , applyDim = isStyleSet dim
426 , applyDim = isStyleSet dim
@@ -592,15 +432,14 @@ styleToApplySeq :: Style -> [StyleStateChange]
592styleToApplySeq s = concat
432styleToApplySeq s = concat
593 [ applyIfRequired ApplyStandout standout
433 [ applyIfRequired ApplyStandout standout
594 , applyIfRequired ApplyUnderline underline
434 , applyIfRequired ApplyUnderline underline
595− , applyIfRequired ApplyItalic italic
596− , applyIfRequired ApplyStrikethrough strikethrough
597 , applyIfRequired ApplyReverseVideo reverseVideo
435 , applyIfRequired ApplyReverseVideo reverseVideo
598 , applyIfRequired ApplyBlink blink
436 , applyIfRequired ApplyBlink blink
599 , applyIfRequired ApplyDim dim
437 , applyIfRequired ApplyDim dim
600− , applyIfRequired ApplyBold bold
438+ , applyIfRequired ApplyBlink bold
603− applyIfRequired op flag
441+ applyIfRequired op flag
604 = if 0 == (flag .&. s)
442 = if 0 == (flag .&. s)
606 else [op]
444 else [op]