git.iko.soy/vty
on ebee723 help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
481 lines 20 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
4{-# CFILES gwinsz.c #-}
6-- | Terminfo based terminal handling.
7--
8-- The color handling assumes tektronix like. No HP support provided. If
9-- the terminal is not one I have easy access to then color support is
10-- entirely based of the docs. Probably with some assumptions mixed in.
11--
12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
13module Graphics.Vty.Output.TerminfoBased
14 ( reserveTerminal
15 )
16where
18import Control.Monad (when)
19import Data.ByteString.Internal (toForeignPtr)
20import Data.Terminfo.Parse
21import Data.Terminfo.Eval
23import Graphics.Vty.Attributes
24import Graphics.Vty.Image (DisplayRegion)
25import Graphics.Vty.DisplayAttributes
26import Graphics.Vty.Output.Interface
28import Blaze.ByteString.Builder (Write, writeToByteString)
30import Control.Monad.Trans
32import Data.Bits ((.&.))
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 , enterUnderline :: Maybe CapExpression
67 , exitUnderline :: Maybe CapExpression
68 , enterReverseVideo :: Maybe CapExpression
69 , enterDimMode :: Maybe CapExpression
70 , enterBoldMode :: Maybe CapExpression
71 }
73-- kinda like:
74-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
75-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
76-- the write will be retried.
77fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
78fdWriteAll outFd ptr len count
79 | len < 0 = fail "fdWriteAll: len is less than 0"
80 | len == 0 = return count
81 | otherwise = do
82 writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)
83 let len' = len - writeCount
84 ptr' = ptr `plusPtr` writeCount
85 count' = count + writeCount
86 fdWriteAll outFd ptr' len' count'
88sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
89sendCapToTerminal t cap capParams = do
90 outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
92-- | Uses terminfo for all control codes. While this should provide the
93-- most compatible terminal terminfo does not support some features that
94-- would increase efficiency and improve compatibility:
95--
96-- * determine the character encoding supported by the terminal. Should
97-- this be taken from the LANG environment variable?
98--
99-- * Provide independent string capabilities for all display attributes.
100reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
101reserveTerminal termName outFd = liftIO $ do
102 ti <- Terminfo.setupTerm termName
103 -- assumes set foreground always implies set background exists.
104 -- if set foreground is not set then all color changing style
105 -- attributes are filtered.
106 msetaf <- probeCap ti "setaf"
107 msetf <- probeCap ti "setf"
108 let (noColors, useAlt, setForeCap)
109 = case msetaf of
110 Just setaf -> (False, False, setaf)
111 Nothing -> case msetf of
112 Just setf -> (False, True, setf)
113 Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
114 msetab <- probeCap ti "setab"
115 msetb <- probeCap ti "setb"
116 let set_back_cap
117 = case msetab of
118 Nothing -> case msetb of
119 Just setb -> setb
120 Nothing -> error $ "no back color support for terminal " ++ termName
121 Just setab -> setab
122 terminfoCaps <- pure TerminfoCaps
123 <*> probeCap ti "smcup"
124 <*> probeCap ti "rmcup"
125 <*> requireCap ti "cup"
126 <*> probeCap ti "cnorm"
127 <*> probeCap ti "civis"
128 <*> pure noColors
129 <*> pure useAlt
130 <*> pure setForeCap
131 <*> pure set_back_cap
132 <*> requireCap ti "sgr0"
133 <*> requireCap ti "clear"
134 <*> requireCap ti "el"
135 <*> currentDisplayAttrCaps ti
136 <*> probeCap ti "bel"
137 newAssumedStateRef <- newIORef initialAssumedState
138 let t = Output
139 { terminalID = termName
140 , releaseTerminal = liftIO $ do
141 sendCap setDefaultAttr []
142 maybeSendCap cnorm []
143 , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
144 , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio []
145 , reserveDisplay = liftIO $ do
146 -- If there is no support for smcup: Clear the screen
147 -- and then move the mouse to the home position to
148 -- approximate the behavior.
149 maybeSendCap smcup []
150 sendCap clearScreen []
151 , releaseDisplay = liftIO $ do
152 maybeSendCap rmcup []
153 maybeSendCap cnorm []
154 , displayBounds = do
155 rawSize <- liftIO $ getWindowSize outFd
156 case rawSize of
157 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
158 | otherwise -> return (w,h)
159 , outputByteBuffer = \outBytes -> do
160 let (fptr, offset, len) = toForeignPtr outBytes
161 actualLen <- withForeignPtr fptr
162 $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0
163 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
164 ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
165 ++ " Please report this bug to vty project."
166 , contextColorCount
167 = case supportsNoColors terminfoCaps of
168 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
169 Nothing -> 8
170 Just v -> toEnum v
171 True -> 1
172 , supportsCursorVisibility = isJust $ civis terminfoCaps
173 , supportsMode = const False
174 , setMode = const $ const $ return ()
175 , getModeStatus = const $ return False
176 , assumedStateRef = newAssumedStateRef
177 -- I think fix would help assure tActual is the only
178 -- reference. I was having issues 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
245-- state of each style directly ; and, for no good reason, resets the
246-- colors to the default) this procedure is used:
247--
248-- 0. set the style attributes. This resets the fore and back color.
249--
250-- 1, If a foreground color is to be set then set the foreground color
251--
252-- 2. likewise with the background color
253--
254-- If the terminal does not support the sgr cap then: if there is a
255-- change from an applied color to the default (in either the fore or
256-- back color) then:
257--
258-- 0. reset all display attributes (sgr0)
259--
260-- 1. enter required style modes
261--
262-- 2. set the fore color if required
263--
264-- 3. set the back color if required
265--
266-- Entering the required style modes could require a reset of the
267-- display attributes. If this is the case then the back and fore colors
268-- always need to be set if not default.
269--
270-- This equation implements the above logic.
271--
272-- Note that this assumes the removal of color changes in the
273-- display attributes is done as expected with noColors == True. See
274-- `limitAttrForDisplay`.
275--
276-- Note that this optimizes for fewer state changes followed by fewer
277-- bytes.
278terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
279terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
280 case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
281 -- The only way to reset either color, portably, to the default
282 -- is to use either the set state capability or the set default
283 -- capability.
284 True -> do
285 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
286 (fixedStyle attr )
287 (styleToApplySeq $ fixedStyle attr) of
288 -- only way to reset a color to the defaults
289 EnterExitSeq caps -> writeDefaultAttr dc
290 `mappend`
291 foldMap (\cap -> writeCapExpr cap []) caps
292 `mappend`
293 setColors
294 -- implicitly resets the colors to the defaults
295 SetState state -> writeCapExpr (fromJust $ setAttrStates
296 $ displayAttrCaps
297 $ terminfoCaps
298 )
299 (sgrArgsForState state)
300 `mappend`
301 setColors
302 -- Otherwise the display colors are not changing or changing
303 -- between two non-default points.
304 False -> do
305 -- Still, it could be the case that the change in display
306 -- attributes requires the colors to be reset because the
307 -- required capability was not available.
308 case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
309 (fixedStyle attr)
310 (styleDiffs diffs) of
311 -- Really, if terminals were re-implemented with modern
312 -- concepts instead of bowing down to 40 yr old dumb
313 -- terminal requirements this would be the only case
314 -- ever reached! Changes the style and color states
315 -- according to the differences with the currently
316 -- 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
351-- 240 color set that might not be supported by the terminal.
352--
353-- This takes a Color which clearly identifies which pallete to use and
354-- computes the index 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
376 - according to these rules.
377 -
378 - 1. The assumption is that it's preferable to use the simpler
379 - enter/exit mode capabilities than the full set display attribute
380 - state capability.
381 -
382 - 2. If a mode is supposed to be removed but there is not an exit
383 - capability defined then the display attributes are reset to defaults
384 - then the display attribute state is set.
385 -
386 - 3. If a mode is supposed to be applied but there is not an enter
387 - capability defined then then display attribute state is set if
388 - possible. Otherwise the mode is not applied.
389 -
390 - 4. If the display attribute state is being set then just update the
391 - arguments to that for any apply/remove.
392 -}
393data DisplayAttrSeq
394 = EnterExitSeq [CapExpression]
395 | SetState DisplayAttrState
397data DisplayAttrState = DisplayAttrState
398 { applyStandout :: Bool
399 , applyUnderline :: Bool
400 , applyReverseVideo :: Bool
401 , applyBlink :: Bool
402 , applyDim :: Bool
403 , applyBold :: Bool
404 }
406sgrArgsForState :: DisplayAttrState -> [CapParam]
407sgrArgsForState attrState = map (\b -> if b then 1 else 0)
408 [ applyStandout attrState
409 , applyUnderline attrState
410 , applyReverseVideo attrState
411 , applyBlink attrState
412 , applyDim attrState
413 , applyBold attrState
414 , False -- invis
415 , False -- protect
416 , False -- alt char set
417 ]
419reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
420reqDisplayCapSeqFor caps s diffs
421 -- if the state transition implied by any diff cannot be supported
422 -- with an enter/exit mode cap then either the state needs to be set
423 -- or the attribute change ignored.
424 = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
425 -- If all the diffs have an enter-exit cap then just use those
426 ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
427 -- If not all the diffs have an enter-exit cap and there is no
428 -- set state cap then filter out all unsupported diffs and just
429 -- apply the rest
430 ( True, False ) -> EnterExitSeq $ map enterExitCap
431 $ filter (not . noEnterExitCap) diffs
432 -- if not all the diffs have an enter-exit can and there is a
433 -- set state cap then just use the set state cap.
434 ( True, True ) -> SetState $ stateForStyle s
435 where
436 noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
437 noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
438 noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
439 noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
440 noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
441 noEnterExitCap RemoveReverseVideo = True
442 noEnterExitCap ApplyBlink = True
443 noEnterExitCap RemoveBlink = True
444 noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
445 noEnterExitCap RemoveDim = True
446 noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
447 noEnterExitCap RemoveBold = True
448 enterExitCap ApplyStandout = fromJust $ enterStandout caps
449 enterExitCap RemoveStandout = fromJust $ exitStandout caps
450 enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
451 enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
452 enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
453 enterExitCap ApplyDim = fromJust $ enterDimMode caps
454 enterExitCap ApplyBold = fromJust $ enterBoldMode caps
455 enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
457stateForStyle :: Style -> DisplayAttrState
458stateForStyle s = DisplayAttrState
459 { applyStandout = isStyleSet standout
460 , applyUnderline = isStyleSet underline
461 , applyReverseVideo = isStyleSet reverseVideo
462 , applyBlink = isStyleSet blink
463 , applyDim = isStyleSet dim
464 , applyBold = isStyleSet bold
465 }
466 where isStyleSet = hasStyle s
468styleToApplySeq :: Style -> [StyleStateChange]
469styleToApplySeq s = concat
470 [ applyIfRequired ApplyStandout standout
471 , applyIfRequired ApplyUnderline underline
472 , applyIfRequired ApplyReverseVideo reverseVideo
473 , applyIfRequired ApplyBlink blink
474 , applyIfRequired ApplyDim dim
475 , applyIfRequired ApplyBlink bold
476 ]
477 where
478 applyIfRequired op flag
479 = if 0 == (flag .&. s)
480 then []
481 else [op]