c3c652d · vty · git.iko.soy

git.iko.soy/vty

remove the use of mfix. while harder to maintain correctness hunting down all the <<loop>> was not worth it right now

commitc3c652d0bcb0ba1c861d2a01a80871af49ed60bb authorCorey O'Connor <coreyoconnor@gmail.com> dateSat 27 Jul 2013, 16:27 (13 years ago) parent16c7730

5 files changed+144−154

compare with master

unifiedsplit

src/Graphics/Vty/Terminal/Interface.hs+4−28 src/Graphics/Vty/Terminal/MacOSX.hs+9−5 src/Graphics/Vty/Terminal/Mock.hs+50−47 src/Graphics/Vty/Terminal/TerminfoBased.hs+71−65 src/Graphics/Vty/Terminal/XTermColor.hs+10−9

src/Graphics/Vty/Terminal/Interface.hs+4−28

@@ -56,7 +56,10 @@ data Terminal = Terminal

5656 -- | if the cursor can be shown / hidden

5757 , supports_cursor_visibility :: Bool

5858 , assumed_state_ref :: IORef AssumedState

59− , mk_display_context :: DisplayContext -> IO DisplayContext

59+ -- | Acquire display access to the given region of the display.

60+ -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

61+ -- (max display_width provided_width, max display_height provided_height)

62+ , display_context :: MonadIO m => DisplayRegion -> m DisplayContext

6063 }

6164

6265data AssumedState = AssumedState

@@ -67,33 +70,6 @@ data AssumedState = AssumedState

6770initial_assumed_state :: AssumedState

6871initial_assumed_state = AssumedState Nothing Nothing

6972

70−-- | Acquire display access to the given region of the display.

71−-- Currently all regions have the upper left corner of (0,0) and the lower right corner at

72−-- (max display_width provided_width, max display_height provided_height)

73−display_context :: MonadIO m

74− => Terminal

75− -> DisplayRegion

76− -> m DisplayContext

77−display_context t r = liftIO $ do

78− let def_context self = DisplayContext

79− { context_region = r

80− , context_device = t

81− , move_cursor_required_bytes = move_cursor_required_bytes self

82− , serialize_move_cursor = serialize_move_cursor self

83− , show_cursor_required_bytes = show_cursor_required_bytes self

84− , serialize_show_cursor = serialize_show_cursor self

85− , hide_cursor_required_bytes = hide_cursor_required_bytes self

86− , serialize_hide_cursor = serialize_hide_cursor self

87− , attr_required_bytes = attr_required_bytes self

88− , serialize_set_attr = serialize_set_attr self

89− , default_attr_required_bytes = default_attr_required_bytes self

90− , serialize_default_attr = serialize_default_attr self

91− , row_end_required_bytes = row_end_required_bytes self

92− , serialize_row_end = serialize_row_end self

93− , inline_hack = return ()

94− }

95− mfix (mk_display_context t . def_context)

96−

9773data DisplayContext = DisplayContext

