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