git.iko.soy/vty
on ff9f4e6 help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
470 lines 20 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 }
69data DisplayAttrCaps = DisplayAttrCaps
70 { setAttrStates :: Maybe CapExpression
71 , enterStandout :: Maybe CapExpression
72 , exitStandout :: Maybe CapExpression
73 , enterUnderline :: Maybe CapExpression
74 , exitUnderline :: Maybe CapExpression
75 , enterReverseVideo :: Maybe CapExpression
76 , enterDimMode :: Maybe CapExpression
77 , enterBoldMode :: Maybe CapExpression
78 }
80-- kinda like: 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 the write will be retried.
82fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
83fdWriteAll outFd ptr len count
84 | len < 0 = fail "fdWriteAll: len is less than 0"
85 | len == 0 = return count
86 | otherwise = do
87 writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)
88 let len' = len - writeCount
89 ptr' = ptr `plusPtr` writeCount
90 count' = count + writeCount
91 fdWriteAll outFd ptr' len' count'
93sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
94sendCapToTerminal t cap capParams = do
95 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
97{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
98 - terminfo does not support some features that would increase efficiency and improve compatibility:
99 -
100 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
101 - environment variable?
102 -
103 - * Provide independent string capabilities for all display attributes.
104 -
105 - todo: Some display attributes like underline and bold have independent string capabilities that
106 - should be used instead of the generic "sgr" string capability.
107 -}
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 attributes are filtered.
113 msetaf <- probeCap ti "setaf"
114 msetf <- probeCap ti "setf"
115 let (noColors, useAlt, setForeCap)
116 = case msetaf of
117 Just setaf -> (False, False, setaf)
118 Nothing -> case msetf of
119 Just setf -> (False, True, setf)
120 Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
121 msetab <- probeCap ti "setab"
122 msetb <- probeCap ti "setb"
123 let set_back_cap
124 = case msetab of
125 Nothing -> case msetb of
126 Just setb -> setb
127 Nothing -> error $ "no back color support for terminal " ++ termName
128 Just setab -> setab
129 terminfoCaps <- pure TerminfoCaps
130 <*> probeCap ti "smcup"
131 <*> probeCap ti "rmcup"
132 <*> requireCap ti "cup"
133 <*> probeCap ti "cnorm"
134 <*> probeCap ti "civis"
135 <*> pure noColors
136 <*> pure useAlt
137 <*> pure setForeCap
138 <*> pure set_back_cap
139 <*> requireCap ti "sgr0"
140 <*> requireCap ti "clear"
141 <*> requireCap ti "el"
142 <*> currentDisplayAttrCaps ti
143 newAssumedStateRef <- newIORef initialAssumedState
144 let t = Output
145 { terminalID = termName
146 , releaseTerminal = liftIO $ do
147 sendCap setDefaultAttr []
148 maybeSendCap cnorm []
149 , reserveDisplay = liftIO $ do
150 -- If there is no support for smcup: Clear the screen and then move the mouse to the
151 -- home position to approximate the behavior.
152 maybeSendCap smcup []
153 sendCap clearScreen []
154 , releaseDisplay = liftIO $ do
155 maybeSendCap rmcup []
156 maybeSendCap cnorm []
157 , displayBounds = do
158 rawSize <- liftIO $ getWindowSize outFd
159 case rawSize of
160 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
161 | otherwise -> return (w,h)
162 , outputByteBuffer = \outBytes -> do
163 let (fptr, offset, len) = toForeignPtr outBytes
164 actualLen <- withForeignPtr fptr
165 $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0
166 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
167 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
168 ++ " Please report this bug to vty project."
169 , contextColorCount
170 = case supportsNoColors terminfoCaps of
171 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
172 Nothing -> 8
173 Just v -> toEnum v
174 True -> 1
175 , supportsCursorVisibility = isJust $ civis terminfoCaps
176 , assumedStateRef = newAssumedStateRef
177 -- I think fix would help assure tActual is the only reference. I was having issues
178 -- tho.
179 , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps
180 }
181 sendCap s = sendCapToTerminal t (s terminfoCaps)
182 maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
183 return t
185requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
186requireCap ti capName
187 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
188 Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
189 Just capStr -> parseCap capStr
191probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
192probeCap ti capName
193 = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
194 Nothing -> return Nothing
195 Just capStr -> Just <$> parseCap capStr
197parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression
198parseCap capStr = do
199 case parseCapExpression capStr of
200 Left e -> fail $ show e
201 Right cap -> return cap
203currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
204 => Terminfo.Terminal
205 -> m DisplayAttrCaps
206currentDisplayAttrCaps ti
207 = pure DisplayAttrCaps
208 <*> probeCap ti "sgr"
209 <*> probeCap ti "smso"
210 <*> probeCap ti "rmso"
211 <*> probeCap ti "smul"
212 <*> probeCap ti "rmul"
213 <*> probeCap ti "rev"
214 <*> probeCap ti "dim"
215 <*> probeCap ti "bold"
217foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
219getWindowSize :: Fd -> IO (Int,Int)
220getWindowSize fd = do
221 (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
222 return (fromIntegral b, fromIntegral a)
224terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
225terminfoDisplayContext tActual terminfoCaps r = return dc
226 where dc = DisplayContext
227 { contextDevice = tActual
228 , contextRegion = r
229 , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
230 , writeShowCursor = case cnorm terminfoCaps of
231 Nothing -> error "this terminal does not support show cursor"
232 Just c -> writeCapExpr c []
233 , writeHideCursor = case civis terminfoCaps of
234 Nothing -> error "this terminal does not support hide cursor"
235 Just c -> writeCapExpr c []
236 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
237 , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []
238 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
239 , inlineHack = return ()
240 }
242-- | Portably setting the display attributes is a giant pain in the ass.
243--
244-- If the terminal supports the sgr capability (which sets the on/off state of each style
245-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
246--
247-- 0. set the style attributes. This resets the fore and back color.
248--
249-- 1, If a foreground color is to be set then set the foreground color
250--
251-- 2. likewise with the background color
252--
253-- If the terminal does not support the sgr cap then:
254-- if there is a change from an applied color to the default (in either the fore or back color)
255-- then:
256--
257-- 0. reset all display attributes (sgr0)
258--
259-- 1. enter required style modes
260--
261-- 2. set the fore color if required
262--
263-- 3. set the back color if required
264--
265-- Entering the required style modes could require a reset of the display attributes. If this is
266-- the case then the back and fore colors always need to be set if not default.
267--
268-- This equation implements the above logic.
269--
270-- \todo This assumes the removal of color changes in the display attributes is done as expected
271-- with noColors == True. See `limitAttrForDisplay`
272--
273-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
274-- haven't measured this or even examined terminal implementations. *shrug*
275terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
276terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
277 case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
278 -- The only way to reset either color, portably, to the default is to use either the set
279 -- state capability or the set default capability.
280 True -> do
281 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
282 (fixedStyle attr )
283 (styleToApplySeq $ fixedStyle attr) of
284 -- only way to reset a color to the defaults
285 EnterExitSeq caps -> writeDefaultAttr dc
286 `mappend`
287 foldMap (\cap -> writeCapExpr cap []) caps
288 `mappend`
289 setColors
290 -- implicitly resets the colors to the defaults
291 SetState state -> writeCapExpr (fromJust $ setAttrStates
292 $ displayAttrCaps
293 $ terminfoCaps
294 )
295 (sgrArgsForState state)
296 `mappend`
297 setColors
298 -- Otherwise the display colors are not changing or changing between two non-default
299 -- points.
300 False -> do
301 -- Still, it could be the case that the change in display attributes requires the
302 -- colors to be reset because the required capability was not available.
303 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
304 (fixedStyle attr)
305 (styleDiffs diffs) of
306 -- Really, if terminals were re-implemented with modern concepts instead of bowing
307 -- down to 40 yr old dumb terminal requirements this would be the only case ever
308 -- reached! Changes the style and color states according to the differences with
309 -- the currently applied states.
310 EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
311 `mappend`
312 writeColorDiff setForeColor (foreColorDiff diffs)
313 `mappend`
314 writeColorDiff setBackColor (backColorDiff diffs)
315 -- implicitly resets the colors to the defaults
316 SetState state -> writeCapExpr (fromJust $ setAttrStates
317 $ displayAttrCaps terminfoCaps
318 )
319 (sgrArgsForState state)
320 `mappend` setColors
321 where
322 colorMap = case useAltColorMap terminfoCaps of
323 False -> ansiColorIndex
324 True -> altColorIndex
325 attr = fixDisplayAttr prevAttr reqAttr
326 setColors =
327 (case fixedForeColor attr of
328 Just c -> writeCapExpr (setForeColor terminfoCaps)
329 [toEnum $ colorMap c]
330 Nothing -> mempty)
331 `mappend`
332 (case fixedBackColor attr of
333 Just c -> writeCapExpr (setBackColor terminfoCaps)
334 [toEnum $ colorMap c]
335 Nothing -> mempty)
336 writeColorDiff _f NoColorChange
337 = mempty
338 writeColorDiff _f ColorToDefault
339 = error "ColorToDefault is not a possible case for applyColorDiffs"
340 writeColorDiff f (SetColor c)
341 = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]
343-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
344-- be supported by the terminal.
345--
346-- This takes a Color which clearly identifies which pallete to use and computes the index
347-- into the full 256 color pallete.
348ansiColorIndex :: Color -> Int
349ansiColorIndex (ISOColor v) = fromEnum v
350ansiColorIndex (Color240 v) = 16 + fromEnum v
352-- | For terminals without setaf/setab
353--
354-- See table in `man terminfo`
355-- Will error if not in table.
356altColorIndex :: Color -> Int
357altColorIndex (ISOColor 0) = 0
358altColorIndex (ISOColor 1) = 4
359altColorIndex (ISOColor 2) = 2
360altColorIndex (ISOColor 3) = 6
361altColorIndex (ISOColor 4) = 1
362altColorIndex (ISOColor 5) = 5
363altColorIndex (ISOColor 6) = 3
364altColorIndex (ISOColor 7) = 7
365altColorIndex (ISOColor v) = fromEnum v
366altColorIndex (Color240 v) = 16 + fromEnum v
368{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
369 -
370 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
371 - the full set display attribute state capability.
372 -
373 - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
374 - display attributes are reset to defaults then the display attribute state is set.
375 -
376 - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
377 - display attribute state is set if possible. Otherwise the mode is not applied.
378 -
379 - 4. If the display attribute state is being set then just update the arguments to that for any
380 - apply/remove.
381 -
382 -}
383data DisplayAttrSeq
384 = EnterExitSeq [CapExpression]
385 | SetState DisplayAttrState
387data DisplayAttrState = DisplayAttrState
388 { applyStandout :: Bool
389 , applyUnderline :: Bool
390 , applyReverseVideo :: Bool
391 , applyBlink :: Bool
392 , applyDim :: Bool
393 , applyBold :: Bool
394 }
396sgrArgsForState :: DisplayAttrState -> [CapParam]
397sgrArgsForState attrState = map (\b -> if b then 1 else 0)
398 [ applyStandout attrState
399 , applyUnderline attrState
400 , applyReverseVideo attrState
401 , applyBlink attrState
402 , applyDim attrState
403 , applyBold attrState
404 , False -- invis
405 , False -- protect
406 , False -- alt char set
407 ]
409reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
410reqDisplayCapSeqFor caps s diffs
411 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
412 -- then either the state needs to be set or the attribute change ignored.
413 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
414 -- If all the diffs have an enter-exit cap then just use those
415 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
416 -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
417 -- all unsupported diffs and just apply the rest
418 ( True, False ) -> EnterExitSeq $ map enterExitCap
419 $ filter (not . noEnterExitCap) diffs
420 -- if not all the diffs have an enter-exit can and there is a set state cap then just use
421 -- the set state cap.
422 ( True, True ) -> SetState $ stateForStyle s
423 where
424 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
425 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
426 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
427 noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
428 noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
429 noEnterExitCap RemoveReverseVideo = True
430 noEnterExitCap ApplyBlink = True
431 noEnterExitCap RemoveBlink = True
432 noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
433 noEnterExitCap RemoveDim = True
434 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
435 noEnterExitCap RemoveBold = True
436 enterExitCap ApplyStandout = fromJust $ enterStandout caps
437 enterExitCap RemoveStandout = fromJust $ exitStandout caps
438 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
439 enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
440 enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
441 enterExitCap ApplyDim = fromJust $ enterDimMode caps
442 enterExitCap ApplyBold = fromJust $ enterBoldMode caps
443 enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
445stateForStyle :: Style -> DisplayAttrState
446stateForStyle s = DisplayAttrState
447 { applyStandout = isStyleSet standout
448 , applyUnderline = isStyleSet underline
449 , applyReverseVideo = isStyleSet reverseVideo
450 , applyBlink = isStyleSet blink
451 , applyDim = isStyleSet dim
452 , applyBold = isStyleSet bold
453 }
454 where isStyleSet = hasStyle s
456styleToApplySeq :: Style -> [StyleStateChange]
457styleToApplySeq s = concat
458 [ applyIfRequired ApplyStandout standout
459 , applyIfRequired ApplyUnderline underline
460 , applyIfRequired ApplyReverseVideo reverseVideo
461 , applyIfRequired ApplyBlink blink
462 , applyIfRequired ApplyDim dim
463 , applyIfRequired ApplyBlink bold
464 ]
465 where
466 applyIfRequired op flag
467 = if 0 == (flag .&. s)
468 then []
469 else [op]