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

c3c652dCorey O'Connor13 years ago

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

compare with master

unifiedsplit

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

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

57 , supports_cursor_visibility :: Bool

58 , 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

60 }

63 }

62data AssumedState = AssumedState

65data AssumedState = AssumedState

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

67initial_assumed_state :: AssumedState

70initial_assumed_state :: AssumedState

68initial_assumed_state = AssumedState Nothing Nothing

71initial_assumed_state = AssumedState Nothing Nothing

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−

97data DisplayContext = DisplayContext

73data DisplayContext = DisplayContext

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

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

99 context_region :: DisplayRegion

75 context_region :: DisplayRegion

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

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

34 hPutStr out_handle str

35 hFlush out_handle

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

37− return $ t

37+ let t' = t

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

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

39− , reserve_display = terminal_app_reserve_display flushed_put

39+ , reserve_display = terminal_app_reserve_display flushed_put

40− , release_display = terminal_app_release_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' }

41− }

44+ }

45+ return t'

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

48-- | 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

38mock_terminal r = liftIO $ do

39 out_ref <- newIORef undefined

40 new_assumed_state_ref <- newIORef initial_assumed_state

41− return $ (,) out_ref $ Terminal

41+ let t = Terminal

42− { terminal_ID = "mock terminal"

42+ { terminal_ID = "mock terminal"

43− , release_terminal = return ()

43+ , release_terminal = return ()

44− , reserve_display = return ()

44+ , reserve_display = return ()

45− , release_display = return ()

45+ , release_display = return ()

46− , display_bounds = return r

46+ , display_bounds = return r

47− , output_byte_buffer = \out_buffer buffer_size -> do

47+ , output_byte_buffer = \out_buffer buffer_size -> do

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

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

49− peekArray (fromEnum buffer_size) out_buffer

49+ peekArray (fromEnum buffer_size) out_buffer

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

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

51− >>= writeIORef out_ref

51+ >>= writeIORef out_ref

52− , context_color_count = 16

52+ , context_color_count = 16

53− , supports_cursor_visibility = True

53+ , supports_cursor_visibility = True

54− , assumed_state_ref = new_assumed_state_ref

54+ , assumed_state_ref = new_assumed_state_ref

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

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

56− { context_region = r

56+ { context_region = r_

57+ , context_device = t

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

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

58− , move_cursor_required_bytes = \_x _y -> 1

59+ , move_cursor_required_bytes = \_x _y -> 1

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

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

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

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

61− return $ ptr `plusPtr` 1

62+ return $ ptr `plusPtr` 1

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

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

63− , show_cursor_required_bytes = 1

64+ , show_cursor_required_bytes = 1

64− , serialize_show_cursor = \ptr -> do

65+ , serialize_show_cursor = \ptr -> do

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

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

66− return $ ptr `plusPtr` 1

67+ return $ ptr `plusPtr` 1

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

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

68− , hide_cursor_required_bytes = 1

69+ , hide_cursor_required_bytes = 1

69− , serialize_hide_cursor = \ptr -> do

70+ , serialize_hide_cursor = \ptr -> do

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

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

71− return $ ptr `plusPtr` 1

72+ return $ ptr `plusPtr` 1

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

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

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

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

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

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

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

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

76− return $ ptr `plusPtr` 1

77+ return $ ptr `plusPtr` 1

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

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

78− , default_attr_required_bytes = 1

79+ , default_attr_required_bytes = 1

79− , serialize_default_attr = \ptr -> do

80+ , serialize_default_attr = \ptr -> do

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

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

81− return $ ptr `plusPtr` 1

82+ return $ ptr `plusPtr` 1

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

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

83− , row_end_required_bytes = 1

84+ , row_end_required_bytes = 1

84− , serialize_row_end = \ptr -> do

85+ , serialize_row_end = \ptr -> do

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

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

86− return $ ptr `plusPtr` 1

87+ return $ ptr `plusPtr` 1

88+ , inline_hack = return ()

89+ }

87 }

90 }

88− }

91+ return (out_ref, t)

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

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

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

79 -}

80reserve_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

82 ti <- Terminfo.setupTerm in_ID

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

84 -- 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

112 <*> require_cap ti "clear"

113 <*> require_cap ti "el"

114 <*> 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)

117 new_assumed_state_ref <- newIORef initial_assumed_state

115 new_assumed_state_ref <- newIORef initial_assumed_state

118− return $ Terminal

116+ let t = Terminal