9874 { -- | Provide the bounds of the display context.

9975 context_region :: DisplayRegion

src/Graphics/Vty/Terminal/MacOSX.hs+9−5

@@ -34,11 +34,15 @@ reserve_terminal v out_handle = do

3434 hPutStr out_handle str

3535 hFlush out_handle

3636 t <- TerminfoBased.reserve_terminal (remap_term v) out_handle

37− return $ t

38− { terminal_ID = terminal_ID t ++ " (Mac)"

39− , reserve_display = terminal_app_reserve_display flushed_put

40− , release_display = terminal_app_release_display flushed_put

41− }

37+ let t' = t

38+ { terminal_ID = terminal_ID t ++ " (Mac)"

39+ , reserve_display = terminal_app_reserve_display flushed_put

40+ , release_display = terminal_app_release_display flushed_put

41+ , display_context = \r -> do

42+ dc <- display_context t r

43+ return $ dc { context_device = t' }

44+ }

45+ return t'

4246

4347

4448-- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones.

src/Graphics/Vty/Terminal/Mock.hs+50−47

@@ -38,52 +38,55 @@ mock_terminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Ter

3838mock_terminal r = liftIO $ do

3939 out_ref <- newIORef undefined

4040 new_assumed_state_ref <- newIORef initial_assumed_state

41− return $ (,) out_ref $ Terminal

42− { terminal_ID = "mock terminal"

43− , release_terminal = return ()

44− , reserve_display = return ()

45− , release_display = return ()

46− , display_bounds = return r

47− , output_byte_buffer = \out_buffer buffer_size -> do

48− putStrLn $ "mock output_byte_buffer of " ++ show buffer_size ++ " bytes"

49− peekArray (fromEnum buffer_size) out_buffer

50− >>= return . UTF8.fromRep . BS.pack

51− >>= writeIORef out_ref

52− , context_color_count = 16

53− , supports_cursor_visibility = True

54− , assumed_state_ref = new_assumed_state_ref

55− , mk_display_context = \self -> return $ self

56− { context_region = r

57− -- A cursor move is always visualized as the single character 'M'

58− , move_cursor_required_bytes = \_x _y -> 1

59− , serialize_move_cursor = \_x _y ptr -> do

60− poke ptr (toEnum $ fromEnum 'M')

61− return $ ptr `plusPtr` 1

62− -- Show cursor is always visualized as the single character 'S'

63− , show_cursor_required_bytes = 1

64− , serialize_show_cursor = \ptr -> do

65− poke ptr (toEnum $ fromEnum 'S')

66− return $ ptr `plusPtr` 1

67− -- Hide cursor is always visualized as the single character 'H'

68− , hide_cursor_required_bytes = 1

69− , serialize_hide_cursor = \ptr -> do

70− poke ptr (toEnum $ fromEnum 'H')

71− return $ ptr `plusPtr` 1

72− -- An attr change is always visualized as the single character 'A'

73− , attr_required_bytes = \_fattr _diffs _attr -> 1

74− , serialize_set_attr = \_fattr _diffs _attr ptr -> do

75− poke ptr (toEnum $ fromEnum 'A')

76− return $ ptr `plusPtr` 1

77− -- default attr is always visualized as the single character 'D'

78− , default_attr_required_bytes = 1

79− , serialize_default_attr = \ptr -> do

80− poke ptr (toEnum $ fromEnum 'D')

81− return $ ptr `plusPtr` 1

82− -- row end is always visualized as the single character 'E'

83− , row_end_required_bytes = 1

84− , serialize_row_end = \ptr -> do

85− poke ptr (toEnum $ fromEnum 'E')

86− return $ ptr `plusPtr` 1

41+ let t = Terminal

42+ { terminal_ID = "mock terminal"

43+ , release_terminal = return ()

44+ , reserve_display = return ()

45+ , release_display = return ()

46+ , display_bounds = return r

47+ , output_byte_buffer = \out_buffer buffer_size -> do

48+ putStrLn $ "mock output_byte_buffer of " ++ show buffer_size ++ " bytes"

49+ peekArray (fromEnum buffer_size) out_buffer

50+ >>= return . UTF8.fromRep . BS.pack

51+ >>= writeIORef out_ref

52+ , context_color_count = 16

53+ , supports_cursor_visibility = True

54+ , assumed_state_ref = new_assumed_state_ref

55+ , display_context = \r_ -> return $ DisplayContext

56+ { context_region = r_

57+ , context_device = t

58+ -- A cursor move is always visualized as the single character 'M'

59+ , move_cursor_required_bytes = \_x _y -> 1

60+ , serialize_move_cursor = \_x _y ptr -> do

61+ poke ptr (toEnum $ fromEnum 'M')

62+ return $ ptr `plusPtr` 1

63+ -- Show cursor is always visualized as the single character 'S'

64+ , show_cursor_required_bytes = 1

65+ , serialize_show_cursor = \ptr -> do

66+ poke ptr (toEnum $ fromEnum 'S')

67+ return $ ptr `plusPtr` 1

68+ -- Hide cursor is always visualized as the single character 'H'

69+ , hide_cursor_required_bytes = 1

70+ , serialize_hide_cursor = \ptr -> do

71+ poke ptr (toEnum $ fromEnum 'H')

72+ return $ ptr `plusPtr` 1

73+ -- An attr change is always visualized as the single character 'A'

74+ , attr_required_bytes = \_fattr _diffs _attr -> 1

75+ , serialize_set_attr = \_fattr _diffs _attr ptr -> do

76+ poke ptr (toEnum $ fromEnum 'A')

77+ return $ ptr `plusPtr` 1

78+ -- default attr is always visualized as the single character 'D'

79+ , default_attr_required_bytes = 1

80+ , serialize_default_attr = \ptr -> do

81+ poke ptr (toEnum $ fromEnum 'D')

82+ return $ ptr `plusPtr` 1

83+ -- row end is always visualized as the single character 'E'

84+ , row_end_required_bytes = 1

85+ , serialize_row_end = \ptr -> do

86+ poke ptr (toEnum $ fromEnum 'E')

87+ return $ ptr `plusPtr` 1

88+ , inline_hack = return ()

89+ }

8790 }

88− }

91+ return (out_ref, t)

8992

src/Graphics/Vty/Terminal/TerminfoBased.hs+71−65

@@ -78,7 +78,7 @@ send_cap_to_terminal t cap cap_params = do

7878 - should be used instead of the generic "sgr" string capability.

7979 -}

8080reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Terminal

81−reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do

81+reserve_terminal in_ID out_handle = liftIO $ do

8282 ti <- Terminfo.setupTerm in_ID

8383 -- assumes set foreground always implies set background exists.

8484 -- if set foreground is not set then all color changing style attributes are filtered.

@@ -112,42 +112,44 @@ reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do

112112 <*> require_cap ti "clear"

113113 <*> require_cap ti "el"

114114 <*> current_display_attr_caps ti

115− let send_cap s = send_cap_to_terminal self (s terminfo_caps)

116− maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)

117115 new_assumed_state_ref <- newIORef initial_assumed_state

118− return $ Terminal

119− { terminal_ID = in_ID

120− , release_terminal = liftIO $ do

121− send_cap set_default_attr []

122− maybe_send_cap cnorm []

123− hClose out_handle

124− , reserve_display = liftIO $ do

125− -- If there is no support for smcup: Clear the screen and then move the mouse to the

126− -- home position to approximate the behavior.

127− maybe_send_cap smcup []

128− hFlush out_handle

129− send_cap clear_screen []

130− , release_display = liftIO $ do

131− maybe_send_cap rmcup []

132− maybe_send_cap cnorm []

133− , display_bounds = do

134− raw_size <- liftIO $ get_window_size

135− case raw_size of

136− (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size

137− | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)

138− , output_byte_buffer = \out_ptr out_byte_count -> do

139− hPutBuf out_handle out_ptr (fromEnum out_byte_count)

140− hFlush out_handle

141− , context_color_count

142− = case supports_no_colors terminfo_caps of

143− False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

144− Nothing -> 8

145− Just v -> toEnum v

146− True -> 1

147− , supports_cursor_visibility = isJust $ civis terminfo_caps

148− , assumed_state_ref = new_assumed_state_ref

149− , mk_display_context = mk_terminfo_display_context terminfo_caps

150− }

116+ let t = Terminal

117+ { terminal_ID = in_ID

118+ , release_terminal = liftIO $ do

119+ send_cap set_default_attr []

120+ maybe_send_cap cnorm []

121+ hClose out_handle

122+ , reserve_display = liftIO $ do

123+ -- If there is no support for smcup: Clear the screen and then move the mouse to the

124+ -- home position to approximate the behavior.

125+ maybe_send_cap smcup []

126+ hFlush out_handle

127+ send_cap clear_screen []

128+ , release_display = liftIO $ do

129+ maybe_send_cap rmcup []

130+ maybe_send_cap cnorm []

131+ , display_bounds = do

132+ raw_size <- liftIO $ get_window_size

133+ case raw_size of

134+ (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size

135+ | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)

136+ , output_byte_buffer = \out_ptr out_byte_count -> do

137+ hPutBuf out_handle out_ptr (fromEnum out_byte_count)

138+ hFlush out_handle

139+ , context_color_count

140+ = case supports_no_colors terminfo_caps of

141+ False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

142+ Nothing -> 8

143+ Just v -> toEnum v

144+ True -> 1

145+ , supports_cursor_visibility = isJust $ civis terminfo_caps

146+ , assumed_state_ref = new_assumed_state_ref

147+ -- would be better to use fix, but I'm having issues avoiding <<loop>>

148+ , display_context = liftIO . terminfo_display_context terminfo_caps t

149+ }

150+ send_cap s = send_cap_to_terminal t (s terminfo_caps)

151+ maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)

