aacb4ab · vty · git.iko.soy

git.iko.soy/vty

Move from MonadIO to IO. Improves results from compiler optimization pass

Ignore-this: 12708b02301c6b170bc1e3dfed569a32 darcs-hash:20100114080327-f0a0d-48666873ef1a5ef44e744cc8dd3ca17600ccf2b4.gz

commitaacb4abe7c35c8cbd05ee1318d67707244039edf authorcoreyoconnor <coreyoconnor@gmail.com> dateThu 14 Jan 2010, 00:03 (17 years ago) parent138ffa2

4 files changed+42−40

compare with master

unifiedsplit

src/Data/Terminfo/Eval.hs+4−2 src/Graphics/Vty/Terminal.hs+3−3 src/Graphics/Vty/Terminal/Generic.hs+5−5 src/Graphics/Vty/Terminal/TerminfoBased.hs+30−30

src/Data/Terminfo/Eval.hs+4−2

@@ -44,6 +44,7 @@ data EvalState = EvalState

4444type EvalT m a = StateT EvalState m a

4545type Eval a = EvalT Identity a

4646

47+{-# SPECIALIZE pop :: EvalT IO CapParam #-}

4748pop :: Monad m => EvalT m CapParam

4849pop = do

4950 s <- get

@@ -52,11 +53,13 @@ pop = do

5253 put s'

5354 return v

5455

56+{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}

5557read_param :: Monad m => Word -> EvalT m CapParam

5658read_param pn = do

5759 EvalState _ _ !params <- get

5860 return $! genericIndex params pn

5961

62+{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}

6063push :: Monad m => CapParam -> EvalT m ()

6164push !v = do

6265 s <- get

@@ -154,8 +157,7 @@ cap_op_required_bytes CompareGt = do

154157 push $ if v_0 > v_1 then 1 else 0

155158 return 0

156159

157−{-# SPECIALIZE serialize_cap_expression :: CapExpression -> [ CapParam ] -> OutputBuffer -> IO OutputBuffer #-}

158−serialize_cap_expression :: MonadIO m => CapExpression -> [CapParam] -> OutputBuffer -> m OutputBuffer

160+serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer

159161serialize_cap_expression cap params out_ptr = do

160162 let params' = apply_param_ops cap params

161163 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 ()

111111set_cursor_pos t x y = do

112112 bounds <- display_bounds t

113113 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)

115115

116116-- | Hides the cursor

117117hide_cursor :: MonadIO m => TerminalHandle -> m ()

118118hide_cursor t = do

119119 bounds <- display_bounds t

120120 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)

122122

123123-- | Shows the cursor

124124show_cursor :: MonadIO m => TerminalHandle -> m ()

125125show_cursor t = do

126126 bounds <- display_bounds t

127127 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)

129129

src/Graphics/Vty/Terminal/Generic.hs+5−5

@@ -81,7 +81,7 @@ class Terminal t where

8181

8282 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to

8383 -- end_ptr - start_ptr

84− output_byte_buffer :: MonadIO m => t -> OutputBuffer -> Word -> m ()

84+ output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()

8585

8686instance Terminal TerminalHandle where

8787 terminal_ID (TerminalHandle t _) = terminal_ID t

@@ -332,10 +332,10 @@ serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do

332332 out_ptr' <- serialize_utf8_text str out_ptr

333333 return (out_ptr', fattr)

334334

335−marshall_to_terminal :: ( MonadIO m, Terminal t )

336− => t -> Word -> (Ptr Word8 -> m (Ptr Word8)) -> m ()

335+marshall_to_terminal :: ( Terminal t )

336+ => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()

337337marshall_to_terminal t c f = do

338− start_ptr <- liftIO $ mallocBytes (fromEnum c)

338+ start_ptr <- mallocBytes (fromEnum c)

339339 --

340340 -- todo: capture exceptions?

341341 end_ptr <- f start_ptr

@@ -343,7 +343,7 @@ marshall_to_terminal t c f = do

343343 count | count < 0 -> fail "End pointer before start pointer."

344344 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)

345345 | otherwise -> output_byte_buffer t start_ptr (toEnum count)

346− liftIO $ free start_ptr

346+ free start_ptr

347347 return ()

348348

349349data CursorOutputMap = CursorOutputMap

src/Graphics/Vty/Terminal/TerminfoBased.hs+30−30

@@ -53,7 +53,7 @@ data DisplayAttrCaps = DisplayAttrCaps

5353 , enter_bold_mode :: Maybe CapExpression

5454 }

5555

56−marshall_cap_to_terminal :: MonadIO m => Term -> (Term -> CapExpression) -> [CapParam] -> m ()

56+marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()

5757marshall_cap_to_terminal t cap_selector cap_params = do

5858 marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )

5959 ( serialize_cap_expression (cap_selector t) cap_params )

@@ -128,25 +128,25 @@ instance Terminal Term where

128128 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"

