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