119− { terminal_ID = in_ID

117+ { terminal_ID = in_ID

120− , release_terminal = liftIO $ do

118+ , release_terminal = liftIO $ do

121− send_cap set_default_attr []

119+ send_cap set_default_attr []

122− maybe_send_cap cnorm []

120+ maybe_send_cap cnorm []

123− hClose out_handle

121+ hClose out_handle

124− , reserve_display = liftIO $ do

122+ , reserve_display = liftIO $ do

125− -- If there is no support for smcup: 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

126− -- home position to approximate the behavior.

124+ -- home position to approximate the behavior.

127− maybe_send_cap smcup []

125+ maybe_send_cap smcup []

128− hFlush out_handle

126+ hFlush out_handle

129− send_cap clear_screen []

127+ send_cap clear_screen []

130− , release_display = liftIO $ do

128+ , release_display = liftIO $ do

131− maybe_send_cap rmcup []

129+ maybe_send_cap rmcup []

132− maybe_send_cap cnorm []

130+ maybe_send_cap cnorm []

133− , display_bounds = do

131+ , display_bounds = do

134− raw_size <- liftIO $ get_window_size

132+ raw_size <- liftIO $ get_window_size

135− case raw_size of

133+ case raw_size of

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

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

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

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

138− , output_byte_buffer = \out_ptr out_byte_count -> do

136+ , output_byte_buffer = \out_ptr out_byte_count -> do

139− hPutBuf out_handle out_ptr (fromEnum out_byte_count)

137+ hPutBuf out_handle out_ptr (fromEnum out_byte_count)

140− hFlush out_handle

138+ hFlush out_handle

141− , context_color_count

139+ , context_color_count

142− = case supports_no_colors terminfo_caps of

140+ = case supports_no_colors terminfo_caps of

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

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

144− Nothing -> 8

142+ Nothing -> 8

145− Just v -> toEnum v

143+ Just v -> toEnum v

146− True -> 1

144+ True -> 1

147− , supports_cursor_visibility = isJust $ civis terminfo_caps

145+ , supports_cursor_visibility = isJust $ civis terminfo_caps

148− , assumed_state_ref = new_assumed_state_ref

146+ , assumed_state_ref = new_assumed_state_ref

149− , mk_display_context = mk_terminfo_display_context terminfo_caps

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

148+ , display_context = liftIO . terminfo_display_context terminfo_caps t

150− }

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

151

153

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

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

153require_cap ti cap_name

155require_cap ti cap_name

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

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

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

190 return (fromIntegral b, fromIntegral a)

192 return (fromIntegral b, fromIntegral a)

191

193

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

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

193−mk_terminfo_display_context terminfo_caps self = do

195+terminfo_display_context terminfo_caps t r = do

194− return $ self

196+ let dc = DisplayContext

197+ { context_region = r

198+ , context_device = t

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

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

196− [toEnum y, toEnum x]

200+ [toEnum y, toEnum x]

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

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

198− [toEnum y, toEnum x]

202+ [toEnum y, toEnum x]

199− out_ptr

203+ out_ptr

200− , show_cursor_required_bytes = case cnorm terminfo_caps of

204+ , show_cursor_required_bytes = case cnorm terminfo_caps of

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

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

202− Just c -> cap_expression_required_bytes c []

206+ Just c -> cap_expression_required_bytes c []

203− , serialize_show_cursor = \out_ptr -> do

207+ , serialize_show_cursor = \out_ptr -> do

204− case cnorm terminfo_caps of

208+ case cnorm terminfo_caps of

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

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

206− Just c -> serialize_cap_expression c [] out_ptr

210+ Just c -> serialize_cap_expression c [] out_ptr

207− , hide_cursor_required_bytes = case civis terminfo_caps of

211+ , hide_cursor_required_bytes = case civis terminfo_caps of

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

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

209− Just c -> cap_expression_required_bytes c []

213+ Just c -> cap_expression_required_bytes c []

210− , serialize_hide_cursor = \out_ptr -> do

214+ , serialize_hide_cursor = \out_ptr -> do

211− case civis terminfo_caps of

215+ case civis terminfo_caps of

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

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

213− Just c -> serialize_cap_expression c [] out_ptr

217+ Just c -> serialize_cap_expression c [] out_ptr

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

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

215− , serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps

219+ , serialize_set_attr = terminfo_serialize_set_attr dc terminfo_caps

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

220+ , 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) []

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

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

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

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

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

224+ , inline_hack = return ()

220− }

225+ }

226+ return dc

221

227

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

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

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

229-- 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

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

30 flushed_put set_utf8_char_set

31 t <- TerminfoBased.reserve_terminal variant' out_handle

32− return $ t

32+ let t' = t

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

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

34− , release_terminal = do

34+ , release_terminal = do

35− liftIO $ flushed_put set_default_char_set

35+ liftIO $ flushed_put set_default_char_set

36− release_terminal t

36+ release_terminal t

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

37+ , display_context = \r -> do

38+ dc <- display_context t r

38− { inline_hack = xterm_inline_hack t

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

39− }

40+ }

40− }

41+ return t'

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

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

43--

44--