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