@@ -1,39 +1,40 @@
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)
35import Data.Word
32import Data.Word
34+#if !MIN_VERSION_base(4,8,0)
35+import Data.Foldable (foldMap)
37import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.C.Types ( CInt(..), CLong(..) )
38import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.ForeignPtr (withForeignPtr)
39import Foreign.Ptr (Ptr, plusPtr)
40import Foreign.Ptr (Ptr, plusPtr)
@@ -42,13 +43,12 @@ import qualified System.Console.Terminfo as Terminfo
42import System.Posix.IO (fdWriteBuf)
43import System.Posix.IO (fdWriteBuf)
43import System.Posix.Types (Fd(..))
44import System.Posix.Types (Fd(..))
45−data TerminfoCaps = TerminfoCaps
46+data TerminfoCaps = TerminfoCaps
46 { smcup :: Maybe CapExpression
47 { smcup :: Maybe CapExpression
47 , rmcup :: Maybe CapExpression
48 , rmcup :: Maybe CapExpression
48 , cup :: CapExpression
49 , cup :: CapExpression
49 , cnorm :: Maybe CapExpression
50 , cnorm :: Maybe CapExpression
50 , civis :: Maybe CapExpression
51 , 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,21 +56,28 @@ 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
61data DisplayAttrCaps = DisplayAttrCaps
62data DisplayAttrCaps = DisplayAttrCaps
62 { setAttrStates :: Maybe CapExpression
63 { setAttrStates :: Maybe CapExpression
63 , enterStandout :: Maybe CapExpression
64 , enterStandout :: Maybe CapExpression
64 , exitStandout :: Maybe CapExpression
65 , exitStandout :: Maybe CapExpression
66+ , enterItalic :: Maybe CapExpression
67+ , exitItalic :: Maybe CapExpression
68+ , enterStrikethrough :: Maybe CapExpression
69+ , exitStrikethrough :: Maybe CapExpression
65 , enterUnderline :: Maybe CapExpression
70 , enterUnderline :: Maybe CapExpression
66 , exitUnderline :: Maybe CapExpression
71 , exitUnderline :: Maybe CapExpression
67 , enterReverseVideo :: Maybe CapExpression
72 , enterReverseVideo :: Maybe CapExpression
68 , enterDimMode :: Maybe CapExpression
73 , enterDimMode :: Maybe CapExpression
69 , enterBoldMode :: Maybe CapExpression
74 , enterBoldMode :: Maybe CapExpression
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.
74fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
81fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
75fdWriteAll outFd ptr len count
82fdWriteAll outFd ptr len count
76 | len < 0 = fail "fdWriteAll: len is less than 0"
83 | len < 0 = fail "fdWriteAll: len is less than 0"
@@ -86,68 +93,95 @@ sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
86sendCapToTerminal t cap capParams = do
93sendCapToTerminal t cap capParams = do
87 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
94 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
101+-- * determining the character encoding supported by the terminal.
93− - environment variable?
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
98− - should be used instead of the generic "sgr" string capability.
100−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
106+reserveTerminal :: String -> Fd -> ColorMode -> IO Output
101−reserveTerminal termName outFd = liftIO $ do
107+reserveTerminal termName outFd colorMode = do
102 ti <- Terminfo.setupTerm termName
108 ti <- Terminfo.setupTerm termName
103 -- assumes set foreground always implies set background exists.
109 -- assumes set foreground always implies set background exists.
104− -- 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.
105 msetaf <- probeCap ti "setaf"
112 msetaf <- probeCap ti "setaf"
106 msetf <- probeCap ti "setf"
113 msetf <- probeCap ti "setf"
107− let (noColors, useAlt, setForeCap)
114+ let (useAlt, setForeCap)
108 = case msetaf of
115 = case msetaf of
109− Just setaf -> (False, False, setaf)
116+ Just setaf -> (False, setaf)
110 Nothing -> case msetf of
117 Nothing -> case msetf of
111− Just setf -> (False, True, setf)
118+ Just setf -> (True, setf)
112− Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
119+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
113 msetab <- probeCap ti "setab"
120 msetab <- probeCap ti "setab"
114 msetb <- probeCap ti "setb"
121 msetb <- probeCap ti "setb"
115− let set_back_cap
122+ let setBackCap
116 = case msetab of
123 = case msetab of
117 Nothing -> case msetb of
125 Nothing -> case msetb of
118 Just setb -> setb
126 Just setb -> setb
119 Nothing -> error $ "no back color support for terminal " ++ termName
127 Nothing -> error $ "no back color support for terminal " ++ termName
120− 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
121 terminfoCaps <- pure TerminfoCaps
147 terminfoCaps <- pure TerminfoCaps
122 <*> probeCap ti "smcup"
148 <*> probeCap ti "smcup"
123 <*> probeCap ti "rmcup"
149 <*> probeCap ti "rmcup"
124 <*> requireCap ti "cup"
150 <*> requireCap ti "cup"
125 <*> probeCap ti "cnorm"
151 <*> probeCap ti "cnorm"
126 <*> probeCap ti "civis"
152 <*> probeCap ti "civis"
128 <*> pure useAlt
153 <*> pure useAlt
129 <*> pure setForeCap
154 <*> pure setForeCap
130− <*> pure set_back_cap
155+ <*> pure setBackCap
131 <*> requireCap ti "sgr0"
156 <*> requireCap ti "sgr0"
132 <*> requireCap ti "clear"
157 <*> requireCap ti "clear"
133 <*> requireCap ti "el"
158 <*> requireCap ti "el"
134 <*> currentDisplayAttrCaps ti
159 <*> currentDisplayAttrCaps ti
135− newAssumedStateRef <- newIORef initialAssumedState
160+ <*> probeCap ti "bel"
136 let t = Output
161 let t = Output
137 { terminalID = termName
162 { terminalID = termName
138− , releaseTerminal = liftIO $ do
163+ , releaseTerminal = do
139 sendCap setDefaultAttr []
164 sendCap setDefaultAttr []
140 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 []
141− , reserveDisplay = liftIO $ do
172+ , reserveDisplay = do
142− -- 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
143− -- home position to approximate the behavior.
175+ -- approximate the behavior.
144 maybeSendCap smcup []
176 maybeSendCap smcup []
145 sendCap clearScreen []
177 sendCap clearScreen []
146− , releaseDisplay = liftIO $ do
178+ , releaseDisplay = do
147 maybeSendCap rmcup []
179 maybeSendCap rmcup []
148 maybeSendCap cnorm []
180 maybeSendCap cnorm []
181+ , setDisplayBounds = \(w, h) ->
182+ setWindowSize outFd (w, h)
149 , displayBounds = do
183 , displayBounds = do
150− rawSize <- liftIO $ getWindowSize outFd
184+ rawSize <- getWindowSize outFd
151 case rawSize of
185 case rawSize of
152 (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
153 | otherwise -> return (w,h)
187 | otherwise -> return (w,h)
@@ -158,48 +192,48 @@ reserveTerminal termName outFd = liftIO $ do
158 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
192 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
159 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
193 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
160 ++ " Please report this bug to vty project."
194 ++ " Please report this bug to vty project."
162− = case supportsNoColors terminfoCaps of
163− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
167 , supportsCursorVisibility = isJust $ civis terminfoCaps
195 , supportsCursorVisibility = isJust $ civis terminfoCaps
196+ , supportsMode = terminfoModeSupported
197+ , setMode = terminfoSetMode
198+ , getModeStatus = terminfoModeStatus
168 , assumedStateRef = newAssumedStateRef
199 , 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)
173 sendCap s = sendCapToTerminal t (s terminfoCaps)
205 sendCap s = sendCapToTerminal t (s terminfoCaps)
174 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
206 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
177−requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
209+requireCap :: Terminfo.Terminal -> String -> IO CapExpression
178−requireCap ti capName
210+requireCap ti capName
179 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
211 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
180 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
212 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
181 Just capStr -> parseCap capStr
213 Just capStr -> parseCap capStr
183−probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
215+probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
184−probeCap ti capName
216+probeCap ti capName
185 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
217 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
186 Nothing -> return Nothing
218 Nothing -> return Nothing
187 Just capStr -> Just <$> parseCap capStr
219 Just capStr -> Just <$> parseCap capStr
189−parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
221+parseCap :: String -> IO CapExpression
190parseCap capStr = do
222parseCap capStr = do
191 case parseCapExpression capStr of
223 case parseCapExpression capStr of
192 Left e -> fail $ show e
224 Left e -> fail $ show e
193 Right cap -> return cap
225 Right cap -> return cap
195−currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
227+currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
196− => Terminfo.Terminal
197− -> m DisplayAttrCaps
198−currentDisplayAttrCaps ti
228+currentDisplayAttrCaps ti
199− = pure DisplayAttrCaps
229+ = pure DisplayAttrCaps
200 <*> probeCap ti "sgr"
230 <*> probeCap ti "sgr"
201 <*> probeCap ti "smso"
231 <*> probeCap ti "smso"
202 <*> probeCap ti "rmso"
232 <*> probeCap ti "rmso"
233+ <*> probeCap ti "sitm"
234+ <*> probeCap ti "ritm"
235+ <*> probeCap ti "smxx"
236+ <*> probeCap ti "rmxx"
203 <*> probeCap ti "smul"
237 <*> probeCap ti "smul"
204 <*> probeCap ti "rmul"
238 <*> probeCap ti "rmul"
205 <*> probeCap ti "rev"
239 <*> probeCap ti "rev"
@@ -209,10 +243,17 @@ currentDisplayAttrCaps ti
209foreign 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
211getWindowSize :: Fd -> IO (Int,Int)
245getWindowSize :: Fd -> IO (Int,Int)
212−getWindowSize fd = do
246+getWindowSize fd = do
213 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
247 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
214 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
216terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
257terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
217terminfoDisplayContext tActual terminfoCaps r = return dc
258terminfoDisplayContext tActual terminfoCaps r = return dc
218 where dc = DisplayContext
259 where dc = DisplayContext
@@ -226,123 +267,204 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
226 Nothing -> error "this terminal does not support hide cursor"
267 Nothing -> error "this terminal does not support hide cursor"
227 Just c -> writeCapExpr c []
268 Just c -> writeCapExpr c []
228 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
269 , 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 []
230 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
277 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
231 , 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 =
234-- | 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.
236−-- 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
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:
239-- 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.
241-- 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
243-- 2. likewise with the background color
305-- 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
249−-- 0. reset all display attributes (sgr0)
311+-- 0. reset all display attributes (sgr0)
251−-- 1. enter required style modes
313+-- 1. enter required style modes
253−-- 2. set the fore color if required
315+-- 2. set the fore color if required
255−-- 3. set the back color if required
317+-- 3. set the back color if required
257−-- 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
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.
260-- This equation implements the above logic.
323-- This equation implements the above logic.
262−-- \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
326+-- display attributes is done as expected with noColors == True. See
263−-- with noColors == True. See `limitAttrForDisplay`
327+-- `limitAttrForDisplay`.
265−-- \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
266−-- haven't measured this or even examined terminal implementations. *shrug*
330+-- bytes.
267−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
331+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
268−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
332+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
269− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
333+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
270− -- 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
271− -- state capability or the set default capability.
335+ -- is to use either the set state capability or the set default
272− True -> do
337+ True -> do
273 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
338 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
274− (fixedStyle attr )
339+ (fixedStyle attr)
275 (styleToApplySeq $ fixedStyle attr) of
340 (styleToApplySeq $ fixedStyle attr) of
276 -- only way to reset a color to the defaults
341 -- only way to reset a color to the defaults
277− EnterExitSeq caps -> writeDefaultAttr dc
342+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
278− `mappend`
343+ `mappend`
279 foldMap (\cap -> writeCapExpr cap []) caps
344 foldMap (\cap -> writeCapExpr cap []) caps
280 `mappend`
345 `mappend`
281 setColors
346 setColors
282 -- implicitly resets the colors to the defaults
347 -- implicitly resets the colors to the defaults
283− SetState state -> writeCapExpr (fromJust $ setAttrStates
348+ SetState state -> writeCapExpr (fromJust $ setAttrStates
284− $ displayAttrCaps
349+ $ displayAttrCaps terminfoCaps
287 (sgrArgsForState state)
351 (sgrArgsForState state)
288− `mappend`
352+ `mappend` setItalics
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.
292 False -> do
357 False -> do
293− -- 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
294− -- colors to be reset because the required capability was not available.
360+ -- required capability was not available.
295 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
361 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
296 (fixedStyle attr)
362 (fixedStyle attr)
297 (styleDiffs diffs) of
363 (styleDiffs diffs) of
298− -- 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
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
368+ -- according to the differences with the currently
301− -- the currently applied states.
369+ -- applied states.
302 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
370 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
303 `mappend`
371 `mappend`
304− writeColorDiff setForeColor (foreColorDiff diffs)
372+ writeColorDiff Foreground (foreColorDiff diffs)
305 `mappend`
373 `mappend`
306− writeColorDiff setBackColor (backColorDiff diffs)
374+ writeColorDiff Background (backColorDiff diffs)
307 -- implicitly resets the colors to the defaults
375 -- implicitly resets the colors to the defaults
308− SetState state -> writeCapExpr (fromJust $ setAttrStates
376+ SetState state -> writeCapExpr (fromJust $ setAttrStates
309 $ displayAttrCaps terminfoCaps
377 $ displayAttrCaps terminfoCaps
311 (sgrArgsForState state)
379 (sgrArgsForState state)
380+ `mappend` setItalics
381+ `mappend` setStrikethrough
312 `mappend` setColors
382 `mappend` setColors
384+ urlAttrs True = writeURLEscapes (urlDiff diffs)
385+ urlAttrs False = mempty
314 colorMap = case useAltColorMap terminfoCaps of
386 colorMap = case useAltColorMap terminfoCaps of
315 False -> ansiColorIndex
387 False -> ansiColorIndex
316 True -> altColorIndex
388 True -> altColorIndex
317 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
318 setColors =
404 setColors =
319 (case fixedForeColor attr of
405 (case fixedForeColor attr of
320− Just c -> writeCapExpr (setForeColor terminfoCaps)
406+ Just c -> writeColor Foreground c
321− [toEnum $ colorMap c]
322 Nothing -> mempty)
407 Nothing -> mempty)
323 `mappend`
408 `mappend`
324 (case fixedBackColor attr of
409 (case fixedBackColor attr of
325− Just c -> writeCapExpr (setBackColor terminfoCaps)
410+ Just c -> writeColor Background c
326− [toEnum $ colorMap c]
327 Nothing -> mempty)
411 Nothing -> mempty)
328− writeColorDiff _f NoColorChange
412+ writeColorDiff _side NoColorChange
330− writeColorDiff _f ColorToDefault
414+ writeColorDiff _side ColorToDefault
331 = error "ColorToDefault is not a possible case for applyColorDiffs"
415 = error "ColorToDefault is not a possible case for applyColorDiffs"
332− 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"
333− = 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"
335−-- | 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
336−-- be supported by the terminal.
454+-- 240 color set that might not be supported by the terminal.
338−-- 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
339−-- into the full 256 color pallete.
457+-- computes the index into the full 256 color palette.
340ansiColorIndex :: Color -> Int
458ansiColorIndex :: Color -> Int
341ansiColorIndex (ISOColor v) = fromEnum v
459ansiColorIndex (ISOColor v) = fromEnum v
342ansiColorIndex (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"
344-- | For terminals without setaf/setab
466-- | For terminals without setaf/setab
346-- See table in `man terminfo`
468-- See table in `man terminfo`
347-- Will error if not in table.
469-- Will error if not in table.
348altColorIndex :: Color -> Int
470altColorIndex :: Color -> Int
@@ -356,21 +478,28 @@ altColorIndex (ISOColor 6) = 3
356altColorIndex (ISOColor 7) = 7
478altColorIndex (ISOColor 7) = 7
357altColorIndex (ISOColor v) = fromEnum v
479altColorIndex (ISOColor v) = fromEnum v
358altColorIndex (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"
360−{- | 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
361− -
487+ - according to these rules.
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.
365− - 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
366− - display attributes are reset to defaults then the display attribute state is set.
490+ - enter/exit mode capabilities than the full set display attribute
368− - 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
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.
375data DisplayAttrSeq
504data DisplayAttrSeq
376 = EnterExitSeq [CapExpression]
505 = EnterExitSeq [CapExpression]
@@ -379,6 +508,8 @@ data DisplayAttrSeq
379data DisplayAttrState = DisplayAttrState
508data DisplayAttrState = DisplayAttrState
380 { applyStandout :: Bool
509 { applyStandout :: Bool
381 , applyUnderline :: Bool
510 , applyUnderline :: Bool
511+ , applyItalic :: Bool
512+ , applyStrikethrough :: Bool
382 , applyReverseVideo :: Bool
513 , applyReverseVideo :: Bool
383 , applyBlink :: Bool
514 , applyBlink :: Bool
384 , applyDim :: Bool
515 , applyDim :: Bool
@@ -400,19 +531,25 @@ sgrArgsForState attrState = map (\b -> if b then 1 else 0)
401reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
532reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
402reqDisplayCapSeqFor caps s diffs
533reqDisplayCapSeqFor caps s diffs
403− -- 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
404− -- then either the state needs to be set or the attribute change ignored.
536+ -- or the attribute change ignored.
405 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
537 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
406 -- 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
407 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
539 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
408− -- 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
409− -- all unsupported diffs and just apply the rest
541+ -- set state cap then filter out all unsupported diffs and just
410− ( True, False ) -> EnterExitSeq $ map enterExitCap
543+ ( True, False ) -> EnterExitSeq $ map enterExitCap
411 $ filter (not . noEnterExitCap) diffs
544 $ filter (not . noEnterExitCap) diffs
412− -- 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
413− -- the set state cap.
546+ -- set state cap then just use the set state cap.
414 ( 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
416 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
553 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
417 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
554 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
418 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
555 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
@@ -425,6 +562,10 @@ reqDisplayCapSeqFor caps s diffs
425 noEnterExitCap RemoveDim = True
562 noEnterExitCap RemoveDim = True
426 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
563 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
427 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
428 enterExitCap ApplyStandout = fromJust $ enterStandout caps
569 enterExitCap ApplyStandout = fromJust $ enterStandout caps
429 enterExitCap RemoveStandout = fromJust $ exitStandout caps
570 enterExitCap RemoveStandout = fromJust $ exitStandout caps
430 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
571 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
@@ -438,6 +579,8 @@ stateForStyle :: Style -> DisplayAttrState
438stateForStyle s = DisplayAttrState
579stateForStyle s = DisplayAttrState
439 { applyStandout = isStyleSet standout
580 { applyStandout = isStyleSet standout
440 , applyUnderline = isStyleSet underline
581 , applyUnderline = isStyleSet underline
582+ , applyItalic = isStyleSet italic
583+ , applyStrikethrough = isStyleSet strikethrough
441 , applyReverseVideo = isStyleSet reverseVideo
584 , applyReverseVideo = isStyleSet reverseVideo
442 , applyBlink = isStyleSet blink
585 , applyBlink = isStyleSet blink
443 , applyDim = isStyleSet dim
586 , applyDim = isStyleSet dim
@@ -449,14 +592,15 @@ styleToApplySeq :: Style -> [StyleStateChange]
449styleToApplySeq s = concat
592styleToApplySeq s = concat
450 [ applyIfRequired ApplyStandout standout
593 [ applyIfRequired ApplyStandout standout
451 , applyIfRequired ApplyUnderline underline
594 , applyIfRequired ApplyUnderline underline
595+ , applyIfRequired ApplyItalic italic
596+ , applyIfRequired ApplyStrikethrough strikethrough
452 , applyIfRequired ApplyReverseVideo reverseVideo
597 , applyIfRequired ApplyReverseVideo reverseVideo
453 , applyIfRequired ApplyBlink blink
598 , applyIfRequired ApplyBlink blink
454 , applyIfRequired ApplyDim dim
599 , applyIfRequired ApplyDim dim
455− , applyIfRequired ApplyBlink bold
600+ , applyIfRequired ApplyBold bold
458− applyIfRequired op flag
603+ applyIfRequired op flag
459 = if 0 == (flag .&. s)
604 = if 0 == (flag .&. s)
461 else [op]
606 else [op]