@@ -1,3 +1,9 @@
1+-- | Terminfo based terminal handling.
3+-- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I
4+-- have easy access to then color support is entirely based of the docs. Probably with some
5+-- assumptions mixed in.
1-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
7-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
2{-# LANGUAGE ForeignFunctionInterface #-}
8{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
@@ -15,7 +21,7 @@ import Graphics.Vty.Terminal.Interface
15import Graphics.Vty.DisplayRegion
21import Graphics.Vty.DisplayRegion
17import Control.Applicative
23import Control.Applicative
18−import Control.Monad ( foldM )
24+import Control.Monad ( foldM, when )
19import Control.Monad.Fix (mfix)
25import Control.Monad.Fix (mfix)
20import Control.Monad.Trans
26import Control.Monad.Trans
@@ -33,8 +39,10 @@ data TerminfoCaps = TerminfoCaps
33 { smcup :: Maybe CapExpression
39 { smcup :: Maybe CapExpression
34 , rmcup :: Maybe CapExpression
40 , rmcup :: Maybe CapExpression
35 , cup :: CapExpression
41 , cup :: CapExpression
36− , cnorm :: CapExpression
42+ , cnorm :: Maybe CapExpression
37− , civis :: CapExpression
43+ , civis :: Maybe CapExpression
44+ , supports_no_colors :: Bool
45+ , use_alt_color_map :: Bool
38 , set_fore_color :: CapExpression
46 , set_fore_color :: CapExpression
39 , set_back_color :: CapExpression
47 , set_back_color :: CapExpression
40 , set_default_attr :: CapExpression
48 , set_default_attr :: CapExpression
@@ -71,39 +79,55 @@ send_cap_to_terminal t cap cap_params = do
71reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Terminal
79reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Terminal
72reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do
80reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do
73 ti <- Terminfo.setupTerm in_ID
81 ti <- Terminfo.setupTerm in_ID
82+ -- assumes set foreground always implies set background exists.
83+ -- if set foreground is not set then all color changing style attributes are filtered.
84+ msetaf <- probe_cap ti "setaf"
85+ msetf <- probe_cap ti "setf"
86+ let (no_colors, use_alt, set_fore_cap)
88+ Just setaf -> (False, False, setaf)
89+ Nothing -> case msetf of
90+ Just setf -> (False, True, setf)
91+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ in_ID)
92+ msetab <- probe_cap ti "setab"
93+ msetb <- probe_cap ti "setb"
96+ Nothing -> case msetb of
98+ Nothing -> error $ "no back color support for terminal " ++ in_ID
74 terminfo_caps <- pure TerminfoCaps
100 terminfo_caps <- pure TerminfoCaps
75 <*> probe_cap ti "smcup"
101 <*> probe_cap ti "smcup"
76 <*> probe_cap ti "rmcup"
102 <*> probe_cap ti "rmcup"
77 <*> require_cap ti "cup"
103 <*> require_cap ti "cup"
78− <*> require_cap ti "cnorm"
104+ <*> probe_cap ti "cnorm"
79− <*> require_cap ti "civis"
105+ <*> probe_cap ti "civis"
80− <*> require_cap ti "setaf"
106+ <*> pure no_colors
81− <*> require_cap ti "setab"
107+ <*> pure use_alt
108+ <*> pure set_fore_cap
109+ <*> pure set_back_cap
82 <*> require_cap ti "sgr0"
110 <*> require_cap ti "sgr0"
83 <*> require_cap ti "clear"
111 <*> require_cap ti "clear"
84 <*> current_display_attr_caps ti
112 <*> current_display_attr_caps ti
85 let send_cap s = send_cap_to_terminal self (s terminfo_caps)
113 let send_cap s = send_cap_to_terminal self (s terminfo_caps)
114+ maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)
86 new_assumed_state_ref <- newIORef initial_assumed_state
115 new_assumed_state_ref <- newIORef initial_assumed_state
87 return $ Terminal
116 return $ Terminal
88 { terminal_ID = in_ID
117 { terminal_ID = in_ID
89 , release_terminal = liftIO $ do
118 , release_terminal = liftIO $ do
90 send_cap set_default_attr []
119 send_cap set_default_attr []
91− send_cap cnorm []
120+ maybe_send_cap cnorm []
92 hClose out_handle
121 hClose out_handle
93 , reserve_display = liftIO $ do
122 , reserve_display = liftIO $ do
94− if (isJust $ smcup terminfo_caps)
95− then send_cap (fromJust . smcup) []
97− -- Screen on OS X does not appear to support smcup?
98− -- To approximate the expected behavior: clear the screen and then move the mouse to the
123+ -- If there is no support for smcup: Clear the screen and then move the mouse to the
99− -- home position.
124+ -- home position to approximate the behavior.
125+ maybe_send_cap smcup []
100 hFlush out_handle
126 hFlush out_handle
101 send_cap clear_screen []
127 send_cap clear_screen []
102 , release_display = liftIO $ do
128 , release_display = liftIO $ do
103− if (isJust $ rmcup terminfo_caps)
129+ maybe_send_cap rmcup []
104− then send_cap (fromJust . rmcup) []
130+ maybe_send_cap cnorm []
107 , display_bounds = do
131 , display_bounds = do
108 raw_size <- liftIO $ get_window_size
132 raw_size <- liftIO $ get_window_size
109 case raw_size of
133 case raw_size of
@@ -112,9 +136,13 @@ reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do
112 , output_byte_buffer = \out_ptr out_byte_count -> do
136 , output_byte_buffer = \out_ptr out_byte_count -> do
113 hPutBuf out_handle out_ptr (fromEnum out_byte_count)
137 hPutBuf out_handle out_ptr (fromEnum out_byte_count)
114 hFlush out_handle
138 hFlush out_handle
139+ , context_color_count
140+ = case supports_no_colors terminfo_caps of
115− , context_color_count = case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
141+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of
116− Nothing -> 8
142+ Nothing -> 8
117− Just v -> toEnum v
143+ Just v -> toEnum v
145+ , supports_cursor_visibility = isJust $ civis terminfo_caps
118 , assumed_state_ref = new_assumed_state_ref
146 , assumed_state_ref = new_assumed_state_ref
119 , mk_display_context = mk_terminfo_display_context terminfo_caps
147 , mk_display_context = mk_terminfo_display_context terminfo_caps
@@ -167,10 +195,20 @@ mk_terminfo_display_context terminfo_caps self = do
167 , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)
195 , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)
168 [toEnum y, toEnum x]
196 [toEnum y, toEnum x]
170− , show_cursor_required_bytes = cap_expression_required_bytes (cnorm terminfo_caps) []
198+ , show_cursor_required_bytes = case cnorm terminfo_caps of
199+ Nothing -> error "this terminal does not support show cursor"
200+ Just c -> cap_expression_required_bytes c []
171− , serialize_show_cursor = \out_ptr -> serialize_cap_expression (cnorm terminfo_caps) [] out_ptr
201+ , serialize_show_cursor = \out_ptr -> do
202+ case cnorm terminfo_caps of
203+ Nothing -> fail "this terminal does not support show cursor"
204+ Just c -> serialize_cap_expression c [] out_ptr
172− , hide_cursor_required_bytes = cap_expression_required_bytes (civis terminfo_caps) []
205+ , hide_cursor_required_bytes = case civis terminfo_caps of
206+ Nothing -> error "this terminal does not support hide cursor"
207+ Just c -> cap_expression_required_bytes c []
173− , serialize_hide_cursor = \out_ptr -> serialize_cap_expression (civis terminfo_caps) [] out_ptr
208+ , serialize_hide_cursor = \out_ptr -> do
209+ case civis terminfo_caps of
210+ Nothing -> fail "this terminal does not support hide cursor"
211+ Just c -> serialize_cap_expression c [] out_ptr
174 , attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes
212 , attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes
175 , serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps
213 , serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps
176 , default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []
214 , default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []
@@ -209,8 +247,11 @@ assumed_attr_required_bytes = 512
210-- This equation implements the above logic.
248-- This equation implements the above logic.
250+-- \todo This assumes the removal of color changes in the display attributes is done as expected
251+-- with no_colors == True. See `limit_attr_for_display`
212-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
253-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I
213− -- haven't measured this or even examined terminal implementations. *shrug*
254+-- haven't measured this or even examined terminal implementations. *shrug*
214terminfo_serialize_set_attr :: DisplayContext
255terminfo_serialize_set_attr :: DisplayContext
215 -> TerminfoCaps
256 -> TerminfoCaps
216 -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer
257 -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer
@@ -264,16 +305,19 @@ terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr =
265 >>= set_colors
306 >>= set_colors
308+ color_map = case use_alt_color_map terminfo_caps of
309+ False -> ansi_color_index
310+ True -> alt_color_index
267 attr = fix_display_attr prev_attr req_attr
311 attr = fix_display_attr prev_attr req_attr
268 set_colors ptr = do
312 set_colors ptr = do
269 ptr' <- case fixed_fore_color attr of
313 ptr' <- case fixed_fore_color attr of
270 Just c -> serialize_cap_expression (set_fore_color terminfo_caps)
314 Just c -> serialize_cap_expression (set_fore_color terminfo_caps)
271− [ toEnum $ ansi_color_index c ]
315+ [ toEnum $ color_map c ]
273 Nothing -> return ptr
317 Nothing -> return ptr
274 ptr'' <- case fixed_back_color attr of
318 ptr'' <- case fixed_back_color attr of
275 Just c -> serialize_cap_expression (set_back_color terminfo_caps)
319 Just c -> serialize_cap_expression (set_back_color terminfo_caps)
276− [ toEnum $ ansi_color_index c ]
320+ [ toEnum $ color_map c ]
278 Nothing -> return ptr'
322 Nothing -> return ptr'
279 return ptr''
323 return ptr''
@@ -283,7 +327,7 @@ terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr =
283 = fail "ColorToDefault is not a possible case for apply_color_diffs"
327 = fail "ColorToDefault is not a possible case for apply_color_diffs"
284 apply_color_diff f ( SetColor c ) ptr
328 apply_color_diff f ( SetColor c ) ptr
285 = serialize_cap_expression (f terminfo_caps)
329 = serialize_cap_expression (f terminfo_caps)
286− [ toEnum $ ansi_color_index c ]
330+ [ toEnum $ color_map c ]
289-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
333-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not
@@ -295,6 +339,22 @@ ansi_color_index :: Color -> Int
295ansi_color_index (ISOColor v) = fromEnum v
339ansi_color_index (ISOColor v) = fromEnum v
296ansi_color_index (Color240 v) = 16 + fromEnum v
340ansi_color_index (Color240 v) = 16 + fromEnum v
342+-- | For terminals without setaf/setab
344+-- See table in `man terminfo`
345+-- Will error if not in table.
346+alt_color_index :: Color -> Int
347+alt_color_index (ISOColor 0) = 0
348+alt_color_index (ISOColor 1) = 4
349+alt_color_index (ISOColor 2) = 2
350+alt_color_index (ISOColor 3) = 6
351+alt_color_index (ISOColor 4) = 1
352+alt_color_index (ISOColor 5) = 5
353+alt_color_index (ISOColor 6) = 3
354+alt_color_index (ISOColor 7) = 7
355+alt_color_index (ISOColor v) = fromEnum v
356+alt_color_index (Color240 v) = 16 + fromEnum v
298{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
358{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
300 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
360 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than