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