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