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