git.iko.soy/vty
on master help sign in
change Attr record accessors
bde5a93coreyoconnor
CHANGELOGnew file+49
compare with master
unifiedsplit
@@ -0,0 +1,49 @@
1+4.1.0.0
2+ * API changes:
3+ * Attr record accessor fore_color changed to attr_fore_color
4+ * Attr record accessor back_color changed to attr_back_color
5+ * Attr record accessor style changed to attr_style
6+ * Added an "inline" attribute changing DSL:
7+ * put_attr_change applies and attribute change monad action
8+ * can be used to change the display attrbiutes of text output via putStrLn and putStr,
9+ for instance. EX: "put_attr_change $ back_color red" will set the background color to
10+ red.
11+ * Does not apply to output_picture.
12+ * See Graphics.Vty.AttributeChange
13+4.0.0.1
14+ * binding for mk_wcswidth was incorrect. Most platforms just magically worked due to
15+ coincidence.
16+
17+4.0.0
18+ * Completely rewritten output backend.
19+ * Efficient, scanline style output span generator. Has not been fully optimized, but good
20+ enough.
21+ * The details required to display the desired picture on a terminal are well encapsulated.
22+ * Terminfo based display terminal implementation. With specialized derivitives for xterm,
23+ Terminal.app, and iTerm.app.
24+ * Attempts to robustly handle even terminals that don't support all display attributes.
25+ * I've tested the following terminals with success: iTerm.app, Terminal.app, xterm,
26+ rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be
27+ as successfull.
28+ * Improved unicode support. Double wide characters will display as expected.
29+ * 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted
30+ according to the number of colors the terminal supports.
31+ * The Graphics.Vty.Image combinators no longer require matching dimensions to arguments.
32+ Unspecified areas are filled in with a user-customizable background pattern. See
33+ Graphics.Vty.Picture.
34+ * output images are always cropped to display size.
35+ * Significant code coverage by QuickCheck tests. An interactive test for those final properties
36+ that couldn't be automatically verified.
37+
38+ issues resolved:
39+ * "gnome terminal displays non-basic attributes as strikethrough"
40+ * http://trac.haskell.org/vty/ticket/14
41+ * "Multi-byte characters are not displayed correctly on update"
42+ * http://trac.haskell.org/vty/ticket/10
43+ * "Redraw does not handle rendering a line that extends beyond screen width characters"
44+ * http://trac.haskell.org/vty/ticket/13
45+ * "The <|> and <-> combinators should be more forgiving of mismatched dimensions"
46+ * http://trac.haskell.org/vty/ticket/9
47+ * "256-color support"
48+ * http://trac.haskell.org/vty/ticket/19
49+
README+10−16
@@ -1,15 +1,13 @@
1−vty is a very simple terminal interface library.
1+vty is a terminal interface library.
2
2
3Vty currently provides:
3Vty currently provides:
4
4
5−* Automatic handling of suspend/resume (SIGTSTP+SIGCONT).
6−
7* Automatic handling of window resizes.
5* Automatic handling of window resizes.
8
6
9* Supports Unicode characters on output, automatically setting and
7* Supports Unicode characters on output, automatically setting and
10− resetting UTF-8 mode (beware double width and combining characters!)
8+ resetting UTF-8 mode for xterm. Other terminals are assumed to support
11
9
12−* Automatic computation of minimal differences.
10+* Efficient output.
13
11
14* Minimizes repaint area, thus virtually eliminating the flicker
12* Minimizes repaint area, thus virtually eliminating the flicker
15 problem that plagues ncurses programs.
13 problem that plagues ncurses programs.
@@ -27,17 +25,13 @@ Vty currently provides:
27* Interface is designed for relatively easy compatible extension.
25* Interface is designed for relatively easy compatible extension.
28
26
29* Supports all ANSI SGR-modes (defined in console_codes(4)) with
27* Supports all ANSI SGR-modes (defined in console_codes(4)) with
30− a simple type-safe interface.
28+ a type-safe interface.
31
29
32−* Properly handles cleanup, leaving the cursor at the bottom of
30+* Properly handles cleanup.
33− the screen and erasing the last line.
34
31
35Current disadvantages:
32Current disadvantages:
36
33
37−* No current support for non-ANSI terminals.
34+* The character encoding of the output terminal is assumed to be UTF-8.
38−
39−* UTF-8 support only works properly on the linux console/xterm,
40− and even then only if it is not the system default.
41
35
42* Minimal support for special keys on terminals other than the
36* Minimal support for special keys on terminals other than the
43 linux-console. (F1-5 and arrow keys should work, but anything
37 linux-console. (F1-5 and arrow keys should work, but anything
@@ -46,9 +40,9 @@ Current disadvantages:
46* Uses the TIOCGWINSZ ioctl to find the current window size, which
40* Uses the TIOCGWINSZ ioctl to find the current window size, which
47 appears to be limited to Linux and *BSD.
41 appears to be limited to Linux and *BSD.
48
42
49−darcs get --tag=rel-3.0.0 http://code.haskell.org/vty/
43+darcs get --tag=vty-4.0.0.1 http://code.haskell.org/vty/
50
44
51−To compile the demonstration program: ghc --make Test.hs gwinsz.c
45+To compile the demonstration program: ghc --make test/Test.hs gwinsz.c
52
46
53−The main documentation consists of the haddock-comments and the
47+The main documentation consists of the haddock-comments and the demonstration
54−demonstration program
48+program
src/Graphics/Vty/Attributes.hs+7−7
@@ -46,9 +46,9 @@ import Data.Word
46-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more
46-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more
47-- information.
47-- information.
48data Attr = Attr
48data Attr = Attr
49− { style :: !(MaybeDefault Style)
49+ { attr_style :: !(MaybeDefault Style)
50− , fore_color :: !(MaybeDefault Color)
50+ , attr_fore_color :: !(MaybeDefault Color)
51− , back_color :: !(MaybeDefault Color)
51+ , attr_back_color :: !(MaybeDefault Color)
52 } deriving ( Eq, Show )
52 } deriving ( Eq, Show )
53
53
54-- | Specifies the display attributes such that the final style and color values do not depend on
54-- | Specifies the display attributes such that the final style and color values do not depend on
@@ -168,7 +168,7 @@ default_style_mask = 0x00
168
168
169style_mask :: Attr -> Word8
169style_mask :: Attr -> Word8
170style_mask attr
170style_mask attr
171− = case style attr of
171+ = case attr_style attr of
172 Default -> 0
172 Default -> 0
173 KeepCurrent -> 0
173 KeepCurrent -> 0
174 SetTo v -> v
174 SetTo v -> v
@@ -179,15 +179,15 @@ has_style s bit_mask = ( s .&. bit_mask ) /= 0
179
179
180-- | Set the foreground color of an `Attr'.
180-- | Set the foreground color of an `Attr'.
181with_fore_color :: Attr -> Color -> Attr
181with_fore_color :: Attr -> Color -> Attr
182−with_fore_color attr c = attr { fore_color = SetTo c }
182+with_fore_color attr c = attr { attr_fore_color = SetTo c }
183
183
184-- | Set the background color of an `Attr'.
184-- | Set the background color of an `Attr'.
185with_back_color :: Attr -> Color -> Attr
185with_back_color :: Attr -> Color -> Attr
186−with_back_color attr c = attr { back_color = SetTo c }
186+with_back_color attr c = attr { attr_back_color = SetTo c }
187
187
188-- | Add the given style attribute
188-- | Add the given style attribute
189with_style :: Attr -> Style -> Attr
189with_style :: Attr -> Style -> Attr
190−with_style attr style_flag = attr { style = SetTo $ style_mask attr .|. style_flag }
190+with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag }
191
191
192-- | Sets the style, background color and foreground color to the default values for the terminal.
192-- | Sets the style, background color and foreground color to the default values for the terminal.
193-- There is no easy way to determine what the default background and foreground colors are.
193-- There is no easy way to determine what the default background and foreground colors are.
src/Graphics/Vty/Terminal.hs+7
@@ -19,6 +19,7 @@ module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal
19 , TerminalHandle(..)
19 , TerminalHandle(..)
20 , DisplayHandle(..)
20 , DisplayHandle(..)
21 , output_picture
21 , output_picture
22+ -- , put_attr_change
22 , display_context
23 , display_context
23 )
24 )
24 where
25 where
@@ -118,6 +119,12 @@ hide_cursor t = do
118 d <- display_context t bounds
119 d <- display_context t bounds
119 marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)
120 marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)
120
121
122+{-
123+put_attr_change :: TerminalHandle -> -> m ()
124+put_attr_change d img = do
125+ return ()
126+-}
127+
121-- | Shows the cursor
128-- | Shows the cursor
122show_cursor :: TerminalHandle -> IO ()
129show_cursor :: TerminalHandle -> IO ()
123show_cursor t = do
130show_cursor t = do
src/Graphics/Vty/Terminal/Generic.hs+107−10
@@ -4,7 +4,9 @@
4-- Copyright 2009 Corey O'Connor
4-- Copyright 2009 Corey O'Connor
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7−module Graphics.Vty.Terminal.Generic
7+module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic
8+ , OutputBuffer
9+ )
8 where
10 where
9
11
10import Data.Marshalling
12import Data.Marshalling
@@ -14,11 +16,14 @@ import Graphics.Vty.Span
14import Graphics.Vty.DisplayRegion
16import Graphics.Vty.DisplayRegion
15
17
16import Control.Monad ( liftM )
18import Control.Monad ( liftM )
19+import Control.Monad.Trans
17
20
18import Data.Array
21import Data.Array
22+import Data.Bits ( (.&.) )
19import qualified Data.ByteString.Internal as BSCore
23import qualified Data.ByteString.Internal as BSCore
20import Data.Foldable
24import Data.Foldable
21import Data.IORef
25import Data.IORef
26+import Data.Monoid ( mconcat )
22import Data.Word
27import Data.Word
23import Data.String.UTF8 hiding ( foldl )
28import Data.String.UTF8 hiding ( foldl )
24
29
@@ -107,6 +112,9 @@ class DisplayTerminal d where
107 -- | Provide the bounds of the display context.
112 -- | Provide the bounds of the display context.
108 context_region :: d -> DisplayRegion
113 context_region :: d -> DisplayRegion
109
114
115+ -- | Maximum number of colors supported by the context.
116+ context_color_count :: d -> Word
117+
110 -- | sets the output position to the specified row and column. Where the number of bytes
118 -- | sets the output position to the specified row and column. Where the number of bytes
111 -- required for the control codes can be specified seperate from the actual byte sequence.
119 -- required for the control codes can be specified seperate from the actual byte sequence.
112 move_cursor_required_bytes :: d -> Word -> Word -> Word
120 move_cursor_required_bytes :: d -> Word -> Word -> Word
@@ -129,8 +137,8 @@ class DisplayTerminal d where
129 -- attributes. In order to support this the currently applied display attributes are required.
137 -- attributes. In order to support this the currently applied display attributes are required.
130 -- In addition it may be possible to optimize the state changes based off the currently applied
138 -- In addition it may be possible to optimize the state changes based off the currently applied
131 -- display attributes.
139 -- display attributes.
132− attr_required_bytes :: d -> FixedAttr -> Attr -> Word
140+ attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiffs -> Word
133− serialize_set_attr :: d -> FixedAttr -> Attr -> OutputBuffer -> IO OutputBuffer
141+ serialize_set_attr :: d -> FixedAttr -> Attr -> DisplayAttrDiffs -> OutputBuffer -> IO OutputBuffer
134
142
135 -- | Reset the display attributes to the default display attributes
143 -- | Reset the display attributes to the default display attributes
136 default_attr_required_bytes :: d -> Word
144 default_attr_required_bytes :: d -> Word
@@ -139,6 +147,7 @@ class DisplayTerminal d where
139
147
140instance DisplayTerminal DisplayHandle where
148instance DisplayTerminal DisplayHandle where
141 context_region (DisplayHandle d _ _) = context_region d
149 context_region (DisplayHandle d _ _) = context_region d
150+ context_color_count (DisplayHandle d _ _) = context_color_count d
142 move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d
151 move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d
143 serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d
152 serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d
144 show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d
153 show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d
@@ -256,8 +265,9 @@ span_ops_required_bytes d y in_fattr span_ops =
256
265
257span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)
266span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)
258span_op_required_bytes d fattr (AttributeChange attr) =
267span_op_required_bytes d fattr (AttributeChange attr) =
268+ let attr' = limit_attr_for_display d attr
259− let c = attr_required_bytes d fattr attr
269+ c = attr_required_bytes d fattr attr' (display_attr_diffs fattr fattr')
260− fattr' = fix_display_attr fattr attr
270+ fattr' = fix_display_attr fattr attr'
261 in (c, fattr')
271 in (c, fattr')
262span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
272span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
263
273
@@ -304,8 +314,9 @@ serialize_span_op :: DisplayTerminal d
304 -> FixedAttr
314 -> FixedAttr
305 -> IO (OutputBuffer, FixedAttr)
315 -> IO (OutputBuffer, FixedAttr)
306serialize_span_op d (AttributeChange attr) out_ptr fattr = do
316serialize_span_op d (AttributeChange attr) out_ptr fattr = do
317+ let attr' = limit_attr_for_display d attr
318+ fattr' = fix_display_attr fattr attr'
307− out_ptr' <- serialize_set_attr d fattr attr out_ptr
319+ out_ptr' <- serialize_set_attr d fattr attr' (display_attr_diffs fattr fattr') out_ptr
308− let fattr' = fix_display_attr fattr attr
309 return (out_ptr', fattr')
320 return (out_ptr', fattr')
310serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
321serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
311 out_ptr' <- serialize_utf8_text str out_ptr
322 out_ptr' <- serialize_utf8_text str out_ptr
@@ -330,9 +341,9 @@ marshall_to_terminal t c f = do
330-- abstraction.
341-- abstraction.
331fix_display_attr :: FixedAttr -> Attr -> FixedAttr
342fix_display_attr :: FixedAttr -> Attr -> FixedAttr
332fix_display_attr fattr attr
343fix_display_attr fattr attr
333− = FixedAttr ( fix_style (fixed_style fattr) (style attr) )
344+ = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )
334− ( fix_color (fixed_fore_color fattr) (fore_color attr) )
345+ ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )
335− ( fix_color (fixed_back_color fattr) (back_color attr) )
346+ ( fix_color (fixed_back_color fattr) (attr_back_color attr) )
336 where
347 where
337 fix_style _s Default = default_style_mask
348 fix_style _s Default = default_style_mask
338 fix_style s KeepCurrent = s
349 fix_style s KeepCurrent = s
@@ -341,6 +352,68 @@ fix_display_attr fattr attr
341 fix_color c KeepCurrent = c
352 fix_color c KeepCurrent = c
342 fix_color _c (SetTo c) = Just c
353 fix_color _c (SetTo c) = Just c
343
354
355+data DisplayAttrDiffs = DisplayAttrDiffs
356+ { style_diffs :: [ StyleStateChange ]
357+ , fore_color_diff :: DisplayColorDiff
358+ , back_color_diff :: DisplayColorDiff
359+ }
360+
361+data DisplayColorDiff
362+ = ColorToDefault
363+ | NoColorChange
364+ | SetColor !Color
365+ deriving Eq
366+
367+data StyleStateChange
368+ = ApplyStandout
369+ | RemoveStandout
370+ | ApplyUnderline
371+ | RemoveUnderline
372+ | ApplyReverseVideo
373+ | RemoveReverseVideo
374+ | ApplyBlink
375+ | RemoveBlink
376+ | ApplyDim
377+ | RemoveDim
378+ | ApplyBold
379+ | RemoveBold
380+
381+display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiffs
382+display_attr_diffs attr attr' = DisplayAttrDiffs
383+ { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )
384+ , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )
385+ , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )
386+ }
387+
388+diff_color Nothing (Just c') = SetColor c'
389+diff_color (Just c) (Just c')
390+ | c == c' = NoColorChange
391+ | otherwise = SetColor c'
392+diff_color Nothing Nothing = NoColorChange
393+diff_color (Just _) Nothing = ColorToDefault
394+
395+diff_styles :: Style -> Style -> [StyleStateChange]
396+diff_styles prev cur
397+ = mconcat
398+ [ style_diff standout ApplyStandout RemoveStandout
399+ , style_diff underline ApplyUnderline RemoveUnderline
400+ , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo
401+ , style_diff blink ApplyBlink RemoveBlink
402+ , style_diff dim ApplyDim RemoveDim
403+ , style_diff bold ApplyBold RemoveBold
404+ ]
405+ where
406+ style_diff s sm rm
407+ = case ( 0 == prev .&. s, 0 == cur .&. s ) of
408+ -- not set in either
409+ ( True, True ) -> []
410+ -- set in both
411+ ( False, False ) -> []
412+ -- now set
413+ ( True, False) -> [ sm ]
414+ -- now unset
415+ ( False, True) -> [ rm ]
416+
344data CursorOutputMap = CursorOutputMap
417data CursorOutputMap = CursorOutputMap
345 { char_to_output_pos :: (Word, Word) -> (Word, Word)
418 { char_to_output_pos :: (Word, Word) -> (Word, Word)
346 }
419 }
@@ -374,3 +447,27 @@ cursor_column_offset span_ops cx cy =
374 (0, 0, False)
447 (0, 0, False)
375 cursor_row_ops
448 cursor_row_ops
376 in out_offset
449 in out_offset
450+
451+limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr
452+limit_attr_for_display d attr
453+ = attr { attr_fore_color = clamp_color $ attr_fore_color attr
454+ , attr_back_color = clamp_color $ attr_back_color attr
455+ }
456+ where
457+ clamp_color Default = Default
458+ clamp_color KeepCurrent = KeepCurrent
459+ clamp_color (SetTo c) = clamp_color' c
460+ clamp_color' (ISOColor v)
461+ | context_color_count d < 8 = Default
462+ | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
463+ | otherwise = SetTo $ ISOColor v
464+ clamp_color' (Color240 v)
465+ -- TODO: Choose closes ISO color?
466+ | context_color_count d < 8 = Default
467+ | context_color_count d < 16 = Default
468+ | context_color_count d == 240 = SetTo $ Color240 v
469+ | otherwise
470+ = let p :: Double = fromIntegral v / 240.0
471+ v' = floor $ p * (fromIntegral $ context_color_count d)
472+ in SetTo $ Color240 v'
473+
src/Graphics/Vty/Terminal/MacOSX.hs+9−2
@@ -34,15 +34,21 @@ flushed_put str = do
34 hPutStr stdout str
34 hPutStr stdout str
35 hFlush stdout
35 hFlush stdout
36
36
37+-- Terminal.app really does want the xterm-color smcup and rmcup caps. Not the generic xterm ones.
38+smcup_str = "\ESC7\ESC[?47h"
39+rmcup_str = "\ESC[2J\ESC[?47l\ESC8"
40+
37instance Terminal Term where
41instance Terminal Term where
38 terminal_ID t = "Terminal.app :: MacOSX"
42 terminal_ID t = "Terminal.app :: MacOSX"
39
43
40 release_terminal t = do
44 release_terminal t = do
41 release_terminal $ super_term t
45 release_terminal $ super_term t
42
46
43− reserve_display t = reserve_display (super_term t)
47+ reserve_display t = do
48+ flushed_put smcup_str
44
49
45− release_display t = release_display (super_term t)
50+ release_display t = do
51+ flushed_put rmcup_str
46
52
47 display_terminal_instance t b c = do
53 display_terminal_instance t b c = do
48 d <- display_context (super_term t) b
54 d <- display_context (super_term t) b
@@ -58,6 +64,7 @@ data DisplayContext = DisplayContext
58
64
59instance DisplayTerminal DisplayContext where
65instance DisplayTerminal DisplayContext where
60 context_region d = context_region (super_display d)
66 context_region d = context_region (super_display d)
67+ context_color_count d = context_color_count (super_display d)
61
68
62 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
69 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
63 serialize_move_cursor d = serialize_move_cursor (super_display d)
70 serialize_move_cursor d = serialize_move_cursor (super_display d)
src/Graphics/Vty/Terminal/TerminfoBased.hs+314−71
@@ -15,6 +15,13 @@ import Graphics.Vty.Attributes
15import Graphics.Vty.Terminal.Generic
15import Graphics.Vty.Terminal.Generic
16import Graphics.Vty.DisplayRegion
16import Graphics.Vty.DisplayRegion
17
17
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
18import Data.Word
25import Data.Word
19
26
20import Foreign.C.Types ( CLong )
27import Foreign.C.Types ( CLong )
@@ -24,17 +31,30 @@ import System.IO
24
31
25data Term = Term
32data Term = Term
26 { term_info_ID :: String
33 { term_info_ID :: String
34+ , term_info :: Terminfo.Terminal
27− , smcup :: CapExpression
35+ , smcup :: Maybe CapExpression
28− , rmcup :: CapExpression
36+ , rmcup :: Maybe CapExpression
29 , cup :: CapExpression
37 , cup :: CapExpression
30 , cnorm :: CapExpression
38 , cnorm :: CapExpression
31 , civis :: CapExpression
39 , civis :: CapExpression
32 , set_fore_color :: CapExpression
40 , set_fore_color :: CapExpression
33 , set_back_color :: CapExpression
41 , set_back_color :: CapExpression
34 , set_default_attr :: CapExpression
42 , set_default_attr :: CapExpression
35− , set_attr :: CapExpression
43+ , clear_screen :: CapExpression
44+ , display_attr_caps :: DisplayAttrCaps
36 }
45 }
37
46
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+
38marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
58marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
39marshall_cap_to_terminal t cap_selector cap_params = do
59marshall_cap_to_terminal t cap_selector cap_params = do
40 marshall_to_terminal t (cap_expression_required_bytes (cap_selector t) cap_params)
60 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
53 -}
73 -}
54terminal_instance :: String -> IO Term
74terminal_instance :: String -> IO Term
55terminal_instance in_ID = do
75terminal_instance in_ID = do
56− term_info <- Terminfo.setupTerm in_ID
76+ ti <- Terminfo.setupTerm in_ID
77+ let require_cap str
57− let str_cap str = case Terminfo.getCapability term_info (Terminfo.tiGetStr str) of
78+ = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of
58− Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""
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
59− Just cap_str -> case parse_cap_expression cap_str of
86+ Just cap_str -> case parse_cap_expression cap_str of
60− Left e -> fail $ show e
87+ Left e -> fail $ show e
61− Right cap -> return cap
88+ Right cap -> return $ Just cap
62− smcup_cap <- str_cap "smcup"
89+ pure Term
63− rmcup_cap <- str_cap "rmcup"
90+ <*> pure in_ID
64− cup_cap <- str_cap "cup"
91+ <*> pure ti
65− cnorm_cap <- str_cap "cnorm"
92+ <*> probe_cap "smcup"
66− civis_cap <- str_cap "civis"
93+ <*> probe_cap "rmcup"
67− setaf_cap <- str_cap "setaf"
94+ <*> require_cap "cup"
68− setab_cap <- str_cap "setab"
95+ <*> require_cap "cnorm"
69− sgr0_cap <- str_cap "sgr0"
96+ <*> require_cap "civis"
70− sgr_cap <- str_cap "sgr"
97+ <*> require_cap "setaf"
71− return $ Term in_ID
98+ <*> require_cap "setab"
72− smcup_cap
99+ <*> require_cap "sgr0"
73− rmcup_cap
100+ <*> require_cap "clear"
74− cup_cap
101+ <*> current_display_attr_caps ti
75− cnorm_cap
102+
76− civis_cap
103+current_display_attr_caps :: Terminfo.Terminal -> IO DisplayAttrCaps
77− setaf_cap
104+current_display_attr_caps ti
78− setab_cap
105+ = pure DisplayAttrCaps
79− sgr0_cap
106+ <*> probe_cap "sgr"
80− sgr_cap
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
81
120
82instance Terminal Term where
121instance Terminal Term where
83 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
122 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
@@ -86,17 +125,26 @@ instance Terminal Term where
86 return ()
125 return ()
87
126
88 reserve_display t = do
127 reserve_display t = do
128+ if (isJust $ smcup t)
89− marshall_cap_to_terminal t smcup []
129+ then marshall_cap_to_terminal t (fromJust . smcup) []
130+ else return ()
131+ -- Screen on OS X does not appear to support smcup?
90− marshall_cap_to_terminal t cup [0, 0]
132+ marshall_cap_to_terminal t clear_screen []
91 return ()
133 return ()
92
134
93 release_display t = do
135 release_display t = do
136+ if (isJust $ rmcup t)
94− marshall_cap_to_terminal t rmcup []
137+ then marshall_cap_to_terminal t (fromJust . rmcup) []
138+ else return ()
95 marshall_cap_to_terminal t cnorm []
139 marshall_cap_to_terminal t cnorm []
96 return ()
140 return ()
97
141
98 display_terminal_instance t b c = do
142 display_terminal_instance t b c = do
143+ let color_count
144+ = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of
145+ Nothing -> 8
146+ Just v -> toEnum v
99− return $ c (DisplayContext b t)
147+ return $ c (DisplayContext b t color_count)
100
148
101 display_bounds _t = do
149 display_bounds _t = do
102 raw_size <- get_window_size
150 raw_size <- get_window_size
@@ -119,11 +167,14 @@ get_window_size = do
119data DisplayContext = DisplayContext
167data DisplayContext = DisplayContext
120 { bounds :: DisplayRegion
168 { bounds :: DisplayRegion
121 , term :: Term
169 , term :: Term
170+ , supported_colors :: Word
122 }
171 }
123
172
124instance DisplayTerminal DisplayContext where
173instance DisplayTerminal DisplayContext where
125 context_region d = bounds d
174 context_region d = bounds d
126
175
176+ context_color_count d = supported_colors d
177+
127 move_cursor_required_bytes d x y
178 move_cursor_required_bytes d x y
128 = cap_expression_required_bytes (cup $ term d) [y, x]
179 = cap_expression_required_bytes (cup $ term d) [y, x]
129 serialize_move_cursor d x y out_ptr
180 serialize_move_cursor d x y out_ptr
@@ -139,41 +190,106 @@ instance DisplayTerminal DisplayContext where
139 serialize_hide_cursor d out_ptr
190 serialize_hide_cursor d out_ptr
140 = serialize_cap_expression (civis $ term d) [] out_ptr
191 = serialize_cap_expression (civis $ term d) [] out_ptr
141
192
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:
142 -- 0. set the style attributes. This resets the fore and back color.
205 -- 0. set the style attributes. This resets the fore and back color.
143 -- 1, If a foreground color is to be set then set the foreground color
206 -- 1, If a foreground color is to be set then set the foreground color
144 -- 2. likewise with the background color
207 -- 2. likewise with the background color
145− --
146 --
208 --
147− -- todo: This process is accurate but inefficient. Optimize later.
209+ -- If the terminal does not support the sgr then
148− attr_required_bytes d prev_attr req_attr =
210+ -- if there is a change from an applied color to the default (in either the fore or back color)
149− let attr = fix_display_attr prev_attr req_attr
211+ -- then:
150− in cap_expression_required_bytes ( set_attr $ term d )
212+ -- 0. reset all display attributes (sgr0)
151− ( sgr_args_for_style (fixed_style attr) )
213+ -- 1. enter required style modes
152− + case fixed_fore_color attr of
214+ -- 2. set the fore color if required
153− Just c -> cap_expression_required_bytes ( set_fore_color $ term d )
215+ -- 3. set the back color if required
154− [ ansi_color_index c ]
216+ --
155− Nothing -> 0
217+ -- Entering the required style modes could require a reset of the display attributes. If this is
156− + case fixed_back_color attr of
218+ -- the case then the back and fore colors always need to be set if not default.
157− Just c -> cap_expression_required_bytes ( set_back_color $ term d )
219+ --
158− [ ansi_color_index c ]
220+ -- All this (I think) is satisfied by the following logic:
159− Nothing -> 0
160−
161− serialize_set_attr d prev_attr req_attr out_ptr = do
221+ serialize_set_attr d prev_attr req_attr diffs out_ptr = do
162− let attr = fix_display_attr prev_attr req_attr
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
163− out_ptr' <- serialize_cap_expression ( set_attr $ term d )
264+ -> serialize_cap_expression ( fromJust $ set_attr_states
164− ( sgr_args_for_style (fixed_style attr) )
265+ $ display_attr_caps
266+ $ term d
267+ )
268+ ( sgr_args_for_state state )
165− out_ptr
269+ out_ptr
270+ >>= set_colors
271+ where
272+ attr = fix_display_attr prev_attr req_attr
273+ set_colors ptr = do
166− out_ptr'' <- case fixed_fore_color attr of
274+ ptr' <- case fixed_fore_color attr of
167− Just c -> serialize_cap_expression ( set_fore_color $ term d )
275+ Just c -> serialize_cap_expression ( set_fore_color $ term d )
168− [ ansi_color_index c ]
276+ [ ansi_color_index c ]
169− out_ptr'
277+ ptr
170− Nothing -> return out_ptr'
278+ Nothing -> return ptr
171− out_ptr''' <- case fixed_back_color attr of
279+ ptr'' <- case fixed_back_color attr of
172− Just c -> serialize_cap_expression ( set_back_color $ term d )
280+ Just c -> serialize_cap_expression ( set_back_color $ term d )
173− [ ansi_color_index c ]
281+ [ ansi_color_index c ]
174− out_ptr''
282+ ptr'
175− Nothing -> return out_ptr''
283+ Nothing -> return ptr'
176− return out_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
177
293
178 default_attr_required_bytes d
294 default_attr_required_bytes d
179 = cap_expression_required_bytes (set_default_attr $ term d) []
295 = cap_expression_required_bytes (set_default_attr $ term d) []
@@ -185,16 +301,143 @@ ansi_color_index :: Color -> Word
185ansi_color_index (ISOColor v) = toEnum $ fromEnum v
301ansi_color_index (ISOColor v) = toEnum $ fromEnum v
186ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
302ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
187
303
188−sgr_args_for_style :: Style -> [CapParam]
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]
189−sgr_args_for_style s = map ( \b -> if b then 1 else 0 )
352+sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
190− [ s `has_style` standout
353+ [ apply_standout attr_state
191− , s `has_style` underline
354+ , apply_underline attr_state
192− , s `has_style` reverse_video
355+ , apply_reverse_video attr_state
193− , s `has_style` blink
356+ , apply_blink attr_state
194− , s `has_style` dim
357+ , apply_dim attr_state
195− , s `has_style` bold
358+ , apply_bold attr_state
196 , False -- invis
359 , False -- invis
197 , False -- protect
360 , False -- protect
198 , False -- alt char set
361 , False -- alt char set
199 ]
362 ]
200
363
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+
src/Graphics/Vty/Terminal/XTermColor.hs+2
@@ -62,6 +62,8 @@ data DisplayContext = DisplayContext
62instance DisplayTerminal DisplayContext where
62instance DisplayTerminal DisplayContext where
63 context_region d = context_region (super_display d)
63 context_region d = context_region (super_display d)
64
64
65+ context_color_count d = context_color_count (super_display d)
66+
65 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
67 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
66 serialize_move_cursor d = serialize_move_cursor (super_display d)
68 serialize_move_cursor d = serialize_move_cursor (super_display d)
67
69
test/interactive_terminal_test.hs+3−2
@@ -852,9 +852,10 @@ inline_test_0 = Test
852 , test_action = do
852 , test_action = do
853 t <- terminal_handle
853 t <- terminal_handle
854 d <- display_bounds t >>= display_context t
854 d <- display_bounds t >>= display_context t
855− let image = string ( def_attr `with_back_color` red ) "line 1."
856 putStrLn "line 0."
855 putStrLn "line 0."
857− put_image_ln d image
856+ -- put_attr_change $ back_color red >> style underline
857+ putStrLn "line 1."
858+ -- put_attr_change $ default_all
858 putStrLn "line 2."
859 putStrLn "line 2."
859 release_terminal t
860 release_terminal t
860 return ()
861 return ()