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