129129

130130 release_terminal t = do

131− marshall_cap_to_terminal t set_default_attr []

132− marshall_cap_to_terminal t cnorm []

131+ liftIO $ marshall_cap_to_terminal t set_default_attr []

132+ liftIO $ marshall_cap_to_terminal t cnorm []

133133 return ()

134134

135135 reserve_display t = do

136136 if (isJust $ smcup t)

137− then marshall_cap_to_terminal t (fromJust . smcup) []

137+ then liftIO $ marshall_cap_to_terminal t (fromJust . smcup) []

138138 else return ()

139139 -- Screen on OS X does not appear to support smcup?

140140 -- To approximate the expected behavior: clear the screen and then move the mouse to the

141141 -- home position.

142− marshall_cap_to_terminal t clear_screen []

142+ liftIO $ marshall_cap_to_terminal t clear_screen []

143143 return ()

144144

145145 release_display t = do

146146 if (isJust $ rmcup t)

147− then marshall_cap_to_terminal t (fromJust . rmcup) []

147+ then liftIO $ marshall_cap_to_terminal t (fromJust . rmcup) []

148148 else return ()

149− marshall_cap_to_terminal t cnorm []

149+ liftIO $ marshall_cap_to_terminal t cnorm []

150150 return ()

151151

152152 display_terminal_instance t b c = do

@@ -166,8 +166,8 @@ instance Terminal Term where

166166 output_byte_buffer _t out_ptr out_byte_count = do

167167 if out_byte_count == 0

168168 then return ()

169− else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)

170− liftIO $ hFlush stdout

169+ else hPutBuf stdout out_ptr (fromEnum out_byte_count)

170+ hFlush stdout

171171

172172foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong

173173

@@ -190,17 +190,17 @@ instance DisplayTerminal DisplayContext where

190190 move_cursor_required_bytes d x y

191191 = cap_expression_required_bytes (cup $ term d) [y, x]

192192 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

194194

195195 show_cursor_required_bytes d

196196 = cap_expression_required_bytes (cnorm $ term d) []

197197 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

199199

200200 hide_cursor_required_bytes d

201201 = cap_expression_required_bytes (civis $ term d) []

202202 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

204204

205205 -- Instead of evaluating all the rules related to setting display attributes twice (once in

206206 -- required bytes and again in serialize) or some memoization scheme just return a size

@@ -242,16 +242,16 @@ instance DisplayTerminal DisplayContext where

242242 EnterExitSeq caps

243243 -- only way to reset a color to the defaults

244244 -> 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)

246246 >>= set_colors

247247 SetState state

248248 -- implicitly resets the colors to the defaults

249− -> serialize_cap_expression ( fromJust $ set_attr_states

249+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

250250 $ display_attr_caps

251251 $ term d

252− )

253− ( sgr_args_for_state state )

254− out_ptr

252+ )

253+ ( sgr_args_for_state state )

254+ out_ptr

255255 >>= set_colors

256256 -- Otherwise the display colors are not changing or changing between two non-default

257257 -- points.

@@ -268,28 +268,28 @@ instance DisplayTerminal DisplayContext where

268268 -- Changes the style and color states according to the differences with the

269269 -- currently applied states.

270270 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 )

272272 >>= apply_color_diff set_fore_color ( fore_color_diff diffs )

273273 >>= apply_color_diff set_back_color ( back_color_diff diffs )

274274 SetState state

275275 -- implicitly resets the colors to the defaults

276− -> serialize_cap_expression ( fromJust $ set_attr_states

277− $ display_attr_caps

278− $ term d

279− )

280− ( sgr_args_for_state state )

281− out_ptr

276+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

277+ $ display_attr_caps

278+ $ term d

279+ )

280+ ( sgr_args_for_state state )

281+ out_ptr

282282 >>= set_colors

283283 where

284284 attr = fix_display_attr prev_attr req_attr

285285 set_colors ptr = do

286286 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 )

288288 [ ansi_color_index c ]

289289 ptr

290290 Nothing -> return ptr

291291 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 )

293293 [ ansi_color_index c ]

294294 ptr'

295295 Nothing -> return ptr'

@@ -299,14 +299,14 @@ instance DisplayTerminal DisplayContext where

299299 apply_color_diff _f ColorToDefault _ptr

300300 = fail "ColorToDefault is not a possible case for apply_color_diffs"

301301 apply_color_diff f ( SetColor c ) ptr

302− = serialize_cap_expression ( f $ term d )

303− [ ansi_color_index c ]

304− ptr

302+ = liftIO $ serialize_cap_expression ( f $ term d )

303+ [ ansi_color_index c ]

304+ ptr

305305

306306 default_attr_required_bytes d

307307 = cap_expression_required_bytes (set_default_attr $ term d) []

308308 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

310310

311311ansi_color_index :: Color -> Word

312312ansi_color_index (ISOColor v) = toEnum $ fromEnum v