git.iko.soy/vty
on b13ca4d help sign in
vty/src/Graphics/Vty/Terminal/TerminfoBased.hs
418 lines 19 kB history raw
1-- Copyright 2009 Corey O'Connor
2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE FlexibleInstances #-}
5module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance
6 )
7 where
9import Data.Terminfo.Parse
10import Data.Terminfo.Eval
12import Graphics.Vty.Attributes
13import Graphics.Vty.DisplayAttributes
14import Graphics.Vty.Terminal.Generic
15import Graphics.Vty.DisplayRegion
17import Control.Applicative
18import Control.Monad ( foldM )
19import Control.Monad.Trans
21import Data.Bits ( (.&.) )
22import Data.Maybe ( isJust, isNothing, fromJust )
23import Data.Word
25import Foreign.C.Types ( CLong )
27import qualified System.Console.Terminfo as Terminfo
28import System.IO
30data Term = Term
31 { term_info_ID :: String
32 , term_info :: Terminfo.Terminal
33 , smcup :: Maybe CapExpression
34 , rmcup :: Maybe CapExpression
35 , cup :: CapExpression
36 , cnorm :: CapExpression
37 , civis :: CapExpression
38 , set_fore_color :: CapExpression
39 , set_back_color :: CapExpression
40 , set_default_attr :: CapExpression
41 , clear_screen :: CapExpression
42 , display_attr_caps :: DisplayAttrCaps
43 }
45data DisplayAttrCaps = DisplayAttrCaps
46 { set_attr_states :: Maybe CapExpression
47 , enter_standout :: Maybe CapExpression
48 , exit_standout :: Maybe CapExpression
49 , enter_underline :: Maybe CapExpression
50 , exit_underline :: Maybe CapExpression
51 , enter_reverse_video :: Maybe CapExpression
52 , enter_dim_mode :: Maybe CapExpression
53 , enter_bold_mode :: Maybe CapExpression
54 }
56marshall_cap_to_terminal :: MonadIO m => Term -> (Term -> CapExpression) -> [CapParam] -> m ()
57marshall_cap_to_terminal t cap_selector cap_params = do
58 marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )
59 ( serialize_cap_expression (cap_selector t) cap_params )
60 return ()
62{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
63 - terminfo does not support some features that would increase efficiency and improve compatibility:
64 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
65 - environment variable?
66 - * Provide independent string capabilities for all display attributes.
67 -
68 -
69 - todo: Some display attributes like underline and bold have independent string capabilities that
70 - should be used instead of the generic "sgr" string capability.
71 -}
72terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term
73terminal_instance in_ID = do
74 ti <- liftIO $ Terminfo.setupTerm in_ID
75 let require_cap str
76 = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of
77 Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""
78 Just cap_str -> do
79 parse_result <- parse_cap_expression cap_str
80 case parse_result of
81 Left e -> fail $ show e
82 Right cap -> return cap
83 probe_cap cap_name
84 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
85 Nothing -> return Nothing
86 Just cap_str -> do
87 parse_result <- parse_cap_expression cap_str
88 case parse_result of
89 Left e -> fail $ show e
90 Right cap -> return $ Just cap
91 pure Term
92 <*> pure in_ID
93 <*> pure ti
94 <*> probe_cap "smcup"
95 <*> probe_cap "rmcup"
96 <*> require_cap "cup"
97 <*> require_cap "cnorm"
98 <*> require_cap "civis"
99 <*> require_cap "setaf"
100 <*> require_cap "setab"
101 <*> require_cap "sgr0"
102 <*> require_cap "clear"
103 <*> current_display_attr_caps ti
105current_display_attr_caps :: ( Applicative m, MonadIO m )
106 => Terminfo.Terminal
107 -> m DisplayAttrCaps
108current_display_attr_caps ti
109 = pure DisplayAttrCaps
110 <*> probe_cap "sgr"
111 <*> probe_cap "smso"
112 <*> probe_cap "rmso"
113 <*> probe_cap "smul"
114 <*> probe_cap "rmul"
115 <*> probe_cap "rev"
116 <*> probe_cap "dim"
117 <*> probe_cap "bold"
118 where probe_cap cap_name
119 = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
120 Nothing -> return Nothing
121 Just cap_str -> do
122 parse_result <- parse_cap_expression cap_str
123 case parse_result of
124 Left e -> fail $ show e
125 Right cap -> return $ Just cap
127instance Terminal Term where
128 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
130 release_terminal t = do
131 marshall_cap_to_terminal t set_default_attr []
132 marshall_cap_to_terminal t cnorm []
133 return ()
135 reserve_display t = do
136 if (isJust $ smcup t)
137 then marshall_cap_to_terminal t (fromJust . smcup) []
138 else return ()
139 -- Screen on OS X does not appear to support smcup?
140 -- To approximate the expected behavior: clear the screen and then move the mouse to the
141 -- home position.
142 marshall_cap_to_terminal t clear_screen []
143 return ()
145 release_display t = do
146 if (isJust $ rmcup t)
147 then marshall_cap_to_terminal t (fromJust . rmcup) []
148 else return ()
149 marshall_cap_to_terminal t cnorm []
150 return ()
152 display_terminal_instance t b c = do
153 let color_count
154 = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of
155 Nothing -> 8
156 Just v -> toEnum v
157 return $ c (DisplayContext b t color_count)
159 display_bounds _t = do
160 raw_size <- liftIO $ get_window_size
161 case raw_size of
162 ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
163 | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)
165 -- Output the byte buffer of the specified size to the terminal device.
166 output_byte_buffer _t out_ptr out_byte_count = do
167 if out_byte_count == 0
168 then return ()
169 else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)
170 liftIO $ hFlush stdout
172foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
174get_window_size :: IO (Int,Int)
175get_window_size = do
176 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
177 return (fromIntegral b, fromIntegral a)
179data DisplayContext = DisplayContext
180 { bounds :: DisplayRegion
181 , term :: Term
182 , supported_colors :: Word
183 }
185instance DisplayTerminal DisplayContext where
186 context_region d = bounds d
188 context_color_count d = supported_colors d
190 move_cursor_required_bytes d x y
191 = cap_expression_required_bytes (cup $ term d) [y, x]
192 serialize_move_cursor d x y out_ptr
193 = serialize_cap_expression (cup $ term d) [y, x] out_ptr
195 show_cursor_required_bytes d
196 = cap_expression_required_bytes (cnorm $ term d) []
197 serialize_show_cursor d out_ptr
198 = serialize_cap_expression (cnorm $ term d) [] out_ptr
200 hide_cursor_required_bytes d
201 = cap_expression_required_bytes (civis $ term d) []
202 serialize_hide_cursor d out_ptr
203 = serialize_cap_expression (civis $ term d) [] out_ptr
205 -- Instead of evaluating all the rules related to setting display attributes twice (once in
206 -- required bytes and again in serialize) or some memoization scheme just return a size
207 -- requirement as big the longest possible control string.
208 --
209 -- Which is assumed to the be less than 512 for now.
210 --
211 -- \todo Not verified as safe and wastes memory.
212 attr_required_bytes _d _prev_attr _req_attr _diffs = 512
214 -- Portably setting the display attributes is a giant pain in the ass.
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 always works:
217 -- 0. set the style attributes. This resets the fore and back color.
218 -- 1, If a foreground color is to be set then set the foreground color
219 -- 2. likewise with the background color
220 --
221 -- If the terminal does not support the sgr then
222 -- if there is a change from an applied color to the default (in either the fore or back color)
223 -- then:
224 -- 0. reset all display attributes (sgr0)
225 -- 1. enter required style modes
226 -- 2. set the fore color if required
227 -- 3. set the back color if required
228 --
229 -- Entering the required style modes could require a reset of the display attributes. If this is
230 -- the case then the back and fore colors always need to be set if not default.
231 --
232 -- All this (I think) is satisfied by the following logic:
233 serialize_set_attr d prev_attr req_attr diffs out_ptr = do
234 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
235 -- The only way to reset either color, portably, to the default is to use either the set
236 -- state capability or the set default capability.
237 True -> do
238 case req_display_cap_seq_for ( display_attr_caps $ term d )
239 ( fixed_style attr )
240 ( style_to_apply_seq $ fixed_style attr )
241 of
242 EnterExitSeq caps
243 -- only way to reset a color to the defaults
244 -> serialize_default_attr d out_ptr
245 >>= (\out_ptr' -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)
246 >>= set_colors
247 SetState state
248 -- implicitly resets the colors to the defaults
249 -> serialize_cap_expression ( fromJust $ set_attr_states
250 $ display_attr_caps
251 $ term d
252 )
253 ( sgr_args_for_state state )
254 out_ptr
255 >>= set_colors
256 -- Otherwise the display colors are not changing or changing between two non-default
257 -- points.
258 False -> do
259 -- Still, it could be the case that the change in display attributes requires the
260 -- colors to be reset because the required capability was not available.
261 case req_display_cap_seq_for ( display_attr_caps $ term d )
262 ( fixed_style attr )
263 ( style_diffs diffs )
264 of
265 -- Really, if terminals were re-implemented with modern concepts instead of
266 -- bowing down to 40 yr old dumb terminal requirements this would be the
267 -- only case ever reached!
268 -- Changes the style and color states according to the differences with the
269 -- currently applied states.
270 EnterExitSeq caps
271 -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps
272 >>= apply_color_diff set_fore_color ( fore_color_diff diffs )
273 >>= apply_color_diff set_back_color ( back_color_diff diffs )
274 SetState state
275 -- implicitly resets the colors to the defaults
276 -> serialize_cap_expression ( fromJust $ set_attr_states
277 $ display_attr_caps
278 $ term d
279 )
280 ( sgr_args_for_state state )
281 out_ptr
282 >>= set_colors
283 where
284 attr = fix_display_attr prev_attr req_attr
285 set_colors ptr = do
286 ptr' <- case fixed_fore_color attr of
287 Just c -> serialize_cap_expression ( set_fore_color $ term d )
288 [ ansi_color_index c ]
289 ptr
290 Nothing -> return ptr
291 ptr'' <- case fixed_back_color attr of
292 Just c -> serialize_cap_expression ( set_back_color $ term d )
293 [ ansi_color_index c ]
294 ptr'
295 Nothing -> return ptr'
296 return ptr''
297 apply_color_diff _f NoColorChange ptr
298 = return ptr
299 apply_color_diff _f ColorToDefault _ptr
300 = fail "ColorToDefault is not a possible case for apply_color_diffs"
301 apply_color_diff f ( SetColor c ) ptr
302 = serialize_cap_expression ( f $ term d )
303 [ ansi_color_index c ]
304 ptr
306 default_attr_required_bytes d
307 = cap_expression_required_bytes (set_default_attr $ term d) []
308 serialize_default_attr d out_ptr = do
309 serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr
311ansi_color_index :: Color -> Word
312ansi_color_index (ISOColor v) = toEnum $ fromEnum v
313ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
315{- The sequence of terminfo caps to apply a given style are determined according to these rules.
316 -
317 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
318 - the full set display attribute state capability.
319 -
320 - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
321 - display attributes are reset to defaults then the display attribute state is set.
322 -
323 - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
324 - display attribute state is set if possible. Otherwise the mode is not applied.
325 -
326 - 4. If the display attribute state is being set then just update the arguments to that for any
327 - apply/remove.
328 -
329 -}
331data DisplayAttrSeq
332 = EnterExitSeq [CapExpression]
333 | SetState DisplayAttrState
335data DisplayAttrState = DisplayAttrState
336 { apply_standout :: Bool
337 , apply_underline :: Bool
338 , apply_reverse_video :: Bool
339 , apply_blink :: Bool
340 , apply_dim :: Bool
341 , apply_bold :: Bool
342 }
344sgr_args_for_state :: DisplayAttrState -> [CapParam]
345sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
346 [ apply_standout attr_state
347 , apply_underline attr_state
348 , apply_reverse_video attr_state
349 , apply_blink attr_state
350 , apply_dim attr_state
351 , apply_bold attr_state
352 , False -- invis
353 , False -- protect
354 , False -- alt char set
355 ]
357req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
358req_display_cap_seq_for caps s diffs
359 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
360 -- then either the state needs to be set or the attribute change ignored.
361 = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
362 -- If all the diffs have an enter-exit cap then just use those
363 ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs
364 -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
365 -- all unsupported diffs and just apply the rest
366 ( True, False ) -> EnterExitSeq $ map enter_exit_cap
367 $ filter (not . no_enter_exit_cap) diffs
368 -- if not all the diffs have an enter-exit can and there is a set state cap then just use
369 -- the set state cap.
370 ( True, True ) -> SetState $ state_for_style s
371 where
372 no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
373 no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
374 no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
375 no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
376 no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
377 no_enter_exit_cap RemoveReverseVideo = True
378 no_enter_exit_cap ApplyBlink = True
379 no_enter_exit_cap RemoveBlink = True
380 no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
381 no_enter_exit_cap RemoveDim = True
382 no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
383 no_enter_exit_cap RemoveBold = True
384 enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
385 enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
386 enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
387 enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
388 enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
389 enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
390 enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
391 enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
393state_for_style :: Style -> DisplayAttrState
394state_for_style s = DisplayAttrState
395 { apply_standout = is_style_set standout
396 , apply_underline = is_style_set underline
397 , apply_reverse_video = is_style_set reverse_video
398 , apply_blink = is_style_set blink
399 , apply_dim = is_style_set dim
400 , apply_bold = is_style_set bold
401 }
402 where is_style_set = has_style s
404style_to_apply_seq :: Style -> [StyleStateChange]
405style_to_apply_seq s = concat
406 [ apply_if_required ApplyStandout standout
407 , apply_if_required ApplyUnderline underline
408 , apply_if_required ApplyReverseVideo reverse_video
409 , apply_if_required ApplyBlink blink
410 , apply_if_required ApplyDim dim
411 , apply_if_required ApplyBlink bold
412 ]
413 where
414 apply_if_required ap flag
415 = if 0 == ( flag .&. s )
416 then []
417 else [ ap ]