@@ -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
@@ -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
78−-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
81+-- 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
82+-- 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
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
97−-- codes. While this should provide the most compatible terminal,
98+{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
98−-- terminfo does not support some features that would increase
99+ - terminfo does not support some features that would increase efficiency and improve compatibility:
99−-- efficiency and improve compatibility:
100+ -
101−-- * determining the character encoding supported by the terminal.
101+ - * 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?
102+ - environment variable?
104−-- * Providing independent string capabilities for all display
104+ - * Provide independent string capabilities for all display attributes.
106+ - todo: Some display attributes like underline and bold have independent string capabilities that
107+ - should be used instead of the generic "sgr" string capability.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
109+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
107−reserveTerminal termName outFd colorMode = do
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)) &&
168− (isJust $ exitItalic (displayAttrCaps terminfoCaps))
169− , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
170− (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
152+ , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
172− , reserveDisplay = do
153+ , reserveDisplay = liftIO $ do
173− -- If there is no support for smcup: Clear the screen
154+ -- 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.
155+ -- home position to 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
201− -- I think fix would help assure tActual is the only
184+ -- I think fix would help assure tActual is the only reference. I was having issues
202− -- reference. I was having issues tho.
185+ -- tho.
203− , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
186+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual 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 )
211+ => Terminfo.Terminal
212+ -> m DisplayAttrCaps
228−currentDisplayAttrCaps ti
213+currentDisplayAttrCaps ti
229− = pure DisplayAttrCaps
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 ->
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
244+ , 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) []
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
299−-- colors to the default) this procedure is used:
252+-- 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.
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
319−-- Entering the required style modes could require a reset of the
272+-- 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.
273+-- the case then the back and fore colors 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
327−-- `limitAttrForDisplay`.
278+-- with noColors == True. See `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.
337− True -> do
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
354− `mappend` setColors
304+ setColors
355− -- Otherwise the display colors are not changing or changing
305+ -- Otherwise the display colors are not changing or changing between two non-default
356− -- between two non-default points.
306+ -- 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
360− -- required capability was not available.
309+ -- colors to be reset because the 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
366− -- terminal requirements this would be the only case
314+ -- down to 40 yr old dumb terminal requirements this would be the only case ever
367− -- ever reached! Changes the style and color states
315+ -- reached! Changes the style and color states according to the differences with
368− -- according to the differences with the currently
369− -- applied states.
316+ -- the currently applied states.
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)
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]
348+ = 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
350+-- | 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.
351+-- 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
495− - then the display attribute state is set.
384+ - 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
386+ - 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.
387+ - 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
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
536− -- or the attribute change ignored.
419+ -- then either the state needs to be set 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
543− ( True, False ) -> EnterExitSeq $ map enterExitCap
425+ ( 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]