1-- | Terminfo based terminal handling.
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.
7-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
8{-# LANGUAGE ForeignFunctionInterface #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE FlexibleInstances #-}
11{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
12module Graphics.Vty.Terminal.TerminfoBased ( reserve_terminal )
15import Data.Terminfo.Parse
16import Data.Terminfo.Eval
18import Graphics.Vty.Attributes
19import Graphics.Vty.DisplayAttributes
20import Graphics.Vty.Terminal.Interface
21import Graphics.Vty.DisplayRegion
23import Control.Applicative
24import Control.Monad ( foldM, when )
25import Control.Monad.Trans
27import Data.Bits ( (.&.) )
29import Data.Maybe ( isJust, isNothing, fromJust )
31import Foreign.C.Types ( CLong(..) )
35import qualified System.Console.Terminfo as Terminfo
37data TerminfoCaps = TerminfoCaps
38 { smcup :: Maybe CapExpression
39 , rmcup :: Maybe CapExpression
40 , cup :: CapExpression
41 , cnorm :: Maybe CapExpression
42 , civis :: Maybe CapExpression
43 , supports_no_colors :: Bool
44 , use_alt_color_map :: Bool
45 , set_fore_color :: CapExpression
46 , set_back_color :: CapExpression
47 , set_default_attr :: CapExpression
48 , clear_screen :: CapExpression
49 , clear_eol :: CapExpression
50 , display_attr_caps :: DisplayAttrCaps
53data DisplayAttrCaps = DisplayAttrCaps
54 { set_attr_states :: Maybe CapExpression
55 , enter_standout :: Maybe CapExpression
56 , exit_standout :: Maybe CapExpression
57 , enter_underline :: Maybe CapExpression
58 , exit_underline :: Maybe CapExpression
59 , enter_reverse_video :: Maybe CapExpression
60 , enter_dim_mode :: Maybe CapExpression
61 , enter_bold_mode :: Maybe CapExpression
64send_cap_to_terminal :: Terminal -> CapExpression -> [CapParam] -> IO ()
65send_cap_to_terminal t cap cap_params = do
66 send_to_terminal t (cap_expression_required_bytes cap cap_params)
67 (serialize_cap_expression cap cap_params)
69{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
70 - terminfo does not support some features that would increase efficiency and improve compatibility:
71 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
72 - environment variable?
73 - * Provide independent string capabilities for all display attributes.
76 - todo: Some display attributes like underline and bold have independent string capabilities that
77 - should be used instead of the generic "sgr" string capability.
79reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Terminal
80reserve_terminal in_ID out_handle = liftIO $ do
81 ti <- Terminfo.setupTerm in_ID
82 -- assumes set foreground always implies set background exists.
83 -- if set foreground is not set then all color changing style attributes are filtered.
84 msetaf <- probe_cap ti "setaf"
85 msetf <- probe_cap ti "setf"
86 let (no_colors, use_alt, set_fore_cap)
88 Just setaf -> (False, False, setaf)
89 Nothing -> case msetf of
90 Just setf -> (False, True, setf)
91 Nothing -> (True, True, error $ "no fore color support for terminal " ++ in_ID)
92 msetab <- probe_cap ti "setab"
93 msetb <- probe_cap ti "setb"
96 Nothing -> case msetb of
98 Nothing -> error $ "no back color support for terminal " ++ in_ID
100 terminfo_caps <- pure TerminfoCaps
101 <*> probe_cap ti "smcup"
102 <*> probe_cap ti "rmcup"
103 <*> require_cap ti "cup"
104 <*> probe_cap ti "cnorm"
105 <*> probe_cap ti "civis"
108 <*> pure set_fore_cap
109 <*> pure set_back_cap
110 <*> require_cap ti "sgr0"
111 <*> require_cap ti "clear"
112 <*> require_cap ti "el"
113 <*> current_display_attr_caps ti
114 new_assumed_state_ref <- newIORef initial_assumed_state
116 { terminal_ID = in_ID
117 , release_terminal = liftIO $ do
118 send_cap set_default_attr []
119 maybe_send_cap cnorm []
121 , reserve_display = liftIO $ do
122 -- If there is no support for smcup: Clear the screen and then move the mouse to the
123 -- home position to approximate the behavior.
124 maybe_send_cap smcup []
126 send_cap clear_screen []
127 , release_display = liftIO $ do
128 maybe_send_cap rmcup []
129 maybe_send_cap cnorm []
130 , display_bounds = do
131 raw_size <- liftIO $ get_window_size
133 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
134 | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)
135 , output_byte_buffer = \out_ptr out_byte_count -> do
136 hPutBuf out_handle out_ptr (fromEnum out_byte_count)
138 , context_color_count
139 = case supports_no_colors terminfo_caps of
140 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
144 , supports_cursor_visibility = isJust $ civis terminfo_caps
145 , assumed_state_ref = new_assumed_state_ref
146 -- I think fix would help assure t_actual is the only reference. I was having issues
148 , mk_display_context = \t_actual -> liftIO . terminfo_display_context t_actual terminfo_caps
150 send_cap s = send_cap_to_terminal t (s terminfo_caps)
151 maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)
154require_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
155require_cap ti cap_name
156 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
157 Nothing -> fail $ "Terminal does not define required capability \"" ++ cap_name ++ "\""
158 Just cap_str -> parse_cap cap_str
160probe_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
162 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
163 Nothing -> return Nothing
164 Just cap_str -> Just <$> parse_cap cap_str
166parse_cap :: (Applicative m, MonadIO m) => String -> m CapExpression
167parse_cap cap_str = do
168 parse_result <- parse_cap_expression cap_str
170 Left e -> fail $ show e
171 Right cap -> return cap
173current_display_attr_caps :: ( Applicative m, MonadIO m )
176current_display_attr_caps ti
177 = pure DisplayAttrCaps
178 <*> probe_cap ti "sgr"
179 <*> probe_cap ti "smso"
180 <*> probe_cap ti "rmso"
181 <*> probe_cap ti "smul"
182 <*> probe_cap ti "rmul"
183 <*> probe_cap ti "rev"
184 <*> probe_cap ti "dim"
185 <*> probe_cap ti "bold"
187foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: IO CLong
189get_window_size :: IO (Int,Int)
191 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
192 return (fromIntegral b, fromIntegral a)
194terminfo_display_context :: Terminal -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
195terminfo_display_context t_actual terminfo_caps r =
196 let dc = DisplayContext
197 { context_device = t_actual
199 , move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)
201 , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)
204 , show_cursor_required_bytes = case cnorm terminfo_caps of
205 Nothing -> error "this terminal does not support show cursor"
206 Just c -> cap_expression_required_bytes c []
207 , serialize_show_cursor = \out_ptr -> do
208 case cnorm terminfo_caps of
209 Nothing -> fail "this terminal does not support show cursor"
210 Just c -> serialize_cap_expression c [] out_ptr
211 , hide_cursor_required_bytes = case civis terminfo_caps of
212 Nothing -> error "this terminal does not support hide cursor"
213 Just c -> cap_expression_required_bytes c []
214 , serialize_hide_cursor = \out_ptr -> do
215 case civis terminfo_caps of
216 Nothing -> fail "this terminal does not support hide cursor"
217 Just c -> serialize_cap_expression c [] out_ptr
218 , attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes
219 , serialize_set_attr = terminfo_serialize_set_attr dc terminfo_caps
220 , default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []
221 , serialize_default_attr = serialize_cap_expression (set_default_attr terminfo_caps) []
222 , row_end_required_bytes = cap_expression_required_bytes (clear_eol terminfo_caps) []
223 , serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []
224 , inline_hack = return ()
228-- | Instead of evaluating all the rules related to setting display attributes twice (once in
229-- required bytes and again in serialize) or some memoization scheme just return a size
230-- requirement as big the longest possible control string.
232-- Which is assumed to the be less than 512 for now.
234-- \todo Not verified as safe and wastes memory.
235assumed_attr_required_bytes :: Int
236assumed_attr_required_bytes = 512
238-- | Portably setting the display attributes is a giant pain in the ass.
240-- If the terminal supports the sgr capability (which sets the on/off state of each style
241-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
243-- 0. set the style attributes. This resets the fore and back color.
244-- 1, If a foreground color is to be set then set the foreground color
245-- 2. likewise with the background color
247-- If the terminal does not support the sgr cap then:
248-- if there is a change from an applied color to the default (in either the fore or back color)
250-- 0. reset all display attributes (sgr0)
251-- 1. enter required style modes
252-- 2. set the fore color if required
253-- 3. set the back color if required
255-- Entering the required style modes could require a reset of the display attributes. If this is
256-- the case then the back and fore colors always need to be set if not default.
258-- This equation implements the above logic.
260-- \todo This assumes the removal of color changes in the display attributes is done as expected
261-- with no_colors == True. See `limit_attr_for_display`
263-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
264-- haven't measured this or even examined terminal implementations. *shrug*
265terminfo_serialize_set_attr :: DisplayContext
267 -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer
268terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr = do
269 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
270 -- The only way to reset either color, portably, to the default is to use either the set
271 -- state capability or the set default capability.
273 case req_display_cap_seq_for ( display_attr_caps terminfo_caps )
275 ( style_to_apply_seq $ fixed_style attr )
278 -- only way to reset a color to the defaults
279 -> serialize_default_attr dc out_ptr
280 >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)
283 -- implicitly resets the colors to the defaults
284 -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states
288 ( sgr_args_for_state state )
291 -- Otherwise the display colors are not changing or changing between two non-default
294 -- Still, it could be the case that the change in display attributes requires the
295 -- colors to be reset because the required capability was not available.
296 case req_display_cap_seq_for (display_attr_caps terminfo_caps)
300 -- Really, if terminals were re-implemented with modern concepts instead of
301 -- bowing down to 40 yr old dumb terminal requirements this would be the
302 -- only case ever reached!
303 -- Changes the style and color states according to the differences with the
304 -- currently applied states.
306 -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps
307 >>= apply_color_diff set_fore_color (fore_color_diff diffs)
308 >>= apply_color_diff set_back_color (back_color_diff diffs)
310 -- implicitly resets the colors to the defaults
311 -> serialize_cap_expression (fromJust $ set_attr_states
312 $ display_attr_caps terminfo_caps
314 (sgr_args_for_state state)
318 color_map = case use_alt_color_map terminfo_caps of
319 False -> ansi_color_index
320 True -> alt_color_index
321 attr = fix_display_attr prev_attr req_attr
323 ptr' <- case fixed_fore_color attr of
324 Just c -> serialize_cap_expression (set_fore_color terminfo_caps)
325 [ toEnum $ color_map c ]
327 Nothing -> return ptr
328 ptr'' <- case fixed_back_color attr of
329 Just c -> serialize_cap_expression (set_back_color terminfo_caps)
330 [ toEnum $ color_map c ]
332 Nothing -> return ptr'
334 apply_color_diff _f NoColorChange ptr
336 apply_color_diff _f ColorToDefault _ptr
337 = fail "ColorToDefault is not a possible case for apply_color_diffs"
338 apply_color_diff f ( SetColor c ) ptr
339 = serialize_cap_expression (f terminfo_caps)
340 [ toEnum $ color_map 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.
346-- This takes a Color which clearly identifies which pallete to use and computes the index
347-- into the full 256 color pallete.
348ansi_color_index :: Color -> Int
349ansi_color_index (ISOColor v) = fromEnum v
350ansi_color_index (Color240 v) = 16 + fromEnum v
352-- | For terminals without setaf/setab
354-- See table in `man terminfo`
355-- Will error if not in table.
356alt_color_index :: Color -> Int
357alt_color_index (ISOColor 0) = 0
358alt_color_index (ISOColor 1) = 4
359alt_color_index (ISOColor 2) = 2
360alt_color_index (ISOColor 3) = 6
361alt_color_index (ISOColor 4) = 1
362alt_color_index (ISOColor 5) = 5
363alt_color_index (ISOColor 6) = 3
364alt_color_index (ISOColor 7) = 7
365alt_color_index (ISOColor v) = fromEnum v
366alt_color_index (Color240 v) = 16 + fromEnum v
368{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
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.
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.
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.
379 - 4. If the display attribute state is being set then just update the arguments to that for any
384 = EnterExitSeq [CapExpression]
385 | SetState DisplayAttrState
387data DisplayAttrState = DisplayAttrState
388 { apply_standout :: Bool
389 , apply_underline :: Bool
390 , apply_reverse_video :: Bool
391 , apply_blink :: Bool
396sgr_args_for_state :: DisplayAttrState -> [CapParam]
397sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
398 [ apply_standout attr_state
399 , apply_underline attr_state
400 , apply_reverse_video attr_state
401 , apply_blink attr_state
402 , apply_dim attr_state
403 , apply_bold attr_state
406 , False -- alt char set
409req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
410req_display_cap_seq_for 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 no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
414 -- If all the diffs have an enter-exit cap then just use those
415 ( False, _ ) -> EnterExitSeq $ map enter_exit_cap 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 enter_exit_cap
419 $ filter (not . no_enter_exit_cap) 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 $ state_for_style s
424 no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
425 no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
426 no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
427 no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
428 no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
429 no_enter_exit_cap RemoveReverseVideo = True
430 no_enter_exit_cap ApplyBlink = True
431 no_enter_exit_cap RemoveBlink = True
432 no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
433 no_enter_exit_cap RemoveDim = True
434 no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
435 no_enter_exit_cap RemoveBold = True
436 enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
437 enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
438 enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
439 enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
440 enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
441 enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
442 enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
443 enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
445state_for_style :: Style -> DisplayAttrState
446state_for_style s = DisplayAttrState
447 { apply_standout = is_style_set standout
448 , apply_underline = is_style_set underline
449 , apply_reverse_video = is_style_set reverse_video
450 , apply_blink = is_style_set blink
451 , apply_dim = is_style_set dim
452 , apply_bold = is_style_set bold
454 where is_style_set = has_style s
456style_to_apply_seq :: Style -> [StyleStateChange]
457style_to_apply_seq s = concat
458 [ apply_if_required ApplyStandout standout
459 , apply_if_required ApplyUnderline underline
460 , apply_if_required ApplyReverseVideo reverse_video
461 , apply_if_required ApplyBlink blink
462 , apply_if_required ApplyDim dim
463 , apply_if_required ApplyBlink bold
466 apply_if_required ap flag
467 = if 0 == ( flag .&. s )
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list