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