152+ return t

151153

152154require_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression

153155require_cap ti cap_name

@@ -189,35 +191,39 @@ get_window_size = do

189191 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size

190192 return (fromIntegral b, fromIntegral a)

191193

192−mk_terminfo_display_context :: TerminfoCaps -> DisplayContext -> IO DisplayContext

193−mk_terminfo_display_context terminfo_caps self = do

194− return $ self

195− { move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)

196− [toEnum y, toEnum x]

197− , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)

198− [toEnum y, toEnum x]

199− out_ptr

200− , show_cursor_required_bytes = case cnorm terminfo_caps of

201− Nothing -> error "this terminal does not support show cursor"

202− Just c -> cap_expression_required_bytes c []

203− , serialize_show_cursor = \out_ptr -> do

204− case cnorm terminfo_caps of

205− Nothing -> fail "this terminal does not support show cursor"

206− Just c -> serialize_cap_expression c [] out_ptr

207− , hide_cursor_required_bytes = case civis terminfo_caps of

208− Nothing -> error "this terminal does not support hide cursor"

209− Just c -> cap_expression_required_bytes c []

210− , serialize_hide_cursor = \out_ptr -> do

211− case civis terminfo_caps of

212− Nothing -> fail "this terminal does not support hide cursor"

213− Just c -> serialize_cap_expression c [] out_ptr

214− , attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes

215− , serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps

216− , default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []

217− , serialize_default_attr = serialize_cap_expression (set_default_attr terminfo_caps) []

218− , row_end_required_bytes = cap_expression_required_bytes (clear_eol terminfo_caps) []

219− , serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []

220− }

194+terminfo_display_context :: TerminfoCaps -> Terminal -> DisplayRegion -> IO DisplayContext

195+terminfo_display_context terminfo_caps t r = do

196+ let dc = DisplayContext

197+ { context_region = r

198+ , context_device = t

199+ , move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)

200+ [toEnum y, toEnum x]

201+ , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)

202+ [toEnum y, toEnum x]

203+ out_ptr

204+ , show_cursor_required_bytes = case cnorm terminfo_caps of

205+ Nothing -> error "this terminal does not support show cursor"

206+ Just c -> cap_expression_required_bytes c []

207+ , serialize_show_cursor = \out_ptr -> do

208+ case cnorm terminfo_caps of

209+ Nothing -> fail "this terminal does not support show cursor"

210+ Just c -> serialize_cap_expression c [] out_ptr

211+ , hide_cursor_required_bytes = case civis terminfo_caps of

212+ Nothing -> error "this terminal does not support hide cursor"

213+ Just c -> cap_expression_required_bytes c []

214+ , serialize_hide_cursor = \out_ptr -> do

215+ case civis terminfo_caps of

216+ Nothing -> fail "this terminal does not support hide cursor"

217+ Just c -> serialize_cap_expression c [] out_ptr

218+ , attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes

219+ , serialize_set_attr = terminfo_serialize_set_attr dc terminfo_caps

220+ , default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []

221+ , serialize_default_attr = serialize_cap_expression (set_default_attr terminfo_caps) []

222+ , row_end_required_bytes = cap_expression_required_bytes (clear_eol terminfo_caps) []

223+ , serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []

224+ , inline_hack = return ()

225+ }

226+ return dc

221227

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

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

src/Graphics/Vty/Terminal/XTermColor.hs+10−9

@@ -29,15 +29,16 @@ reserve_terminal variant out_handle = liftIO $ do

2929 let variant' = if variant == "xterm-color" then "xterm" else variant

3030 flushed_put set_utf8_char_set

3131 t <- TerminfoBased.reserve_terminal variant' out_handle

32− return $ t

33− { terminal_ID = terminal_ID t ++ " (xterm-color)"

34− , release_terminal = do

35− liftIO $ flushed_put set_default_char_set

36− release_terminal t

37− , mk_display_context = \self -> return $ self

38− { inline_hack = xterm_inline_hack t

39− }

40− }

32+ let t' = t

33+ { terminal_ID = terminal_ID t ++ " (xterm-color)"

34+ , release_terminal = do

35+ liftIO $ flushed_put set_default_char_set

36+ release_terminal t

37+ , display_context = \r -> do

38+ dc <- display_context t r

39+ return $ dc { context_device = t', inline_hack = xterm_inline_hack t }

40+ }

41+ return t'

4142

4243-- | These sequences set xterm based terminals to UTF-8 output.

4344--