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