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