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