git.iko.soy/vty
on d8007cb help sign in
vty/src/Graphics/Vty/Output/TerminfoBased.hs
435 lines 20 kB history raw
1-- | Terminfo based terminal handling.
2--
3-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
4-- have easy access to then color support is entirely based of the docs. Probably with some
5-- assumptions mixed in.
6--
7-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
8{-# LANGUAGE FlexibleInstances #-}
9{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
10{-# CFILES gwinsz.c #-}
11module Graphics.Vty.Output.TerminfoBased ( reserve_terminal )
12 where
14import Graphics.Vty.Prelude
16import qualified Data.ByteString as BS
17import Data.Terminfo.Parse
18import Data.Terminfo.Eval
20import Graphics.Vty.Attributes
21import Graphics.Vty.DisplayAttributes
22import Graphics.Vty.Output.Interface
24import Blaze.ByteString.Builder (Write, writeToByteString)
26import Control.Monad.Trans
28import Data.Bits ((.&.))
29import Data.Foldable (foldMap)
30import Data.IORef
31import Data.Maybe (isJust, isNothing, fromJust)
32import Data.Monoid
34import Foreign.C.Types ( CLong(..) )
36import GHC.IO.Handle
38import qualified System.Console.Terminfo as Terminfo
40data TerminfoCaps = TerminfoCaps
41 { smcup :: Maybe CapExpression
42 , rmcup :: Maybe CapExpression
43 , cup :: CapExpression
44 , cnorm :: Maybe CapExpression
45 , civis :: Maybe CapExpression
46 , supports_no_colors :: Bool
47 , use_alt_color_map :: Bool
48 , set_fore_color :: CapExpression
49 , set_back_color :: CapExpression
50 , set_default_attr :: CapExpression
51 , clear_screen :: CapExpression
52 , clear_eol :: CapExpression
53 , display_attr_caps :: DisplayAttrCaps
54 }
56data DisplayAttrCaps = DisplayAttrCaps
57 { set_attr_states :: Maybe CapExpression
58 , enter_standout :: Maybe CapExpression
59 , exit_standout :: Maybe CapExpression
60 , enter_underline :: Maybe CapExpression
61 , exit_underline :: Maybe CapExpression
62 , enter_reverse_video :: Maybe CapExpression
63 , enter_dim_mode :: Maybe CapExpression
64 , enter_bold_mode :: Maybe CapExpression
65 }
67send_cap_to_terminal :: Output -> CapExpression -> [CapParam] -> IO ()
68send_cap_to_terminal t cap cap_params = do
69 output_byte_buffer t $ writeToByteString $ write_cap_expr cap cap_params
71{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
72 - terminfo does not support some features that would increase efficiency and improve compatibility:
73 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
74 - environment variable?
75 - * Provide independent string capabilities for all display attributes.
76 -
77 -
78 - todo: Some display attributes like underline and bold have independent string capabilities that
79 - should be used instead of the generic "sgr" string capability.
80 -}
81reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output
82reserve_terminal in_ID out_handle = liftIO $ do
83 ti <- Terminfo.setupTerm in_ID
84 -- assumes set foreground always implies set background exists.
85 -- if set foreground is not set then all color changing style attributes are filtered.
86 msetaf <- probe_cap ti "setaf"
87 msetf <- probe_cap ti "setf"
88 let (no_colors, use_alt, set_fore_cap)
89 = case msetaf of
90 Just setaf -> (False, False, setaf)
91 Nothing -> case msetf of
92 Just setf -> (False, True, setf)
93 Nothing -> (True, True, error $ "no fore color support for terminal " ++ in_ID)
94 msetab <- probe_cap ti "setab"
95 msetb <- probe_cap ti "setb"
96 let set_back_cap
97 = case msetab of
98 Nothing -> case msetb of
99 Just setb -> setb
100 Nothing -> error $ "no back color support for terminal " ++ in_ID
101 Just setab -> setab
102 terminfo_caps <- pure TerminfoCaps
103 <*> probe_cap ti "smcup"
104 <*> probe_cap ti "rmcup"
105 <*> require_cap ti "cup"
106 <*> probe_cap ti "cnorm"
107 <*> probe_cap ti "civis"
108 <*> pure no_colors
109 <*> pure use_alt
110 <*> pure set_fore_cap
111 <*> pure set_back_cap
112 <*> require_cap ti "sgr0"
113 <*> require_cap ti "clear"
114 <*> require_cap ti "el"
115 <*> current_display_attr_caps ti
116 new_assumed_state_ref <- newIORef initial_assumed_state
117 let t = Output
118 { terminal_ID = in_ID
119 , release_terminal = liftIO $ do
120 send_cap set_default_attr []
121 maybe_send_cap cnorm []
122 hClose out_handle
123 , reserve_display = liftIO $ do
124 -- If there is no support for smcup: Clear the screen and then move the mouse to the
125 -- home position to approximate the behavior.
126 maybe_send_cap smcup []
127 hFlush out_handle
128 send_cap clear_screen []
129 , release_display = liftIO $ do
130 maybe_send_cap rmcup []
131 maybe_send_cap cnorm []
132 , display_bounds = do
133 raw_size <- liftIO $ get_window_size
134 case raw_size of
135 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
136 | otherwise -> return (w,h)
137 , output_byte_buffer = \out_bytes -> do
138 BS.hPut out_handle out_bytes
139 hFlush out_handle
140 , context_color_count
141 = case supports_no_colors terminfo_caps of
142 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
143 Nothing -> 8
144 Just v -> toEnum v
145 True -> 1
146 , supports_cursor_visibility = isJust $ civis terminfo_caps
147 , assumed_state_ref = new_assumed_state_ref
148 -- I think fix would help assure t_actual is the only reference. I was having issues
149 -- tho.
150 , mk_display_context = \t_actual -> liftIO . terminfo_display_context t_actual terminfo_caps
151 }
152 send_cap s = send_cap_to_terminal t (s terminfo_caps)
153 maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)
154 return t
156require_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
157require_cap ti cap_name
158 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
159 Nothing -> fail $ "Terminal does not define required capability \"" ++ cap_name ++ "\""
160 Just cap_str -> parse_cap cap_str
162probe_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
163probe_cap ti cap_name
164 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
165 Nothing -> return Nothing
166 Just cap_str -> Just <$> parse_cap cap_str
168parse_cap :: (Applicative m, MonadIO m) => String -> m CapExpression
169parse_cap cap_str = do
170 case parse_cap_expression cap_str of
171 Left e -> fail $ show e
172 Right cap -> return cap
174current_display_attr_caps :: ( Applicative m, MonadIO m )
175 => Terminfo.Terminal
176 -> m DisplayAttrCaps
177current_display_attr_caps ti
178 = pure DisplayAttrCaps
179 <*> probe_cap ti "sgr"
180 <*> probe_cap ti "smso"
181 <*> probe_cap ti "rmso"
182 <*> probe_cap ti "smul"
183 <*> probe_cap ti "rmul"
184 <*> probe_cap ti "rev"
185 <*> probe_cap ti "dim"
186 <*> probe_cap ti "bold"
188foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: IO CLong
190get_window_size :: IO (Int,Int)
191get_window_size = do
192 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
193 return (fromIntegral b, fromIntegral a)
195terminfo_display_context :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
196terminfo_display_context t_actual terminfo_caps r = return dc
197 where dc = DisplayContext
198 { context_device = t_actual
199 , context_region = r
200 , write_move_cursor = \x y -> write_cap_expr (cup terminfo_caps) [toEnum y, toEnum x]
201 , write_show_cursor = case cnorm terminfo_caps of
202 Nothing -> error "this terminal does not support show cursor"
203 Just c -> write_cap_expr c []
204 , write_hide_cursor = case civis terminfo_caps of
205 Nothing -> error "this terminal does not support hide cursor"
206 Just c -> write_cap_expr c []
207 , write_set_attr = terminfo_write_set_attr dc terminfo_caps
208 , write_default_attr = write_cap_expr (set_default_attr terminfo_caps) []
209 , write_row_end = write_cap_expr (clear_eol terminfo_caps) []
210 , inline_hack = return ()
211 }
213-- | Portably setting the display attributes is a giant pain in the ass.
214--
215-- If the terminal supports the sgr capability (which sets the on/off state of each style
216-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
217--
218-- 0. set the style attributes. This resets the fore and back color.
219-- 1, If a foreground color is to be set then set the foreground color
220-- 2. likewise with the background color
221--
222-- If the terminal does not support the sgr cap then:
223-- if there is a change from an applied color to the default (in either the fore or back color)
224-- then:
225-- 0. reset all display attributes (sgr0)
226-- 1. enter required style modes
227-- 2. set the fore color if required
228-- 3. set the back color if required
229--
230-- Entering the required style modes could require a reset of the display attributes. If this is
231-- the case then the back and fore colors always need to be set if not default.
232--
233-- This equation implements the above logic.
234--
235-- \todo This assumes the removal of color changes in the display attributes is done as expected
236-- with no_colors == True. See `limit_attr_for_display`
237--
238-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
239-- haven't measured this or even examined terminal implementations. *shrug*
240terminfo_write_set_attr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
241terminfo_write_set_attr dc terminfo_caps prev_attr req_attr diffs = do
242 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
243 -- The only way to reset either color, portably, to the default is to use either the set
244 -- state capability or the set default capability.
245 True -> do
246 case req_display_cap_seq_for (display_attr_caps terminfo_caps)
247 (fixed_style attr )
248 (style_to_apply_seq $ fixed_style attr) of
249 -- only way to reset a color to the defaults
250 EnterExitSeq caps -> write_default_attr dc
251 `mappend`
252 foldMap (\cap -> write_cap_expr cap []) caps
253 `mappend`
254 set_colors
255 -- implicitly resets the colors to the defaults
256 SetState state -> write_cap_expr (fromJust $ set_attr_states
257 $ display_attr_caps
258 $ terminfo_caps
259 )
260 (sgr_args_for_state state)
261 `mappend`
262 set_colors
263 -- Otherwise the display colors are not changing or changing between two non-default
264 -- points.
265 False -> do
266 -- Still, it could be the case that the change in display attributes requires the
267 -- colors to be reset because the required capability was not available.
268 case req_display_cap_seq_for (display_attr_caps terminfo_caps)
269 (fixed_style attr)
270 (style_diffs diffs) of
271 -- Really, if terminals were re-implemented with modern concepts instead of bowing
272 -- down to 40 yr old dumb terminal requirements this would be the only case ever
273 -- reached! Changes the style and color states according to the differences with
274 -- the currently applied states.
275 EnterExitSeq caps -> foldMap (\cap -> write_cap_expr cap []) caps
276 `mappend`
277 write_color_diff set_fore_color (fore_color_diff diffs)
278 `mappend`
279 write_color_diff set_back_color (back_color_diff diffs)
280 -- implicitly resets the colors to the defaults
281 SetState state -> write_cap_expr (fromJust $ set_attr_states
282 $ display_attr_caps terminfo_caps
283 )
284 (sgr_args_for_state state)
285 `mappend` set_colors
286 where
287 color_map = case use_alt_color_map terminfo_caps of
288 False -> ansi_color_index
289 True -> alt_color_index
290 attr = fix_display_attr prev_attr req_attr
291 set_colors =
292 (case fixed_fore_color attr of
293 Just c -> write_cap_expr (set_fore_color terminfo_caps)
294 [toEnum $ color_map c]
295 Nothing -> mempty)
296 `mappend`
297 (case fixed_back_color attr of
298 Just c -> write_cap_expr (set_back_color terminfo_caps)
299 [toEnum $ color_map c]
300 Nothing -> mempty)
301 write_color_diff _f NoColorChange
302 = mempty
303 write_color_diff _f ColorToDefault
304 = error "ColorToDefault is not a possible case for apply_color_diffs"
305 write_color_diff f (SetColor c)
306 = write_cap_expr (f terminfo_caps) [toEnum $ color_map c]
308-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
309-- be supported by the terminal.
310--
311-- This takes a Color which clearly identifies which pallete to use and computes the index
312-- into the full 256 color pallete.
313ansi_color_index :: Color -> Int
314ansi_color_index (ISOColor v) = fromEnum v
315ansi_color_index (Color240 v) = 16 + fromEnum v
317-- | For terminals without setaf/setab
318--
319-- See table in `man terminfo`
320-- Will error if not in table.
321alt_color_index :: Color -> Int
322alt_color_index (ISOColor 0) = 0
323alt_color_index (ISOColor 1) = 4
324alt_color_index (ISOColor 2) = 2
325alt_color_index (ISOColor 3) = 6
326alt_color_index (ISOColor 4) = 1
327alt_color_index (ISOColor 5) = 5
328alt_color_index (ISOColor 6) = 3
329alt_color_index (ISOColor 7) = 7
330alt_color_index (ISOColor v) = fromEnum v
331alt_color_index (Color240 v) = 16 + fromEnum v
333{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
334 -
335 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
336 - the full set display attribute state capability.
337 -
338 - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
339 - display attributes are reset to defaults then the display attribute state is set.
340 -
341 - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
342 - display attribute state is set if possible. Otherwise the mode is not applied.
343 -
344 - 4. If the display attribute state is being set then just update the arguments to that for any
345 - apply/remove.
346 -
347 -}
348data DisplayAttrSeq
349 = EnterExitSeq [CapExpression]
350 | SetState DisplayAttrState
352data DisplayAttrState = DisplayAttrState
353 { apply_standout :: Bool
354 , apply_underline :: Bool
355 , apply_reverse_video :: Bool
356 , apply_blink :: Bool
357 , apply_dim :: Bool
358 , apply_bold :: Bool
359 }
361sgr_args_for_state :: DisplayAttrState -> [CapParam]
362sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
363 [ apply_standout attr_state
364 , apply_underline attr_state
365 , apply_reverse_video attr_state
366 , apply_blink attr_state
367 , apply_dim attr_state
368 , apply_bold attr_state
369 , False -- invis
370 , False -- protect
371 , False -- alt char set
372 ]
374req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
375req_display_cap_seq_for caps s diffs
376 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
377 -- then either the state needs to be set or the attribute change ignored.
378 = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
379 -- If all the diffs have an enter-exit cap then just use those
380 ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs
381 -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
382 -- all unsupported diffs and just apply the rest
383 ( True, False ) -> EnterExitSeq $ map enter_exit_cap
384 $ filter (not . no_enter_exit_cap) diffs
385 -- if not all the diffs have an enter-exit can and there is a set state cap then just use
386 -- the set state cap.
387 ( True, True ) -> SetState $ state_for_style s
388 where
389 no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
390 no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
391 no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
392 no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
393 no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
394 no_enter_exit_cap RemoveReverseVideo = True
395 no_enter_exit_cap ApplyBlink = True
396 no_enter_exit_cap RemoveBlink = True
397 no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
398 no_enter_exit_cap RemoveDim = True
399 no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
400 no_enter_exit_cap RemoveBold = True
401 enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
402 enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
403 enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
404 enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
405 enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
406 enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
407 enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
408 enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
410state_for_style :: Style -> DisplayAttrState
411state_for_style s = DisplayAttrState
412 { apply_standout = is_style_set standout
413 , apply_underline = is_style_set underline
414 , apply_reverse_video = is_style_set reverse_video
415 , apply_blink = is_style_set blink
416 , apply_dim = is_style_set dim
417 , apply_bold = is_style_set bold
418 }
419 where is_style_set = has_style s
421style_to_apply_seq :: Style -> [StyleStateChange]
422style_to_apply_seq s = concat
423 [ apply_if_required ApplyStandout standout
424 , apply_if_required ApplyUnderline underline
425 , apply_if_required ApplyReverseVideo reverse_video
426 , apply_if_required ApplyBlink blink
427 , apply_if_required ApplyDim dim
428 , apply_if_required ApplyBlink bold
429 ]
430 where
431 apply_if_required op flag
432 = if 0 == (flag .&. s)
433 then []
434 else [op]