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