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