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