@@ -1,54 +1,71 @@
1−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
4−{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
5{-# CFILES gwinsz.c #-}
5{-# CFILES gwinsz.c #-}
6−
6+-- | Terminfo based terminal handling.
7−-- | Terminfo-based terminal output driver.
7+--
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 )
11− ( reserveTerminal
14+ where
13− )
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
43−import System.Posix.IO (fdWriteBuf)
55+#ifdef __GLASGOW_HASKELL__
56+#if __GLASGOW_HASKELL__ >= 611
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
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
100−--
97+ - environment variable?
101−-- * determining the character encoding supported by the terminal.
98+ -
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
101+ - todo: Some display attributes like underline and bold have independent string capabilities that
105−-- attributes.
102+ - should be used instead of the generic "sgr" string capability.
106−reserveTerminal :: String -> Fd -> ColorMode -> IO Output
103+ -}
107−reserveTerminal termName outFd colorMode = do
104+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
108− ti <- Terminfo.setupTerm termName
105+reserveTerminal inID outHandle = liftIO $ do
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)) &&
146+ , reserveDisplay = liftIO $ do
168− (isJust $ exitItalic (displayAttrCaps terminfoCaps))
147+ -- If there is no support for smcup: Clear the screen and then move the mouse to the
169− , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
148+ -- home position to approximate the behavior.
170− (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
171− , ringTerminalBell = maybeSendCap ringBellAudio []
172− , reserveDisplay = do
173− -- If there is no support for smcup: Clear the screen
174− -- and then move the mouse to the home position to
175− -- 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
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)
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 )
228−currentDisplayAttrCaps ti
198+ => Terminfo.Terminal
229− = pure DisplayAttrCaps
199+ -> m DisplayAttrCaps
200+currentDisplayAttrCaps ti
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 ->
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 []
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
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:
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
259+-- Entering the required style modes could require a reset of the display attributes. If this is
318−--
260+-- the case then the back and fore colors always need to be set if not default.
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
321−-- 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.
336− -- capability.
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
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.
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
296+ -- colors to be reset because the required capability was not available.
360− -- 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
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
303+ -- the currently applied states.
368− -- according to the differences with the currently
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)
417− = writeColor side c
335+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap 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]
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
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.
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
406+ -- then either the state needs to be set or the attribute change ignored.
536− -- 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
542− -- apply the rest
412+ ( True, False ) -> EnterExitSeq $ map enterExitCap
543− ( 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_)))