@@ -15,6 +15,13 @@ import Graphics.Vty.Attributes
1515import Graphics.Vty.Terminal.Generic
1616import Graphics.Vty.DisplayRegion
1717
18+import Control.Applicative
19+import Control.Monad ( foldM )
20+
21+import Data.Bits ( (.&.) )
22+import Data.List ( foldl' )
23+import Data.Maybe ( fromJust )
24+import Data.Monoid
1825import Data.Word
1926
2027import Foreign.C.Types ( CLong )
@@ -24,17 +31,30 @@ import System.IO
2431
2532data Term = Term
2633 { term_info_ID :: String
27− , smcup :: CapExpression
28− , rmcup :: CapExpression
34+ , term_info :: Terminfo.Terminal
35+ , smcup :: Maybe CapExpression
36+ , rmcup :: Maybe CapExpression
2937 , cup :: CapExpression
3038 , cnorm :: CapExpression
3139 , civis :: CapExpression
3240 , set_fore_color :: CapExpression
3341 , set_back_color :: CapExpression
3442 , set_default_attr :: CapExpression
35− , set_attr :: CapExpression
43+ , clear_screen :: CapExpression
44+ , display_attr_caps :: DisplayAttrCaps
3645 }
3746
47+data 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+ }
57+
3858marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
3959marshall_cap_to_terminal t cap_selector cap_params = do
4060 marshall_to_terminal t (cap_expression_required_bytes (cap_selector t) cap_params)
@@ -53,31 +73,50 @@ marshall_cap_to_terminal t cap_selector cap_params = do
5373 -}
5474terminal_instance :: String -> IO Term
5575terminal_instance in_ID = do
56− term_info <- Terminfo.setupTerm in_ID
57− let str_cap str = case Terminfo.getCapability term_info (Terminfo.tiGetStr str) of
58− Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""
59− Just cap_str -> case parse_cap_expression cap_str of
60− Left e -> fail $ show e
61− Right cap -> return cap
62− smcup_cap <- str_cap "smcup"
63− rmcup_cap <- str_cap "rmcup"
64− cup_cap <- str_cap "cup"
65− cnorm_cap <- str_cap "cnorm"
66− civis_cap <- str_cap "civis"
67− setaf_cap <- str_cap "setaf"
68− setab_cap <- str_cap "setab"
69− sgr0_cap <- str_cap "sgr0"
70− sgr_cap <- str_cap "sgr"
71− return $ Term in_ID
72− smcup_cap
73− rmcup_cap
74− cup_cap
75− cnorm_cap
76− civis_cap
77− setaf_cap
78− setab_cap
79− sgr0_cap
80− sgr_cap
76+ ti <- 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 -> case parse_cap_expression cap_str 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 -> case parse_cap_expression cap_str of
87+ Left e -> fail $ show e
88+ Right cap -> return $ Just cap
89+ pure Term
90+ <*> pure in_ID
91+ <*> pure ti
92+ <*> probe_cap "smcup"
93+ <*> probe_cap "rmcup"
94+ <*> require_cap "cup"
95+ <*> require_cap "cnorm"
96+ <*> require_cap "civis"
97+ <*> require_cap "setaf"
98+ <*> require_cap "setab"
99+ <*> require_cap "sgr0"
100+ <*> require_cap "clear"
101+ <*> current_display_attr_caps ti
102+
103+current_display_attr_caps :: Terminfo.Terminal -> IO DisplayAttrCaps
104+current_display_attr_caps ti
105+ = pure DisplayAttrCaps
106+ <*> probe_cap "sgr"
107+ <*> probe_cap "smso"
108+ <*> probe_cap "rmso"
109+ <*> probe_cap "smul"
110+ <*> probe_cap "rmul"
111+ <*> probe_cap "rev"
112+ <*> probe_cap "dim"
113+ <*> probe_cap "bold"
114+ where probe_cap cap_name
115+ = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
116+ Nothing -> return Nothing
117+ Just cap_str -> case parse_cap_expression cap_str of
118+ Left e -> fail $ show e
119+ Right cap -> return $ Just cap
81120
82121instance Terminal Term where
83122 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
@@ -86,17 +125,26 @@ instance Terminal Term where
86125 return ()
87126
88127 reserve_display t = do
89− marshall_cap_to_terminal t smcup []
90− marshall_cap_to_terminal t cup [0, 0]
128+ if (isJust $ smcup t)
129+ then marshall_cap_to_terminal t (fromJust . smcup) []
130+ else return ()
131+ -- Screen on OS X does not appear to support smcup?
132+ marshall_cap_to_terminal t clear_screen []
91133 return ()
92134
93135 release_display t = do
94− marshall_cap_to_terminal t rmcup []
136+ if (isJust $ rmcup t)
137+ then marshall_cap_to_terminal t (fromJust . rmcup) []
138+ else return ()
95139 marshall_cap_to_terminal t cnorm []
96140 return ()
97141
98142 display_terminal_instance t b c = do
99− return $ c (DisplayContext b t)
143+ let color_count
144+ = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of
145+ Nothing -> 8
146+ Just v -> toEnum v
147+ return $ c (DisplayContext b t color_count)
100148
101149 display_bounds _t = do
102150 raw_size <- get_window_size
@@ -119,11 +167,14 @@ get_window_size = do
119167data DisplayContext = DisplayContext
120168 { bounds :: DisplayRegion
121169 , term :: Term
170+ , supported_colors :: Word
122171 }
123172
124173instance DisplayTerminal DisplayContext where
125174 context_region d = bounds d
126175
176+ context_color_count d = supported_colors d
177+
127178 move_cursor_required_bytes d x y
128179 = cap_expression_required_bytes (cup $ term d) [y, x]
129180 serialize_move_cursor d x y out_ptr
@@ -139,41 +190,106 @@ instance DisplayTerminal DisplayContext where
139190 serialize_hide_cursor d out_ptr
140191 = serialize_cap_expression (civis $ term d) [] out_ptr
141192
193+ -- Instead of evaluating all the rules related to setting display attributes twice (once in
194+ -- required bytes and again in serialize) or some memoization scheme just return a size
195+ -- requirement as big the longest possible control string.
196+ --
197+ -- Which is assumed to the be less than 512 for now.
198+ --
199+ -- \todo Not verified as safe and wastes memory.
200+ attr_required_bytes d _prev_attr _req_attr _diffs = 512
201+
202+ -- Portably setting the display attributes is a giant pain in the ass.
203+ -- If the terminal supports the sgr capability (which sets the on/off state of each style
204+ -- directly ; and, for no good reason, resets the colors to the default) this always works:
142205 -- 0. set the style attributes. This resets the fore and back color.
143206 -- 1, If a foreground color is to be set then set the foreground color
144207 -- 2. likewise with the background color
145− --
146208 --
147− -- todo: This process is accurate but inefficient. Optimize later.
148− attr_required_bytes d prev_attr req_attr =
149− let attr = fix_display_attr prev_attr req_attr
150− in cap_expression_required_bytes ( set_attr $ term d )
151− ( sgr_args_for_style (fixed_style attr) )
152− + case fixed_fore_color attr of
153− Just c -> cap_expression_required_bytes ( set_fore_color $ term d )
154− [ ansi_color_index c ]
155− Nothing -> 0
156− + case fixed_back_color attr of
157− Just c -> cap_expression_required_bytes ( set_back_color $ term d )
158− [ ansi_color_index c ]
159− Nothing -> 0
160−
161− serialize_set_attr d prev_attr req_attr out_ptr = do
162− let attr = fix_display_attr prev_attr req_attr
163− out_ptr' <- serialize_cap_expression ( set_attr $ term d )
164− ( sgr_args_for_style (fixed_style attr) )
165− out_ptr
166− out_ptr'' <- case fixed_fore_color attr of
167− Just c -> serialize_cap_expression ( set_fore_color $ term d )
168− [ ansi_color_index c ]
169− out_ptr'
170− Nothing -> return out_ptr'
171− out_ptr''' <- case fixed_back_color attr of
172− Just c -> serialize_cap_expression ( set_back_color $ term d )
173− [ ansi_color_index c ]
174− out_ptr''
175− Nothing -> return out_ptr''
176− return out_ptr'''
209+ -- If the terminal does not support the sgr then
210+ -- if there is a change from an applied color to the default (in either the fore or back color)
211+ -- then:
212+ -- 0. reset all display attributes (sgr0)
213+ -- 1. enter required style modes
214+ -- 2. set the fore color if required
215+ -- 3. set the back color if required
216+ --
217+ -- Entering the required style modes could require a reset of the display attributes. If this is
218+ -- the case then the back and fore colors always need to be set if not default.
219+ --
220+ -- All this (I think) is satisfied by the following logic:
221+ serialize_set_attr d prev_attr req_attr diffs out_ptr = do
222+ case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
223+ -- The only way to reset either color, portably, to the default is to use either the set
224+ -- state capability or the set default capability.
225+ True -> do
226+ case req_display_cap_seq_for ( display_attr_caps $ term d )
227+ ( fixed_style attr )
228+ ( style_to_apply_seq $ fixed_style attr )
229+ of
230+ EnterExitSeq caps
231+ -- only way to reset a color to the defaults
232+ -> serialize_default_attr d out_ptr
233+ >>= (\ptr -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) ptr caps)
234+ >>= set_colors
235+ SetState state
236+ -- implicitly resets the colors to the defaults
237+ -> serialize_cap_expression ( fromJust $ set_attr_states
238+ $ display_attr_caps
239+ $ term d
240+ )
241+ ( sgr_args_for_state state )
242+ out_ptr
243+ >>= set_colors
244+ -- Otherwise the display colors are not changing or changing between two non-default
245+ -- points.
246+ False -> do
247+ -- Still, it could be the case that the change in display attributes requires the
248+ -- colors to be reset because the required capability was not available.
249+ case req_display_cap_seq_for ( display_attr_caps $ term d )
250+ ( fixed_style attr )
251+ ( style_diffs diffs )
252+ of
253+ -- Really, if terminals were re-implemented with modern concepts instead of
254+ -- bowing down to 40 yr old dumb terminal requirements this would be the
255+ -- only case ever reached!
256+ -- Changes the style and color states according to the differences with the
257+ -- currently applied states.
258+ EnterExitSeq caps
259+ -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps
260+ >>= apply_color_diff set_fore_color ( fore_color_diff diffs )
261+ >>= apply_color_diff set_back_color ( back_color_diff diffs )
262+ SetState state
263+ -- implicitly resets the colors to the defaults
264+ -> 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+ where
272+ attr = fix_display_attr prev_attr req_attr
273+ set_colors ptr = do
274+ ptr' <- case fixed_fore_color attr of
275+ Just c -> serialize_cap_expression ( set_fore_color $ term d )
276+ [ ansi_color_index c ]
277+ ptr
278+ Nothing -> return ptr
279+ ptr'' <- case fixed_back_color attr of
280+ Just c -> serialize_cap_expression ( set_back_color $ term d )
281+ [ ansi_color_index c ]
282+ ptr'
283+ Nothing -> return ptr'
284+ return ptr''
285+ apply_color_diff _f NoColorChange ptr
286+ = return ptr
287+ apply_color_diff _f ColorToDefault ptr
288+ = fail "ColorToDefault is not a possible case for apply_color_diffs"
289+ apply_color_diff f ( SetColor c ) ptr
290+ = serialize_cap_expression ( f $ term d )
291+ [ ansi_color_index c ]
292+ ptr
177293
178294 default_attr_required_bytes d
179295 = cap_expression_required_bytes (set_default_attr $ term d) []
@@ -185,16 +301,143 @@ ansi_color_index :: Color -> Word
185301ansi_color_index (ISOColor v) = toEnum $ fromEnum v
186302ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
187303
188−sgr_args_for_style :: Style -> [CapParam]
189−sgr_args_for_style s = map ( \b -> if b then 1 else 0 )
190− [ s `has_style` standout
191− , s `has_style` underline
192− , s `has_style` reverse_video
193− , s `has_style` blink
194− , s `has_style` dim
195− , s `has_style` bold
304+{- The sequence of terminfo caps to apply a given style are determined according to these rules.
305+ -
306+ - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
307+ - the full set display attribute state capability.
308+ -
309+ - 2. If a mode is supposed to be removed but there is not an exit capability defined then the
310+ - display attributes are reset to defaults then the display attribute state is set.
311+ -
312+ - 3. If a mode is supposed to be applied but there is not an enter capability defined then then
313+ - display attribute state is set if possible. Otherwise the mode is not applied.
314+ -
315+ - 4. If the display attribute state is being set then just update the arguments to that for any
316+ - apply/remove.
317+ -
318+ - The style diffs each imply either the enter/exit control code or a reset to defaults ; set state
319+ - sequence. This mapping satisfies the communitive monoid properties:
320+ - - no diff * diff == diff
321+ - - diff * no diff == diff
322+ - - (diff_0 * diff_1) * diff_2 == diff_0 * ( diff_1 * diff_2 )
323+ - - diff_0 * diff_1 == diff_1 * diff_0
324+ - so the mapping is a sequence of mappend's applied to mempty. Where the monoid points appended
325+ - depend on the diff. The accumulated value is the monad point that represents the final sequence
326+ - to apply. The application (*) operator assures all the rules are followed.
327+ -
328+ - The diff implies an enter/exit control code if:
329+ - - The current
330+ -}
331+
332+data DisplayAttrSeq v
333+ = EnterExitSeq [v]
334+ | SetState DisplayAttrState
335+
336+instance Monoid (DisplayAttrSeq v) where
337+ mempty = EnterExitSeq []
338+ SetState s `mappend` _ = SetState s
339+ _ `mappend` SetState s = SetState s
340+ (EnterExitSeq caps_0) `mappend` (EnterExitSeq caps_1) = EnterExitSeq (caps_0 `mappend` caps_1)
341+
342+data 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+ }
350+
351+sgr_args_for_state :: DisplayAttrState -> [CapParam]
352+sgr_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
196359 , False -- invis
197360 , False -- protect
198361 , False -- alt char set
199362 ]
200363
364+req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq CapExpression
365+req_display_cap_seq_for caps style diffs =
366+ -- First pass: concat the monoid points that are implied by the diffs
367+ let base = mconcat $ map diff_point diffs
368+ -- Second pass: Apply the capability restrictions.
369+ in apply_caps base
370+ where
371+ set_state = SetState $ state_for_style style
372+ diff_point ApplyStandout = EnterExitSeq [ApplyStandout]
373+ diff_point ApplyUnderline = EnterExitSeq [ApplyUnderline]
374+ diff_point ApplyReverseVideo = EnterExitSeq [ApplyReverseVideo]
375+ diff_point ApplyBlink = set_state
376+ diff_point ApplyDim = EnterExitSeq [ApplyDim]
377+ diff_point ApplyBold = EnterExitSeq [ApplyBold]
378+ diff_point RemoveStandout = EnterExitSeq [RemoveStandout]
379+ diff_point RemoveUnderline = EnterExitSeq [RemoveUnderline]
380+ diff_point RemoveReverseVideo = set_state
381+ diff_point RemoveBlink = set_state
382+ diff_point RemoveDim = set_state
383+ diff_point RemoveBold = set_state
384+ apply_caps ( SetState _ )
385+ = case set_attr_states caps of
386+ Nothing -> EnterExitSeq []
387+ Just _ -> set_state
388+ apply_caps (EnterExitSeq [])
389+ = EnterExitSeq []
390+ apply_caps (EnterExitSeq (diff : diffs'))
391+ = case apply_caps' diff of
392+ SetState _ -> set_state
393+ p -> p `mappend` apply_caps (EnterExitSeq diffs')
394+ apply_caps' ApplyStandout = m $ enter_standout caps
395+ apply_caps' ApplyUnderline = m $ enter_underline caps
396+ apply_caps' ApplyReverseVideo = m $ enter_reverse_video caps
397+ apply_caps' ApplyBlink = set_state
398+ apply_caps' ApplyDim = m $ enter_dim_mode caps
399+ apply_caps' ApplyBold = m $ enter_bold_mode caps
400+ apply_caps' RemoveStandout = m $ exit_standout caps
401+ apply_caps' RemoveUnderline = m $ exit_underline caps
402+ apply_caps' RemoveReverseVideo = set_state
403+ apply_caps' RemoveBlink = set_state
404+ apply_caps' RemoveDim = set_state
405+ apply_caps' RemoveBold = set_state
406+ m = maybe set_state (EnterExitSeq . return)
407+
408+{-
409+set_style_required_bytes caps style diffs reset_cap =
410+ let state = state_for_style style
411+ req_seq = req_seq_for caps style diffs
412+ in case req_seq of
413+ EnterExitSeq caps -> sum $ map (\cap -> cap_expression_required_bytes cap []) caps
414+ SetState -> cap_expression_required_bytes ( fromJust $ set_attr_states $ caps )
415+ ( sgr_args_for_state state )
416+-}
417+
418+state_for_style :: Style -> DisplayAttrState
419+state_for_style s = DisplayAttrState
420+ { apply_standout = is_style_set standout
421+ , apply_underline = is_style_set underline
422+ , apply_reverse_video = is_style_set reverse_video
423+ , apply_blink = is_style_set blink
424+ , apply_dim = is_style_set dim
425+ , apply_bold = is_style_set bold
426+ }
427+ where is_style_set = has_style s
428+
429+style_to_apply_seq :: Style -> [StyleStateChange]
430+style_to_apply_seq s = mconcat
431+ [ apply_if_required ApplyStandout standout
432+ , apply_if_required ApplyUnderline underline
433+ , apply_if_required ApplyReverseVideo reverse_video
434+ , apply_if_required ApplyBlink blink
435+ , apply_if_required ApplyDim dim
436+ , apply_if_required ApplyBlink bold
437+ ]
438+ where
439+ apply_if_required ap flag
440+ = if 0 == ( flag .&. s )
441+ then []
442+ else [ ap ]
443+