git.iko.soy/vty
on 021a059 help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
483 lines 21 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
5{-# CFILES gwinsz.c #-}
6-- | Terminfo based terminal handling.
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.
11--
12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
13module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )
14 where
16import Graphics.Vty.Prelude
18import qualified Data.ByteString as BS
19import Data.Terminfo.Parse
20import Data.Terminfo.Eval
22import Graphics.Vty.Attributes
23import Graphics.Vty.DisplayAttributes
24import Graphics.Vty.Output.Interface
26import Blaze.ByteString.Builder (Write, writeToByteString)
28import Control.Monad.Trans
30import Data.Bits ((.&.))
31import Data.Foldable (foldMap)
32import Data.IORef
33import Data.Maybe (isJust, isNothing, fromJust)
34import Data.Monoid
36import Foreign.C.Types ( CInt(..), CLong(..) )
38import GHC.IO.Handle
39#ifdef __GLASGOW_HASKELL__
40#if __GLASGOW_HASKELL__ >= 611
41import GHC.IO.Handle.Internals (withHandle_)
42import GHC.IO.Handle.Types (Handle__(..))
43import qualified GHC.IO.FD as FD
44-- import qualified GHC.IO.Handle.FD as FD
45import GHC.IO.Exception
46import Data.Typeable (cast)
47#else
48import GHC.IOBase
49import GHC.Handle hiding (fdToHandle)
50import qualified GHC.Handle
51#endif
52#endif
54import qualified System.Console.Terminfo as Terminfo
55#ifdef __GLASGOW_HASKELL__
56#if __GLASGOW_HASKELL__ >= 611
57import System.IO.Error
58#endif
59#endif
60import System.Posix.Types (Fd(..))
62data TerminfoCaps = TerminfoCaps
63 { smcup :: Maybe CapExpression
64 , rmcup :: Maybe CapExpression
65 , cup :: CapExpression
66 , cnorm :: Maybe CapExpression
67 , civis :: Maybe CapExpression
68 , supportsNoColors :: Bool
69 , useAltColorMap :: Bool
70 , setForeColor :: CapExpression
71 , setBackColor :: CapExpression
72 , setDefaultAttr :: CapExpression
73 , clearScreen :: CapExpression
74 , clearEol :: CapExpression
75 , displayAttrCaps :: DisplayAttrCaps
76 }
78data DisplayAttrCaps = DisplayAttrCaps
79 { setAttrStates :: Maybe CapExpression
80 , enterStandout :: Maybe CapExpression
81 , exitStandout :: Maybe CapExpression
82 , enterUnderline :: Maybe CapExpression
83 , exitUnderline :: Maybe CapExpression
84 , enterReverseVideo :: Maybe CapExpression
85 , enterDimMode :: Maybe CapExpression
86 , enterBoldMode :: Maybe CapExpression
87 }
89sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
90sendCapToTerminal t cap capParams = do
91 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
93{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
94 - terminfo does not support some features that would increase efficiency and improve compatibility:
95 -
96 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
97 - environment variable?
98 -
99 - * Provide independent string capabilities for all display attributes.
100 -
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.
103 -}
104reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
105reserveTerminal inID outHandle = liftIO $ do
106 ti <- Terminfo.setupTerm inID
107 -- assumes set foreground always implies set background exists.
108 -- if set foreground is not set then all color changing style attributes are filtered.
109 msetaf <- probeCap ti "setaf"
110 msetf <- probeCap ti "setf"
111 let (noColors, useAlt, setForeCap)
112 = case msetaf of
113 Just setaf -> (False, False, setaf)
114 Nothing -> case msetf of
115 Just setf -> (False, True, setf)
116 Nothing -> (True, True, error $ "no fore color support for terminal " ++ inID)
117 msetab <- probeCap ti "setab"
118 msetb <- probeCap ti "setb"
119 let set_back_cap
120 = case msetab of
121 Nothing -> case msetb of
122 Just setb -> setb
123 Nothing -> error $ "no back color support for terminal " ++ inID
124 Just setab -> setab
125 terminfoCaps <- pure TerminfoCaps
126 <*> probeCap ti "smcup"
127 <*> probeCap ti "rmcup"
128 <*> requireCap ti "cup"
129 <*> probeCap ti "cnorm"
130 <*> probeCap ti "civis"
131 <*> pure noColors
132 <*> pure useAlt
133 <*> pure setForeCap
134 <*> pure set_back_cap
135 <*> requireCap ti "sgr0"
136 <*> requireCap ti "clear"
137 <*> requireCap ti "el"
138 <*> currentDisplayAttrCaps ti
139 newAssumedStateRef <- newIORef initialAssumedState
140 let t = Output
141 { terminalID = inID
142 , releaseTerminal = liftIO $ do
143 sendCap setDefaultAttr []
144 maybeSendCap cnorm []
145 hClose outHandle
146 , reserveDisplay = liftIO $ do
147 -- If there is no support for smcup: Clear the screen and then move the mouse to the
148 -- home position to approximate the behavior.
149 maybeSendCap smcup []
150 hFlush outHandle
151 sendCap clearScreen []
152 , releaseDisplay = liftIO $ do
153 maybeSendCap rmcup []
154 maybeSendCap cnorm []
155 , displayBounds = do
156 rawSize <- liftIO $ withFd outHandle getWindowSize
157 case rawSize of
158 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
159 | otherwise -> return (w,h)
160 , outputByteBuffer = \outBytes -> do
161 BS.hPut outHandle outBytes
162 hFlush outHandle
163 , contextColorCount
164 = case supportsNoColors terminfoCaps of
165 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
166 Nothing -> 8
167 Just v -> toEnum v
168 True -> 1
169 , supportsCursorVisibility = isJust $ civis terminfoCaps
170 , assumedStateRef = newAssumedStateRef
171 -- I think fix would help assure tActual is the only reference. I was having issues
172 -- tho.
173 , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
174 }
175 sendCap s = sendCapToTerminal t (s terminfoCaps)
176 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
177 return t
179requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
180requireCap ti capName
181 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
182 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
183 Just capStr -> parseCap capStr
185probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
186probeCap ti capName
187 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
188 Nothing -> return Nothing
189 Just capStr -> Just <$> parseCap capStr
191parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
192parseCap capStr = do
193 case parseCapExpression capStr of
194 Left e -> fail $ show e
195 Right cap -> return cap
197currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
198 => Terminfo.Terminal
199 -> m DisplayAttrCaps
200currentDisplayAttrCaps ti
201 = pure DisplayAttrCaps
202 <*> probeCap ti "sgr"
203 <*> probeCap ti "smso"
204 <*> probeCap ti "rmso"
205 <*> probeCap ti "smul"
206 <*> probeCap ti "rmul"
207 <*> probeCap ti "rev"
208 <*> probeCap ti "dim"
209 <*> probeCap ti "bold"
211foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
213getWindowSize :: Fd -> IO (Int,Int)
214getWindowSize fd = do
215 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
216 return (fromIntegral b, fromIntegral a)
218terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
219terminfoDisplayContext tActual terminfoCaps r = return dc
220 where dc = DisplayContext
221 { contextDevice = tActual
222 , contextRegion = r
223 , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
224 , writeShowCursor = case cnorm terminfoCaps of
225 Nothing -> error "this terminal does not support show cursor"
226 Just c -> writeCapExpr c []
227 , writeHideCursor = case civis terminfoCaps of
228 Nothing -> error "this terminal does not support hide cursor"
229 Just c -> writeCapExpr c []
230 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
231 , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
232 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
233 , inlineHack = return ()
234 }
236-- | Portably setting the display attributes is a giant pain in the ass.
237--
238-- If the terminal supports the sgr capability (which sets the on/off state of each style
239-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
240--
241-- 0. set the style attributes. This resets the fore and back color.
242--
243-- 1, If a foreground color is to be set then set the foreground color
244--
245-- 2. likewise with the background color
246--
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)
249-- then:
250--
251-- 0. reset all display attributes (sgr0)
252--
253-- 1. enter required style modes
254--
255-- 2. set the fore color if required
256--
257-- 3. set the back color if required
258--
259-- Entering the required style modes could require a reset of the display attributes. If this is
260-- the case then the back and fore colors always need to be set if not default.
261--
262-- This equation implements the above logic.
263--
264-- \todo This assumes the removal of color changes in the display attributes is done as expected
265-- with noColors == True. See `limit_attr_for_display`
266--
267-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
268-- haven't measured this or even examined terminal implementations. *shrug*
269terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
270terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
271 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
273 -- state capability or the set default capability.
274 True -> do
275 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
276 (fixedStyle attr )
277 (styleToApplySeq $ fixedStyle attr) of
278 -- only way to reset a color to the defaults
279 EnterExitSeq caps -> writeDefaultAttr dc
280 `mappend`
281 foldMap (\cap -> writeCapExpr cap []) caps
282 `mappend`
283 setColors
284 -- implicitly resets the colors to the defaults
285 SetState state -> writeCapExpr (fromJust $ setAttrStates
286 $ displayAttrCaps
287 $ terminfoCaps
288 )
289 (sgrArgsForState state)
290 `mappend`
291 setColors
292 -- Otherwise the display colors are not changing or changing between two non-default
293 -- points.
294 False -> do
295 -- Still, it could be the case that the change in display attributes requires the
296 -- colors to be reset because the required capability was not available.
297 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
298 (fixedStyle attr)
299 (styleDiffs diffs) of
300 -- Really, if terminals were re-implemented with modern concepts instead of bowing
301 -- down to 40 yr old dumb terminal requirements this would be the only case ever
302 -- reached! Changes the style and color states according to the differences with
303 -- the currently applied states.
304 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
305 `mappend`
306 writeColorDiff setForeColor (foreColorDiff diffs)
307 `mappend`
308 writeColorDiff setBackColor (backColorDiff diffs)
309 -- implicitly resets the colors to the defaults
310 SetState state -> writeCapExpr (fromJust $ setAttrStates
311 $ displayAttrCaps terminfoCaps
312 )
313 (sgrArgsForState state)
314 `mappend` setColors
315 where
316 colorMap = case useAltColorMap terminfoCaps of
317 False -> ansiColorIndex
318 True -> altColorIndex
319 attr = fixDisplayAttr prevAttr reqAttr
320 setColors =
321 (case fixedForeColor attr of
322 Just c -> writeCapExpr (setForeColor terminfoCaps)
323 [toEnum $ colorMap c]
324 Nothing -> mempty)
325 `mappend`
326 (case fixedBackColor attr of
327 Just c -> writeCapExpr (setBackColor terminfoCaps)
328 [toEnum $ colorMap c]
329 Nothing -> mempty)
330 writeColorDiff _f NoColorChange
331 = mempty
332 writeColorDiff _f ColorToDefault
333 = error "ColorToDefault is not a possible case for applyColorDiffs"
334 writeColorDiff f (SetColor c)
335 = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
337-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
338-- be supported by the terminal.
339--
340-- This takes a Color which clearly identifies which pallete to use and computes the index
341-- into the full 256 color pallete.
342ansiColorIndex :: Color -> Int
343ansiColorIndex (ISOColor v) = fromEnum v
344ansiColorIndex (Color240 v) = 16 + fromEnum v
346-- | For terminals without setaf/setab
347--
348-- See table in `man terminfo`
349-- Will error if not in table.
350altColorIndex :: Color -> Int
351altColorIndex (ISOColor 0) = 0
352altColorIndex (ISOColor 1) = 4
353altColorIndex (ISOColor 2) = 2
354altColorIndex (ISOColor 3) = 6
355altColorIndex (ISOColor 4) = 1
356altColorIndex (ISOColor 5) = 5
357altColorIndex (ISOColor 6) = 3
358altColorIndex (ISOColor 7) = 7
359altColorIndex (ISOColor v) = fromEnum v
360altColorIndex (Color240 v) = 16 + fromEnum v
362{- | The sequence of terminfo caps to apply a given style are determined 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.
366 -
367 - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
368 - display attributes are reset to defaults then the display attribute state is set.
369 -
370 - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
371 - display attribute state is set if possible. Otherwise the mode is not applied.
372 -
373 - 4. If the display attribute state is being set then just update the arguments to that for any
374 - apply/remove.
375 -
376 -}
377data DisplayAttrSeq
378 = EnterExitSeq [CapExpression]
379 | SetState DisplayAttrState
381data DisplayAttrState = DisplayAttrState
382 { applyStandout :: Bool
383 , applyUnderline :: Bool
384 , applyReverseVideo :: Bool
385 , applyBlink :: Bool
386 , applyDim :: Bool
387 , applyBold :: Bool
388 }
390sgrArgsForState :: DisplayAttrState -> [CapParam]
391sgrArgsForState attrState = map (\b -> if b then 1 else 0)
392 [ applyStandout attrState
393 , applyUnderline attrState
394 , applyReverseVideo attrState
395 , applyBlink attrState
396 , applyDim attrState
397 , applyBold attrState
398 , False -- invis
399 , False -- protect
400 , False -- alt char set
401 ]
403reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
404reqDisplayCapSeqFor caps s diffs
405 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
406 -- then either the state needs to be set or the attribute change ignored.
407 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
408 -- If all the diffs have an enter-exit cap then just use those
409 ( 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
411 -- all unsupported diffs and just apply the rest
412 ( True, False ) -> EnterExitSeq $ map enterExitCap
413 $ 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
415 -- the set state cap.
416 ( True, True ) -> SetState $ stateForStyle s
417 where
418 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
419 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
420 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
421 noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
422 noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
423 noEnterExitCap RemoveReverseVideo = True
424 noEnterExitCap ApplyBlink = True
425 noEnterExitCap RemoveBlink = True
426 noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
427 noEnterExitCap RemoveDim = True
428 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
429 noEnterExitCap RemoveBold = True
430 enterExitCap ApplyStandout = fromJust $ enterStandout caps
431 enterExitCap RemoveStandout = fromJust $ exitStandout caps
432 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
433 enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
434 enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
435 enterExitCap ApplyDim = fromJust $ enterDimMode caps
436 enterExitCap ApplyBold = fromJust $ enterBoldMode caps
437 enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
439stateForStyle :: Style -> DisplayAttrState
440stateForStyle s = DisplayAttrState
441 { applyStandout = isStyleSet standout
442 , applyUnderline = isStyleSet underline
443 , applyReverseVideo = isStyleSet reverseVideo
444 , applyBlink = isStyleSet blink
445 , applyDim = isStyleSet dim
446 , applyBold = isStyleSet bold
447 }
448 where isStyleSet = hasStyle s
450styleToApplySeq :: Style -> [StyleStateChange]
451styleToApplySeq s = concat
452 [ applyIfRequired ApplyStandout standout
453 , applyIfRequired ApplyUnderline underline
454 , applyIfRequired ApplyReverseVideo reverseVideo
455 , applyIfRequired ApplyBlink blink
456 , applyIfRequired ApplyDim dim
457 , applyIfRequired ApplyBlink bold
458 ]
459 where
460 applyIfRequired op flag
461 = if 0 == (flag .&. s)
462 then []
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
468-- to close the fd.
469withFd :: Handle -> (Fd -> IO a) -> IO a
470#ifdef __GLASGOW_HASKELL__
471#if __GLASGOW_HASKELL__ >= 611
472withFd 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)))
478#else
479withFd h f =
480 withHandle_ "withFd" h $ \ h_ ->
481 f (Fd (fromIntegral (haFD h_)))
482#endif
483#endif