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