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