git.iko.soy/vty
on d64ff96 help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
539 lines 23 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
5{-# CFILES gwinsz.c #-}
7-- | Terminfo-based terminal output driver.
8--
9-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
10module Graphics.Vty.Output.TerminfoBased
11 ( reserveTerminal
12 )
13where
15import Control.Monad (when)
16import qualified Data.ByteString as BS
17import Data.ByteString.Internal (toForeignPtr)
18import Data.Terminfo.Parse
19import Data.Terminfo.Eval
21import Graphics.Vty.Attributes
22import Graphics.Vty.Image (DisplayRegion)
23import Graphics.Vty.DisplayAttributes
24import Graphics.Vty.Output.Interface
26import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)
28import Control.Monad.Trans
30import Data.Bits ((.&.))
31import Data.Foldable (foldMap)
32import Data.IORef
33import Data.Maybe (isJust, isNothing, fromJust)
34import Data.Word
36import Foreign.C.Types ( CInt(..), CLong(..) )
37import Foreign.ForeignPtr (withForeignPtr)
38import Foreign.Ptr (Ptr, plusPtr)
40import qualified System.Console.Terminfo as Terminfo
41import System.Posix.IO (fdWriteBuf)
42import System.Posix.Types (Fd(..))
44data TerminfoCaps = TerminfoCaps
45 { smcup :: Maybe CapExpression
46 , rmcup :: Maybe CapExpression
47 , cup :: CapExpression
48 , cnorm :: Maybe CapExpression
49 , civis :: Maybe CapExpression
50 , supportsNoColors :: Bool
51 , useAltColorMap :: Bool
52 , setForeColor :: CapExpression
53 , setBackColor :: CapExpression
54 , setDefaultAttr :: CapExpression
55 , clearScreen :: CapExpression
56 , clearEol :: CapExpression
57 , displayAttrCaps :: DisplayAttrCaps
58 , ringBellAudio :: Maybe CapExpression
59 }
61data DisplayAttrCaps = DisplayAttrCaps
62 { setAttrStates :: Maybe CapExpression
63 , enterStandout :: Maybe CapExpression
64 , exitStandout :: Maybe CapExpression
65 , enterItalic :: Maybe CapExpression
66 , exitItalic :: Maybe CapExpression
67 , enterUnderline :: Maybe CapExpression
68 , exitUnderline :: Maybe CapExpression
69 , enterReverseVideo :: Maybe CapExpression
70 , enterDimMode :: Maybe CapExpression
71 , enterBoldMode :: Maybe CapExpression
72 }
74-- kinda like:
75-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
76-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
77-- the write will be retried.
78fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
79fdWriteAll outFd ptr len count
80 | len < 0 = fail "fdWriteAll: len is less than 0"
81 | len == 0 = return count
82 | otherwise = do
83 writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)
84 let len' = len - writeCount
85 ptr' = ptr `plusPtr` writeCount
86 count' = count + writeCount
87 fdWriteAll outFd ptr' len' count'
89sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
90sendCapToTerminal t cap capParams = do
91 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
93-- | Constructs an output driver that uses terminfo for all control
94-- codes. While this should provide the most compatible terminal,
95-- terminfo does not support some features that would increase
96-- efficiency and improve compatibility:
97--
98-- * determining the character encoding supported by the terminal.
99-- Should this be taken from the LANG environment variable?
100--
101-- * Providing independent string capabilities for all display
102-- attributes.
103reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
104reserveTerminal termName outFd = liftIO $ do
105 ti <- Terminfo.setupTerm termName
106 -- assumes set foreground always implies set background exists.
107 -- if set foreground is not set then all color changing style
108 -- 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 " ++ termName)
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 " ++ termName
124 Just setab -> setab
126 hyperlinkModeStatus <- newIORef False
127 newAssumedStateRef <- newIORef initialAssumedState
129 let terminfoSetMode m newStatus = do
130 curStatus <- terminfoModeStatus m
131 when (newStatus /= curStatus) $
132 case m of
133 Hyperlink -> liftIO $ do
134 writeIORef hyperlinkModeStatus newStatus
135 writeIORef newAssumedStateRef initialAssumedState
136 _ -> return ()
137 terminfoModeStatus m =
138 case m of
139 Hyperlink -> liftIO $ readIORef hyperlinkModeStatus
140 _ -> return False
141 terminfoModeSupported Hyperlink = True
142 terminfoModeSupported _ = False
144 terminfoCaps <- pure TerminfoCaps
145 <*> probeCap ti "smcup"
146 <*> probeCap ti "rmcup"
147 <*> requireCap ti "cup"
148 <*> probeCap ti "cnorm"
149 <*> probeCap ti "civis"
150 <*> pure noColors
151 <*> pure useAlt
152 <*> pure setForeCap
153 <*> pure set_back_cap
154 <*> requireCap ti "sgr0"
155 <*> requireCap ti "clear"
156 <*> requireCap ti "el"
157 <*> currentDisplayAttrCaps ti
158 <*> probeCap ti "bel"
159 let t = Output
160 { terminalID = termName
161 , releaseTerminal = liftIO $ do
162 sendCap setDefaultAttr []
163 maybeSendCap cnorm []
164 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
165 , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
166 , reserveDisplay = liftIO $ do
167 -- If there is no support for smcup: Clear the screen
168 -- and then move the mouse to the home position to
169 -- approximate the behavior.
170 maybeSendCap smcup []
171 sendCap clearScreen []
172 , releaseDisplay = liftIO $ do
173 maybeSendCap rmcup []
174 maybeSendCap cnorm []
175 , displayBounds = do
176 rawSize <- liftIO $ getWindowSize outFd
177 case rawSize of
178 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
179 | otherwise -> return (w,h)
180 , outputByteBuffer = \outBytes -> do
181 let (fptr, offset, len) = toForeignPtr outBytes
182 actualLen <- withForeignPtr fptr
183 $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0
184 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
185 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
186 ++ " Please report this bug to vty project."
187 , contextColorCount
188 = case supportsNoColors terminfoCaps of
189 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
190 Nothing -> 8
191 Just v -> toEnum v
192 True -> 1
193 , supportsCursorVisibility = isJust $ civis terminfoCaps
194 , supportsMode = terminfoModeSupported
195 , setMode = terminfoSetMode
196 , getModeStatus = terminfoModeStatus
197 , assumedStateRef = newAssumedStateRef
198 -- I think fix would help assure tActual is the only
199 -- reference. I was having issues tho.
200 , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
201 }
202 sendCap s = sendCapToTerminal t (s terminfoCaps)
203 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
204 return t
206requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
207requireCap ti capName
208 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
209 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
210 Just capStr -> parseCap capStr
212probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
213probeCap ti capName
214 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
215 Nothing -> return Nothing
216 Just capStr -> Just <$> parseCap capStr
218parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
219parseCap capStr = do
220 case parseCapExpression capStr of
221 Left e -> fail $ show e
222 Right cap -> return cap
224currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
225 => Terminfo.Terminal
226 -> m DisplayAttrCaps
227currentDisplayAttrCaps ti
228 = pure DisplayAttrCaps
229 <*> probeCap ti "sgr"
230 <*> probeCap ti "smso"
231 <*> probeCap ti "rmso"
232 <*> probeCap ti "sitm"
233 <*> probeCap ti "ritm"
234 <*> probeCap ti "smul"
235 <*> probeCap ti "rmul"
236 <*> probeCap ti "rev"
237 <*> probeCap ti "dim"
238 <*> probeCap ti "bold"
240foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
242getWindowSize :: Fd -> IO (Int,Int)
243getWindowSize fd = do
244 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
245 return (fromIntegral b, fromIntegral a)
247terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
248terminfoDisplayContext tActual terminfoCaps r = return dc
249 where dc = DisplayContext
250 { contextDevice = tActual
251 , contextRegion = r
252 , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
253 , writeShowCursor = case cnorm terminfoCaps of
254 Nothing -> error "this terminal does not support show cursor"
255 Just c -> writeCapExpr c []
256 , writeHideCursor = case civis terminfoCaps of
257 Nothing -> error "this terminal does not support hide cursor"
258 Just c -> writeCapExpr c []
259 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
260 , writeDefaultAttr = \urlsEnabled ->
261 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
262 (if urlsEnabled then writeURLEscapes EndLink else mempty)
263 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
264 , inlineHack = return ()
265 }
267-- | Write the escape sequences that are used in some terminals to
268-- include embedded hyperlinks. As of yet, this information isn't
269-- included in termcap or terminfo, so this writes them directly
270-- instead of looking up the appropriate capabilities.
271writeURLEscapes :: URLDiff -> Write
272writeURLEscapes (LinkTo url) =
273 foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
274 foldMap writeStorable (BS.unpack url) `mappend`
275 writeStorable (0x07 :: Word8)
276writeURLEscapes EndLink =
277 foldMap writeStorable (BS.unpack "\x1b]8;;\a")
278writeURLEscapes NoLinkChange =
279 mempty
281-- | Portably setting the display attributes is a giant pain in the ass.
282--
283-- If the terminal supports the sgr capability (which sets the on/off
284-- state of each style directly ; and, for no good reason, resets the
285-- colors to the default) this procedure is used:
286--
287-- 0. set the style attributes. This resets the fore and back color.
288--
289-- 1, If a foreground color is to be set then set the foreground color
290--
291-- 2. likewise with the background color
292--
293-- If the terminal does not support the sgr cap then: if there is a
294-- change from an applied color to the default (in either the fore or
295-- back color) then:
296--
297-- 0. reset all display attributes (sgr0)
298--
299-- 1. enter required style modes
300--
301-- 2. set the fore color if required
302--
303-- 3. set the back color if required
304--
305-- Entering the required style modes could require a reset of the
306-- display attributes. If this is the case then the back and fore colors
307-- always need to be set if not default.
308--
309-- This equation implements the above logic.
310--
311-- Note that this assumes the removal of color changes in the
312-- display attributes is done as expected with noColors == True. See
313-- `limitAttrForDisplay`.
314--
315-- Note that this optimizes for fewer state changes followed by fewer
316-- bytes.
317terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
318terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
319 urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
320 -- The only way to reset either color, portably, to the default
321 -- is to use either the set state capability or the set default
322 -- capability.
323 True -> do
324 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
325 (fixedStyle attr )
326 (styleToApplySeq $ fixedStyle attr) of
327 -- only way to reset a color to the defaults
328 EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
329 `mappend`
330 foldMap (\cap -> writeCapExpr cap []) caps
331 `mappend`
332 setColors
333 -- implicitly resets the colors to the defaults
334 SetState state -> writeCapExpr (fromJust $ setAttrStates
335 $ displayAttrCaps
336 $ terminfoCaps
337 )
338 (sgrArgsForState state)
339 `mappend` setItalics
340 `mappend` setColors
341 -- Otherwise the display colors are not changing or changing
342 -- between two non-default points.
343 False -> do
344 -- Still, it could be the case that the change in display
345 -- attributes requires the colors to be reset because the
346 -- required capability was not available.
347 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
348 (fixedStyle attr)
349 (styleDiffs diffs) of
350 -- Really, if terminals were re-implemented with modern
351 -- concepts instead of bowing down to 40 yr old dumb
352 -- terminal requirements this would be the only case
353 -- ever reached! Changes the style and color states
354 -- according to the differences with the currently
355 -- applied states.
356 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
357 `mappend`
358 writeColorDiff setForeColor (foreColorDiff diffs)
359 `mappend`
360 writeColorDiff setBackColor (backColorDiff diffs)
361 -- implicitly resets the colors to the defaults
362 SetState state -> writeCapExpr (fromJust $ setAttrStates
363 $ displayAttrCaps terminfoCaps
364 )
365 (sgrArgsForState state)
366 `mappend` setItalics
367 `mappend` setColors
368 where
369 urlAttrs True = writeURLEscapes (urlDiff diffs)
370 urlAttrs False = mempty
371 colorMap = case useAltColorMap terminfoCaps of
372 False -> ansiColorIndex
373 True -> altColorIndex
374 attr = fixDisplayAttr prevAttr reqAttr
376 -- italics can't be set via SGR, so here we manually
377 -- apply the enter and exit sequences as needed after
378 -- changing the SGR
379 setItalics
380 | hasStyle (fixedStyle attr) italic
381 , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
382 = writeCapExpr sitm []
383 | otherwise = mempty
384 setColors =
385 (case fixedForeColor attr of
386 Just c -> writeCapExpr (setForeColor terminfoCaps)
387 [toEnum $ colorMap c]
388 Nothing -> mempty)
389 `mappend`
390 (case fixedBackColor attr of
391 Just c -> writeCapExpr (setBackColor terminfoCaps)
392 [toEnum $ colorMap c]
393 Nothing -> mempty)
394 writeColorDiff _f NoColorChange
395 = mempty
396 writeColorDiff _f ColorToDefault
397 = error "ColorToDefault is not a possible case for applyColorDiffs"
398 writeColorDiff f (SetColor c)
399 = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
401-- | The color table used by a terminal is a 16 color set followed by a
402-- 240 color set that might not be supported by the terminal.
403--
404-- This takes a Color which clearly identifies which pallete to use and
405-- computes the index into the full 256 color pallete.
406ansiColorIndex :: Color -> Int
407ansiColorIndex (ISOColor v) = fromEnum v
408ansiColorIndex (Color240 v) = 16 + fromEnum v
410-- | For terminals without setaf/setab
411--
412-- See table in `man terminfo`
413-- Will error if not in table.
414altColorIndex :: Color -> Int
415altColorIndex (ISOColor 0) = 0
416altColorIndex (ISOColor 1) = 4
417altColorIndex (ISOColor 2) = 2
418altColorIndex (ISOColor 3) = 6
419altColorIndex (ISOColor 4) = 1
420altColorIndex (ISOColor 5) = 5
421altColorIndex (ISOColor 6) = 3
422altColorIndex (ISOColor 7) = 7
423altColorIndex (ISOColor v) = fromEnum v
424altColorIndex (Color240 v) = 16 + fromEnum v
426{- | The sequence of terminfo caps to apply a given style are determined
427 - according to these rules.
428 -
429 - 1. The assumption is that it's preferable to use the simpler
430 - enter/exit mode capabilities than the full set display attribute
431 - state capability.
432 -
433 - 2. If a mode is supposed to be removed but there is not an exit
434 - capability defined then the display attributes are reset to defaults
435 - then the display attribute state is set.
436 -
437 - 3. If a mode is supposed to be applied but there is not an enter
438 - capability defined then then display attribute state is set if
439 - possible. Otherwise the mode is not applied.
440 -
441 - 4. If the display attribute state is being set then just update the
442 - arguments to that for any apply/remove.
443 -}
444data DisplayAttrSeq
445 = EnterExitSeq [CapExpression]
446 | SetState DisplayAttrState
448data DisplayAttrState = DisplayAttrState
449 { applyStandout :: Bool
450 , applyUnderline :: Bool
451 , applyItalic :: Bool
452 , applyReverseVideo :: Bool
453 , applyBlink :: Bool
454 , applyDim :: Bool
455 , applyBold :: Bool
456 }
458sgrArgsForState :: DisplayAttrState -> [CapParam]
459sgrArgsForState attrState = map (\b -> if b then 1 else 0)
460 [ applyStandout attrState
461 , applyUnderline attrState
462 , applyReverseVideo attrState
463 , applyBlink attrState
464 , applyDim attrState
465 , applyBold attrState
466 , False -- invis
467 , False -- protect
468 , False -- alt char set
469 ]
471reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
472reqDisplayCapSeqFor caps s diffs
473 -- if the state transition implied by any diff cannot be supported
474 -- with an enter/exit mode cap then either the state needs to be set
475 -- or the attribute change ignored.
476 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
477 -- If all the diffs have an enter-exit cap then just use those
478 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
479 -- If not all the diffs have an enter-exit cap and there is no
480 -- set state cap then filter out all unsupported diffs and just
481 -- apply the rest
482 ( True, False ) -> EnterExitSeq $ map enterExitCap
483 $ filter (not . noEnterExitCap) diffs
484 -- if not all the diffs have an enter-exit can and there is a
485 -- set state cap then just use the set state cap.
486 ( True, True ) -> SetState $ stateForStyle s
487 where
488 noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
489 noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
490 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
491 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
492 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
493 noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
494 noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
495 noEnterExitCap RemoveReverseVideo = True
496 noEnterExitCap ApplyBlink = True
497 noEnterExitCap RemoveBlink = True
498 noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
499 noEnterExitCap RemoveDim = True
500 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
501 noEnterExitCap RemoveBold = True
502 enterExitCap ApplyItalic = fromJust $ enterItalic caps
503 enterExitCap RemoveItalic = fromJust $ exitItalic caps
504 enterExitCap ApplyStandout = fromJust $ enterStandout caps
505 enterExitCap RemoveStandout = fromJust $ exitStandout caps
506 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
507 enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
508 enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
509 enterExitCap ApplyDim = fromJust $ enterDimMode caps
510 enterExitCap ApplyBold = fromJust $ enterBoldMode caps
511 enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
513stateForStyle :: Style -> DisplayAttrState
514stateForStyle s = DisplayAttrState
515 { applyStandout = isStyleSet standout
516 , applyUnderline = isStyleSet underline
517 , applyItalic = isStyleSet italic
518 , applyReverseVideo = isStyleSet reverseVideo
519 , applyBlink = isStyleSet blink
520 , applyDim = isStyleSet dim
521 , applyBold = isStyleSet bold
522 }
523 where isStyleSet = hasStyle s
525styleToApplySeq :: Style -> [StyleStateChange]
526styleToApplySeq s = concat
527 [ applyIfRequired ApplyStandout standout
528 , applyIfRequired ApplyUnderline underline
529 , applyIfRequired ApplyItalic italic
530 , applyIfRequired ApplyReverseVideo reverseVideo
531 , applyIfRequired ApplyBlink blink
532 , applyIfRequired ApplyDim dim
533 , applyIfRequired ApplyBold bold
534 ]
535 where
536 applyIfRequired op flag
537 = if 0 == (flag .&. s)
538 then []
539 else [op]