git.iko.soy/vty
on master help sign in
Move from MonadIO to IO. Improves results from compiler optimization pass
aacb4abcoreyoconnor
src/Data/Terminfo/Eval.hs+4−2
compare with master
unifiedsplit
@@ -44,6 +44,7 @@ data EvalState = EvalState
44type EvalT m a = StateT EvalState m a
44type EvalT m a = StateT EvalState m a
45type Eval a = EvalT Identity a
45type Eval a = EvalT Identity a
46
46
47+{-# SPECIALIZE pop :: EvalT IO CapParam #-}
47pop :: Monad m => EvalT m CapParam
48pop :: Monad m => EvalT m CapParam
48pop = do
49pop = do
49 s <- get
50 s <- get
@@ -52,11 +53,13 @@ pop = do
52 put s'
53 put s'
53 return v
54 return v
54
55
56+{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}
55read_param :: Monad m => Word -> EvalT m CapParam
57read_param :: Monad m => Word -> EvalT m CapParam
56read_param pn = do
58read_param pn = do
57 EvalState _ _ !params <- get
59 EvalState _ _ !params <- get
58 return $! genericIndex params pn
60 return $! genericIndex params pn
59
61
62+{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}
60push :: Monad m => CapParam -> EvalT m ()
63push :: Monad m => CapParam -> EvalT m ()
61push !v = do
64push !v = do
62 s <- get
65 s <- get
@@ -154,8 +157,7 @@ cap_op_required_bytes CompareGt = do
154 push $ if v_0 > v_1 then 1 else 0
157 push $ if v_0 > v_1 then 1 else 0
155 return 0
158 return 0
156
159
157−{-# SPECIALIZE serialize_cap_expression :: CapExpression -> [ CapParam ] -> OutputBuffer -> IO OutputBuffer #-}
160+serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer
158−serialize_cap_expression :: MonadIO m => CapExpression -> [CapParam] -> OutputBuffer -> m OutputBuffer
159serialize_cap_expression cap params out_ptr = do
161serialize_cap_expression cap params out_ptr = do
160 let params' = apply_param_ops cap params
162 let params' = apply_param_ops cap params
161 s_0 = EvalState [] cap params'
163 s_0 = EvalState [] cap params'
src/Graphics/Vty/Terminal.hs+3−3
@@ -111,19 +111,19 @@ set_cursor_pos :: MonadIO m => TerminalHandle -> Word -> Word -> m ()
111set_cursor_pos t x y = do
111set_cursor_pos t x y = do
112 bounds <- display_bounds t
112 bounds <- display_bounds t
113 d <- display_context t bounds
113 d <- display_context t bounds
114− marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)
114+ liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)
115
115
116-- | Hides the cursor
116-- | Hides the cursor
117hide_cursor :: MonadIO m => TerminalHandle -> m ()
117hide_cursor :: MonadIO m => TerminalHandle -> m ()
118hide_cursor t = do
118hide_cursor t = do
119 bounds <- display_bounds t
119 bounds <- display_bounds t
120 d <- display_context t bounds
120 d <- display_context t bounds
121− marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)
121+ liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)
122
122
123-- | Shows the cursor
123-- | Shows the cursor
124show_cursor :: MonadIO m => TerminalHandle -> m ()
124show_cursor :: MonadIO m => TerminalHandle -> m ()
125show_cursor t = do
125show_cursor t = do
126 bounds <- display_bounds t
126 bounds <- display_bounds t
127 d <- display_context t bounds
127 d <- display_context t bounds
128− marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d)
128+ liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d)
129
129
src/Graphics/Vty/Terminal/Generic.hs+5−5
@@ -81,7 +81,7 @@ class Terminal t where
81
81
82 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
82 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
83 -- end_ptr - start_ptr
83 -- end_ptr - start_ptr
84− output_byte_buffer :: MonadIO m => t -> OutputBuffer -> Word -> m ()
84+ output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()
85
85
86instance Terminal TerminalHandle where
86instance Terminal TerminalHandle where
87 terminal_ID (TerminalHandle t _) = terminal_ID t
87 terminal_ID (TerminalHandle t _) = terminal_ID t
@@ -332,10 +332,10 @@ serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
332 out_ptr' <- serialize_utf8_text str out_ptr
332 out_ptr' <- serialize_utf8_text str out_ptr
333 return (out_ptr', fattr)
333 return (out_ptr', fattr)
334
334
335−marshall_to_terminal :: ( MonadIO m, Terminal t )
335+marshall_to_terminal :: ( Terminal t )
336− => t -> Word -> (Ptr Word8 -> m (Ptr Word8)) -> m ()
336+ => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
337marshall_to_terminal t c f = do
337marshall_to_terminal t c f = do
338− start_ptr <- liftIO $ mallocBytes (fromEnum c)
338+ start_ptr <- mallocBytes (fromEnum c)
339 --
339 --
340 -- todo: capture exceptions?
340 -- todo: capture exceptions?
341 end_ptr <- f start_ptr
341 end_ptr <- f start_ptr
@@ -343,7 +343,7 @@ marshall_to_terminal t c f = do
343 count | count < 0 -> fail "End pointer before start pointer."
343 count | count < 0 -> fail "End pointer before start pointer."
344 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
344 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
345 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
345 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
346− liftIO $ free start_ptr
346+ free start_ptr
347 return ()
347 return ()
348
348
349data CursorOutputMap = CursorOutputMap
349data CursorOutputMap = CursorOutputMap
src/Graphics/Vty/Terminal/TerminfoBased.hs+30−30
@@ -53,7 +53,7 @@ data DisplayAttrCaps = DisplayAttrCaps
53 , enter_bold_mode :: Maybe CapExpression
53 , enter_bold_mode :: Maybe CapExpression
54 }
54 }
55
55
56−marshall_cap_to_terminal :: MonadIO m => Term -> (Term -> CapExpression) -> [CapParam] -> m ()
56+marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
57marshall_cap_to_terminal t cap_selector cap_params = do
57marshall_cap_to_terminal t cap_selector cap_params = do
58 marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )
58 marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )
59 ( serialize_cap_expression (cap_selector t) cap_params )
59 ( serialize_cap_expression (cap_selector t) cap_params )
@@ -128,25 +128,25 @@ instance Terminal Term where
128 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
128 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
129
129
130 release_terminal t = do
130 release_terminal t = do
131− marshall_cap_to_terminal t set_default_attr []
131+ liftIO $ marshall_cap_to_terminal t set_default_attr []
132− marshall_cap_to_terminal t cnorm []
132+ liftIO $ marshall_cap_to_terminal t cnorm []
133 return ()
133 return ()
134
134
135 reserve_display t = do
135 reserve_display t = do
136 if (isJust $ smcup t)
136 if (isJust $ smcup t)
137− then marshall_cap_to_terminal t (fromJust . smcup) []
137+ then liftIO $ marshall_cap_to_terminal t (fromJust . smcup) []
138 else return ()
138 else return ()
139 -- Screen on OS X does not appear to support smcup?
139 -- Screen on OS X does not appear to support smcup?
140 -- To approximate the expected behavior: clear the screen and then move the mouse to the
140 -- To approximate the expected behavior: clear the screen and then move the mouse to the
141 -- home position.
141 -- home position.
142− marshall_cap_to_terminal t clear_screen []
142+ liftIO $ marshall_cap_to_terminal t clear_screen []
143 return ()
143 return ()
144
144
145 release_display t = do
145 release_display t = do
146 if (isJust $ rmcup t)
146 if (isJust $ rmcup t)
147− then marshall_cap_to_terminal t (fromJust . rmcup) []
147+ then liftIO $ marshall_cap_to_terminal t (fromJust . rmcup) []
148 else return ()
148 else return ()
149− marshall_cap_to_terminal t cnorm []
149+ liftIO $ marshall_cap_to_terminal t cnorm []
150 return ()
150 return ()
151
151
152 display_terminal_instance t b c = do
152 display_terminal_instance t b c = do
@@ -166,8 +166,8 @@ instance Terminal Term where
166 output_byte_buffer _t out_ptr out_byte_count = do
166 output_byte_buffer _t out_ptr out_byte_count = do
167 if out_byte_count == 0
167 if out_byte_count == 0
168 then return ()
168 then return ()
169− else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)
169+ else hPutBuf stdout out_ptr (fromEnum out_byte_count)
170− liftIO $ hFlush stdout
170+ hFlush stdout
171
171
172foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
172foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
173
173
@@ -190,17 +190,17 @@ instance DisplayTerminal DisplayContext where
190 move_cursor_required_bytes d x y
190 move_cursor_required_bytes d x y
191 = cap_expression_required_bytes (cup $ term d) [y, x]
191 = cap_expression_required_bytes (cup $ term d) [y, x]
192 serialize_move_cursor d x y out_ptr
192 serialize_move_cursor d x y out_ptr
193− = serialize_cap_expression (cup $ term d) [y, x] out_ptr
193+ = liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr
194
194
195 show_cursor_required_bytes d
195 show_cursor_required_bytes d
196 = cap_expression_required_bytes (cnorm $ term d) []
196 = cap_expression_required_bytes (cnorm $ term d) []
197 serialize_show_cursor d out_ptr
197 serialize_show_cursor d out_ptr
198− = serialize_cap_expression (cnorm $ term d) [] out_ptr
198+ = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr
199
199
200 hide_cursor_required_bytes d
200 hide_cursor_required_bytes d
201 = cap_expression_required_bytes (civis $ term d) []
201 = cap_expression_required_bytes (civis $ term d) []
202 serialize_hide_cursor d out_ptr
202 serialize_hide_cursor d out_ptr
203− = serialize_cap_expression (civis $ term d) [] out_ptr
203+ = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr
204
204
205 -- Instead of evaluating all the rules related to setting display attributes twice (once in
205 -- Instead of evaluating all the rules related to setting display attributes twice (once in
206 -- required bytes and again in serialize) or some memoization scheme just return a size
206 -- required bytes and again in serialize) or some memoization scheme just return a size
@@ -242,16 +242,16 @@ instance DisplayTerminal DisplayContext where
242 EnterExitSeq caps
242 EnterExitSeq caps
243 -- only way to reset a color to the defaults
243 -- only way to reset a color to the defaults
244 -> serialize_default_attr d out_ptr
244 -> serialize_default_attr d out_ptr
245− >>= (\out_ptr' -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)
245+ >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)
246 >>= set_colors
246 >>= set_colors
247 SetState state
247 SetState state
248 -- implicitly resets the colors to the defaults
248 -- implicitly resets the colors to the defaults
249− -> serialize_cap_expression ( fromJust $ set_attr_states
249+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states
250 $ display_attr_caps
250 $ display_attr_caps
251 $ term d
251 $ term d
252− )
252+ )
253− ( sgr_args_for_state state )
253+ ( sgr_args_for_state state )
254− out_ptr
254+ out_ptr
255 >>= set_colors
255 >>= set_colors
256 -- Otherwise the display colors are not changing or changing between two non-default
256 -- Otherwise the display colors are not changing or changing between two non-default
257 -- points.
257 -- points.
@@ -268,28 +268,28 @@ instance DisplayTerminal DisplayContext where
268 -- Changes the style and color states according to the differences with the
268 -- Changes the style and color states according to the differences with the
269 -- currently applied states.
269 -- currently applied states.
270 EnterExitSeq caps
270 EnterExitSeq caps
271− -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps
271+ -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps )
272 >>= apply_color_diff set_fore_color ( fore_color_diff diffs )
272 >>= apply_color_diff set_fore_color ( fore_color_diff diffs )
273 >>= apply_color_diff set_back_color ( back_color_diff diffs )
273 >>= apply_color_diff set_back_color ( back_color_diff diffs )
274 SetState state
274 SetState state
275 -- implicitly resets the colors to the defaults
275 -- implicitly resets the colors to the defaults
276− -> serialize_cap_expression ( fromJust $ set_attr_states
276+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states
277− $ display_attr_caps
277+ $ display_attr_caps
278− $ term d
278+ $ term d
279− )
279+ )
280− ( sgr_args_for_state state )
280+ ( sgr_args_for_state state )
281− out_ptr
281+ out_ptr
282 >>= set_colors
282 >>= set_colors
283 where
283 where
284 attr = fix_display_attr prev_attr req_attr
284 attr = fix_display_attr prev_attr req_attr
285 set_colors ptr = do
285 set_colors ptr = do
286 ptr' <- case fixed_fore_color attr of
286 ptr' <- case fixed_fore_color attr of
287− Just c -> serialize_cap_expression ( set_fore_color $ term d )
287+ Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d )
288 [ ansi_color_index c ]
288 [ ansi_color_index c ]
289 ptr
289 ptr
290 Nothing -> return ptr
290 Nothing -> return ptr
291 ptr'' <- case fixed_back_color attr of
291 ptr'' <- case fixed_back_color attr of
292− Just c -> serialize_cap_expression ( set_back_color $ term d )
292+ Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d )
293 [ ansi_color_index c ]
293 [ ansi_color_index c ]
294 ptr'
294 ptr'
295 Nothing -> return ptr'
295 Nothing -> return ptr'
@@ -299,14 +299,14 @@ instance DisplayTerminal DisplayContext where
299 apply_color_diff _f ColorToDefault _ptr
299 apply_color_diff _f ColorToDefault _ptr
300 = fail "ColorToDefault is not a possible case for apply_color_diffs"
300 = fail "ColorToDefault is not a possible case for apply_color_diffs"
301 apply_color_diff f ( SetColor c ) ptr
301 apply_color_diff f ( SetColor c ) ptr
302− = serialize_cap_expression ( f $ term d )
302+ = liftIO $ serialize_cap_expression ( f $ term d )
303− [ ansi_color_index c ]
303+ [ ansi_color_index c ]
304− ptr
304+ ptr
305
305
306 default_attr_required_bytes d
306 default_attr_required_bytes d
307 = cap_expression_required_bytes (set_default_attr $ term d) []
307 = cap_expression_required_bytes (set_default_attr $ term d) []
308 serialize_default_attr d out_ptr = do
308 serialize_default_attr d out_ptr = do
309− serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr
309+ liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr
310
310
311ansi_color_index :: Color -> Word
311ansi_color_index :: Color -> Word
312ansi_color_index (ISOColor v) = toEnum $ fromEnum v
312ansi_color_index (ISOColor v) = toEnum $ fromEnum v