git.iko.soy/vty
on 8e0c7cc help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
476 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 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
96 - environment variable?
97 - * Provide independent string capabilities for all display attributes.
98 -
99 -
100 - todo: Some display attributes like underline and bold have independent string capabilities that
101 - should be used instead of the generic "sgr" string capability.
102 -}
103reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
104reserveTerminal inID outHandle = liftIO $ do
105 ti <- Terminfo.setupTerm inID
106 -- assumes set foreground always implies set background exists.
107 -- if set foreground is not set then all color changing style attributes are filtered.
108 msetaf <- probeCap ti "setaf"
109 msetf <- probeCap ti "setf"
110 let (noColors, useAlt, setForeCap)
111 = case msetaf of
112 Just setaf -> (False, False, setaf)
113 Nothing -> case msetf of
114 Just setf -> (False, True, setf)
115 Nothing -> (True, True, error $ "no fore color support for terminal " ++ inID)
116 msetab <- probeCap ti "setab"
117 msetb <- probeCap ti "setb"
118 let set_back_cap
119 = case msetab of
120 Nothing -> case msetb of
121 Just setb -> setb
122 Nothing -> error $ "no back color support for terminal " ++ inID
123 Just setab -> setab
124 terminfoCaps <- pure TerminfoCaps
125 <*> probeCap ti "smcup"
126 <*> probeCap ti "rmcup"
127 <*> requireCap ti "cup"
128 <*> probeCap ti "cnorm"
129 <*> probeCap ti "civis"
130 <*> pure noColors
131 <*> pure useAlt
132 <*> pure setForeCap
133 <*> pure set_back_cap
134 <*> requireCap ti "sgr0"
135 <*> requireCap ti "clear"
136 <*> requireCap ti "el"
137 <*> currentDisplayAttrCaps ti
138 newAssumedStateRef <- newIORef initialAssumedState
139 let t = Output
140 { terminalID = inID
141 , releaseTerminal = liftIO $ do
142 sendCap setDefaultAttr []
143 maybeSendCap cnorm []
144 hClose outHandle
145 , reserveDisplay = liftIO $ do
146 -- If there is no support for smcup: Clear the screen and then move the mouse to the
147 -- home position to approximate the behavior.
148 maybeSendCap smcup []
149 hFlush outHandle
150 sendCap clearScreen []
151 , releaseDisplay = liftIO $ do
152 maybeSendCap rmcup []
153 maybeSendCap cnorm []
154 , displayBounds = do
155 rawSize <- liftIO $ withFd outHandle getWindowSize
156 case rawSize of
157 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
158 | otherwise -> return (w,h)
159 , outputByteBuffer = \outBytes -> do
160 BS.hPut outHandle outBytes
161 hFlush outHandle
162 , contextColorCount
163 = case supportsNoColors terminfoCaps of
164 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
165 Nothing -> 8
166 Just v -> toEnum v
167 True -> 1
168 , supportsCursorVisibility = isJust $ civis terminfoCaps
169 , assumedStateRef = newAssumedStateRef
170 -- I think fix would help assure tActual is the only reference. I was having issues
171 -- tho.
172 , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
173 }
174 sendCap s = sendCapToTerminal t (s terminfoCaps)
175 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
176 return t
178requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
179requireCap ti capName
180 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
181 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
182 Just capStr -> parseCap capStr
184probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
185probeCap ti capName
186 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
187 Nothing -> return Nothing
188 Just capStr -> Just <$> parseCap capStr
190parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
191parseCap capStr = do
192 case parseCapExpression capStr of
193 Left e -> fail $ show e
194 Right cap -> return cap
196currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
197 => Terminfo.Terminal
198 -> m DisplayAttrCaps
199currentDisplayAttrCaps ti
200 = pure DisplayAttrCaps
201 <*> probeCap ti "sgr"
202 <*> probeCap ti "smso"
203 <*> probeCap ti "rmso"
204 <*> probeCap ti "smul"
205 <*> probeCap ti "rmul"
206 <*> probeCap ti "rev"
207 <*> probeCap ti "dim"
208 <*> probeCap ti "bold"
210foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
212getWindowSize :: Fd -> IO (Int,Int)
213getWindowSize fd = do
214 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
215 return (fromIntegral b, fromIntegral a)
217terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
218terminfoDisplayContext tActual terminfoCaps r = return dc
219 where dc = DisplayContext
220 { contextDevice = tActual
221 , contextRegion = r
222 , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
223 , writeShowCursor = case cnorm terminfoCaps of
224 Nothing -> error "this terminal does not support show cursor"
225 Just c -> writeCapExpr c []
226 , writeHideCursor = case civis terminfoCaps of
227 Nothing -> error "this terminal does not support hide cursor"
228 Just c -> writeCapExpr c []
229 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
230 , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
231 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
232 , inlineHack = return ()
233 }
235-- | Portably setting the display attributes is a giant pain in the ass.
236--
237-- If the terminal supports the sgr capability (which sets the on/off state of each style
238-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
239--
240-- 0. set the style attributes. This resets the fore and back color.
241-- 1, If a foreground color is to be set then set the foreground color
242-- 2. likewise with the background color
243--
244-- If the terminal does not support the sgr cap then:
245-- if there is a change from an applied color to the default (in either the fore or back color)
246-- then:
247-- 0. reset all display attributes (sgr0)
248-- 1. enter required style modes
249-- 2. set the fore color if required
250-- 3. set the back color if required
251--
252-- Entering the required style modes could require a reset of the display attributes. If this is
253-- the case then the back and fore colors always need to be set if not default.
254--
255-- This equation implements the above logic.
256--
257-- \todo This assumes the removal of color changes in the display attributes is done as expected
258-- with noColors == True. See `limit_attr_for_display`
259--
260-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
261-- haven't measured this or even examined terminal implementations. *shrug*
262terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
263terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
264 case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
265 -- The only way to reset either color, portably, to the default is to use either the set
266 -- state capability or the set default capability.
267 True -> do
268 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
269 (fixedStyle attr )
270 (styleToApplySeq $ fixedStyle attr) of
271 -- only way to reset a color to the defaults
272 EnterExitSeq caps -> writeDefaultAttr dc
273 `mappend`
274 foldMap (\cap -> writeCapExpr cap []) caps
275 `mappend`
276 setColors
277 -- implicitly resets the colors to the defaults
278 SetState state -> writeCapExpr (fromJust $ setAttrStates
279 $ displayAttrCaps
280 $ terminfoCaps
281 )
282 (sgrArgsForState state)
283 `mappend`
284 setColors
285 -- Otherwise the display colors are not changing or changing between two non-default
286 -- points.
287 False -> do
288 -- Still, it could be the case that the change in display attributes requires the
289 -- colors to be reset because the required capability was not available.
290 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
291 (fixedStyle attr)
292 (styleDiffs diffs) of
293 -- Really, if terminals were re-implemented with modern concepts instead of bowing
294 -- down to 40 yr old dumb terminal requirements this would be the only case ever
295 -- reached! Changes the style and color states according to the differences with
296 -- the currently applied states.
297 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
298 `mappend`
299 writeColorDiff setForeColor (foreColorDiff diffs)
300 `mappend`
301 writeColorDiff setBackColor (backColorDiff diffs)
302 -- implicitly resets the colors to the defaults
303 SetState state -> writeCapExpr (fromJust $ setAttrStates
304 $ displayAttrCaps terminfoCaps
305 )
306 (sgrArgsForState state)
307 `mappend` setColors
308 where
309 colorMap = case useAltColorMap terminfoCaps of
310 False -> ansiColorIndex
311 True -> altColorIndex
312 attr = fixDisplayAttr prevAttr reqAttr
313 setColors =
314 (case fixedForeColor attr of
315 Just c -> writeCapExpr (setForeColor terminfoCaps)
316 [toEnum $ colorMap c]
317 Nothing -> mempty)
318 `mappend`
319 (case fixedBackColor attr of
320 Just c -> writeCapExpr (setBackColor terminfoCaps)
321 [toEnum $ colorMap c]
322 Nothing -> mempty)
323 writeColorDiff _f NoColorChange
324 = mempty
325 writeColorDiff _f ColorToDefault
326 = error "ColorToDefault is not a possible case for applyColorDiffs"
327 writeColorDiff f (SetColor c)
328 = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
330-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
331-- be supported by the terminal.
332--
333-- This takes a Color which clearly identifies which pallete to use and computes the index
334-- into the full 256 color pallete.
335ansiColorIndex :: Color -> Int
336ansiColorIndex (ISOColor v) = fromEnum v
337ansiColorIndex (Color240 v) = 16 + fromEnum v
339-- | For terminals without setaf/setab
340--
341-- See table in `man terminfo`
342-- Will error if not in table.
343altColorIndex :: Color -> Int
344altColorIndex (ISOColor 0) = 0
345altColorIndex (ISOColor 1) = 4
346altColorIndex (ISOColor 2) = 2
347altColorIndex (ISOColor 3) = 6
348altColorIndex (ISOColor 4) = 1
349altColorIndex (ISOColor 5) = 5
350altColorIndex (ISOColor 6) = 3
351altColorIndex (ISOColor 7) = 7
352altColorIndex (ISOColor v) = fromEnum v
353altColorIndex (Color240 v) = 16 + fromEnum v
355{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
356 -
357 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
358 - the full set display attribute state capability.
359 -
360 - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
361 - display attributes are reset to defaults then the display attribute state is set.
362 -
363 - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
364 - display attribute state is set if possible. Otherwise the mode is not applied.
365 -
366 - 4. If the display attribute state is being set then just update the arguments to that for any
367 - apply/remove.
368 -
369 -}
370data DisplayAttrSeq
371 = EnterExitSeq [CapExpression]
372 | SetState DisplayAttrState
374data DisplayAttrState = DisplayAttrState
375 { applyStandout :: Bool
376 , applyUnderline :: Bool
377 , applyReverseVideo :: Bool
378 , applyBlink :: Bool
379 , applyDim :: Bool
380 , applyBold :: Bool
381 }
383sgrArgsForState :: DisplayAttrState -> [CapParam]
384sgrArgsForState attrState = map (\b -> if b then 1 else 0)
385 [ applyStandout attrState
386 , applyUnderline attrState
387 , applyReverseVideo attrState
388 , applyBlink attrState
389 , applyDim attrState
390 , applyBold attrState
391 , False -- invis
392 , False -- protect
393 , False -- alt char set
394 ]
396reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
397reqDisplayCapSeqFor caps s diffs
398 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
399 -- then either the state needs to be set or the attribute change ignored.
400 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
401 -- If all the diffs have an enter-exit cap then just use those
402 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
403 -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
404 -- all unsupported diffs and just apply the rest
405 ( True, False ) -> EnterExitSeq $ map enterExitCap
406 $ filter (not . noEnterExitCap) diffs
407 -- if not all the diffs have an enter-exit can and there is a set state cap then just use
408 -- the set state cap.
409 ( True, True ) -> SetState $ stateForStyle s
410 where
411 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
412 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
413 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
414 noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
415 noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
416 noEnterExitCap RemoveReverseVideo = True
417 noEnterExitCap ApplyBlink = True
418 noEnterExitCap RemoveBlink = True
419 noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
420 noEnterExitCap RemoveDim = True
421 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
422 noEnterExitCap RemoveBold = True
423 enterExitCap ApplyStandout = fromJust $ enterStandout caps
424 enterExitCap RemoveStandout = fromJust $ exitStandout caps
425 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
426 enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
427 enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
428 enterExitCap ApplyDim = fromJust $ enterDimMode caps
429 enterExitCap ApplyBold = fromJust $ enterBoldMode caps
430 enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
432stateForStyle :: Style -> DisplayAttrState
433stateForStyle s = DisplayAttrState
434 { applyStandout = isStyleSet standout
435 , applyUnderline = isStyleSet underline
436 , applyReverseVideo = isStyleSet reverseVideo
437 , applyBlink = isStyleSet blink
438 , applyDim = isStyleSet dim
439 , applyBold = isStyleSet bold
440 }
441 where isStyleSet = hasStyle s
443styleToApplySeq :: Style -> [StyleStateChange]
444styleToApplySeq s = concat
445 [ applyIfRequired ApplyStandout standout
446 , applyIfRequired ApplyUnderline underline
447 , applyIfRequired ApplyReverseVideo reverseVideo
448 , applyIfRequired ApplyBlink blink
449 , applyIfRequired ApplyDim dim
450 , applyIfRequired ApplyBlink bold
451 ]
452 where
453 applyIfRequired op flag
454 = if 0 == (flag .&. s)
455 then []
456 else [op]
458-- from https://patch-tag.com/r/mae/sendfile/snapshot/current/content/pretty/src/Network/Socket/SendFile/Internal.hs
459-- The Fd should not be used after the action returns because the
460-- Handler may be garbage collected and than will cause the finalizer
461-- to close the fd.
462withFd :: Handle -> (Fd -> IO a) -> IO a
463#ifdef __GLASGOW_HASKELL__
464#if __GLASGOW_HASKELL__ >= 611
465withFd h f = withHandle_ "withFd" h $ \ Handle__{..} -> do
466 case cast haDevice of
467 Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
468 "withFd" (Just h) Nothing)
469 "handle is not a file descriptor")
470 Just fd -> f (Fd (fromIntegral (FD.fdFD fd)))
471#else
472withFd h f =
473 withHandle_ "withFd" h $ \ h_ ->
474 f (Fd (fromIntegral (haFD h_)))
475#endif
476#endif