@@ -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 #-}
6−
6+-- | Terminfo based terminal handling.
7−-- | Terminfo-based terminal output driver.
7+--
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 )
11− ( reserveTerminal
14+ where
13− )
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
77−-- kinda like:
72+-- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422
78−-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
73+-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried.
79−-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
80−-- the write will be retried.
81fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
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
89+{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
97−-- codes. While this should provide the most compatible terminal,
90+ - terminfo does not support some features that would increase efficiency and improve compatibility:
98−-- terminfo does not support some features that would increase
91+ -
99−-- efficiency and improve compatibility:
92+ - * determine the character encoding supported by the terminal. Should this be taken from the LANG
100−--
93+ - environment variable?
101−-- * determining the character encoding supported by the terminal.
94+ -
102−-- Should this be taken from the LANG environment variable?
95+ - * Provide independent string capabilities for all display attributes.
104−-- * Providing independent string capabilities for all display
97+ - todo: Some display attributes like underline and bold have independent string capabilities that
105−-- attributes.
98+ - should be used instead of the generic "sgr" string capability.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
99+ -}
107−reserveTerminal termName outFd colorMode = do
100+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
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
141+ , reserveDisplay = liftIO $ do
167− , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&
142+ -- If there is no support for smcup: Clear the screen and then move the mouse to the
168− (isJust $ exitItalic (displayAttrCaps terminfoCaps))
143+ -- home position to approximate the behavior.
169− , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
170− (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
172− , reserveDisplay = do
173− -- If there is no support for smcup: Clear the screen
174− -- and then move the mouse to the home position to
175− -- approximate the behavior.
176 maybeSendCap smcup []
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
169+ -- I think fix would help assure tActual is the only reference. I was having issues
201− -- I think fix would help assure tActual is the only
170+ -- tho.
202− -- reference. I was having issues tho.
171+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
203− , mkDisplayContext = (`terminfoDisplayContext` 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 )
228−currentDisplayAttrCaps ti
196+ => Terminfo.Terminal
229− = pure DisplayAttrCaps
197+ -> m DisplayAttrCaps
198+currentDisplayAttrCaps ti
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 ->
229+ , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
271− writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
272− (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
273− (case exitStrikethrough $ displayAttrCaps terminfoCaps of
274− Just cap -> writeCapExpr cap []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
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
237+-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
299−-- colors to the default) this procedure is used:
301-- 0. set the style attributes. This resets the fore and back color.
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
249+-- 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)
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
258+-- the case then the back and fore colors always need to be set if not default.
321−-- 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
263+-- with noColors == True. See `limitAttrForDisplay`
327−-- `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.
336− -- capability.
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
289+ setColors
354− `mappend` setColors
290+ -- Otherwise the display colors are not changing or changing between two non-default
355− -- Otherwise the display colors are not changing or changing
291+ -- points.
356− -- between two non-default 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
294+ -- colors to be reset because the required capability was not available.
360− -- 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
299+ -- down to 40 yr old dumb terminal requirements this would be the only case ever
366− -- terminal requirements this would be the only case
300+ -- reached! Changes the style and color states according to the differences with
367− -- ever reached! Changes the style and color states
301+ -- the currently applied states.
368− -- according to the differences with the currently
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)
417− = writeColor side c
333+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap 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]
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
369+ - display attribute state is set if possible. Otherwise the mode is not applied.
495− - then the display attribute state is set.
497− - 3. If a mode is supposed to be applied but there is not an enter
371+ - 4. If the display attribute state is being set then just update the arguments to that for any
498− - capability defined then then display attribute state is set if
372+ - apply/remove.
499− - possible. Otherwise the mode is not applied.
501− - 4. If the display attribute state is being set then just update the
502− - arguments to that for any apply/remove.
504data DisplayAttrSeq
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
404+ -- then either the state needs to be set or the attribute change ignored.
536− -- or the attribute change ignored.
537 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
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
542− -- apply the rest
410+ ( True, False ) -> EnterExitSeq $ map enterExitCap
543− ( 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]