fd3df90 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

Move from a typeclass to a structure of properties interface for terminals and display contexts.

fd3df90Corey O'Connor13 years ago

README.md+8−7

compare with master

unifiedsplit

@@ -59,10 +59,11 @@ None!

60## Coverage

62−On my system the hpc coverage mix file receives a bad hash when using template haskell. This means

62+Profiling appears to cause issues with coverage when enabled. To evaluate coverage configure as

63−Graphics.Vty.Span needs to have the hash value fixed after being re-generated. I just pull the

63+follows:

64−expected hash from the first tix file that fails. The error message is unhelpful:

64+

65−

65+~~~

66−hpc: can not find vty-5.0.0/Graphics.Vty.Span in ["./dist/hpc/mix/vty-5.0.0"]

66+cabal configure --enable-tests --enable-library-coverage \

67−

67+ --disable-library-profiling \

68−which is incorrect: The file can be found but the hash is incorrect.

68+ --disable-executable-profiling

69+~~~

src/Graphics/Vty.hs+11−11

@@ -44,7 +44,7 @@ data Vty = Vty

44 update :: Picture -> IO ()

45 -- | Get one Event object, blocking if necessary.

46 , next_event :: IO Event

47− -- | Handle to the terminal interface. See `Terminal`

47+ -- | The terminal device interface. See `Interface`

48 --

49 -- The use of Vty typically follows this process:

50 --

@@ -60,7 +60,7 @@ data Vty = Vty

60 -- input backend for implementation.

61 --

62 -- todo: remove explicit `shutdown` requirement.

63− , terminal :: TerminalHandle

63+ , terminal :: Terminal

64 -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some

65 -- other program might output to the terminal and mess the display. In that case the user

66 -- might want to force a refresh.

@@ -81,12 +81,12 @@ mkVty = mkVtyEscDelay 0

81mkVtyEscDelay :: Int -> IO Vty

82mkVtyEscDelay escDelay = do

83 term_info <- Terminfo.setupTermFromEnv

84− t <- terminal_handle

84+ t <- current_terminal

85 reserve_display t

86 (kvar, endi) <- initTermInput escDelay term_info

87− intMkVty kvar ( endi >> release_display t >> release_terminal t ) t

87+ intMkVty kvar ( endi >> release_display t >> release_device t ) t

89−intMkVty :: IO Event -> IO () -> TerminalHandle -> IO Vty

89+intMkVty :: IO Event -> IO () -> Terminal -> IO Vty

90intMkVty kvar fend t = do

91 last_pic_ref <- newIORef Nothing

92 last_update_ref <- newIORef Nothing

@@ -111,15 +111,15 @@ intMkVty kvar fend t = do

111 mlast_update <- readIORef last_update_ref

112 update_data <- case mlast_update of

113 Nothing -> do

114− d <- display_context t b

114+ dc <- display_context t b

115− output_picture d in_pic'

115+ output_picture dc in_pic'

116− return (b, d)

116+ return (b, dc)

117 Just (last_bounds, last_context) -> do

118 if b /= last_bounds

119 then do

120− d <- display_context t b

120+ dc <- display_context t b

121− output_picture d in_pic'

121+ output_picture dc in_pic'

122− return (b, d)

122+ return (b, dc)

123 else do

124 output_picture last_context in_pic'

125 return (b, last_context)

src/Graphics/Vty/Inline.hs+33−18

@@ -9,15 +9,13 @@

9-- text \" Styled! \" drawn over a red background and underlined.

10--

11-- @

12−-- t <- terminal_handle

13-- putStr \"Not styled. \"

12-- putStr \"Not styled. \"

14−-- put_attr_change t $ do

13+-- put_attr_change_ $ do

15-- back_color red

14-- back_color red

16-- apply_style underline

15-- apply_style underline

17-- putStr \" Styled! \"

16-- putStr \" Styled! \"

18−-- put_attr_change t $ default_all

17+-- put_attr_change_ $ default_all

19-- putStrLn \"Not styled.\"

18-- putStrLn \"Not styled.\"

20−-- release_terminal t

21-- @

19-- @

22--

20--

23-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate

21-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate

@@ -33,7 +31,9 @@ module Graphics.Vty.Inline ( module Graphics.Vty.Inline

34import Graphics.Vty.Attributes

32import Graphics.Vty.Attributes

35import Graphics.Vty.DisplayAttributes

33import Graphics.Vty.DisplayAttributes

34+import Graphics.Vty.Inline.Hack

36import Graphics.Vty.Terminal.Interface

35import Graphics.Vty.Terminal.Interface

36+import Graphics.Vty.Terminal

38import Control.Applicative

39import Control.Monad.State.Strict

@@ -76,27 +76,42 @@ remove_style s_mask = modify $ \attr ->

76default_all :: InlineM ()

77default_all = put def_attr

79−-- | Apply the provided display attribute changes to the terminal.

79+-- | Apply the provided display attribute changes to the given terminal.

80--

81−-- This also flushes the 'stdout' handle.

81+-- This does not flush the terminal.

82−put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m ()

82+put_attr_change :: ( Applicative m, MonadIO m ) => Terminal -> InlineM () -> m ()

83−put_attr_change t c = do

83+put_attr_change t c = liftIO $ do

84 bounds <- display_bounds t

85− d <- display_context t bounds

85+ dc <- display_context t bounds

86− mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )

86+ mfattr <- prev_fattr <$> readIORef (assumed_state_ref t)

87 fattr <- case mfattr of

88 Nothing -> do

89− liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d)

89+ liftIO $ send_to_terminal t (default_attr_required_bytes dc) (serialize_default_attr dc)

90 return $ FixedAttr default_style_mask Nothing Nothing

91 Just v -> return v

92 let attr = execState c current_attr

93− attr' = limit_attr_for_display d attr

93+ attr' = limit_attr_for_display t attr

94 fattr' = fix_display_attr fattr attr'

95 diffs = display_attr_diffs fattr fattr'

96− liftIO $ hFlush stdout

97− liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )

96+ send_to_terminal t (attr_required_bytes dc fattr attr' diffs)

98− ( serialize_set_attr d fattr attr' diffs )

97+ (serialize_set_attr dc fattr attr' diffs)

99− liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }

98+ modifyIORef (assumed_state_ref t) $ \s -> s { prev_fattr = Just fattr' }

100− inline_hack d

99+ inline_hack dc

100+

101+-- | Apply the provided display attributes changes to the terminal that was current at the time this

102+-- was first used. Which, for most use cases, is the current terminal.

103+--

104+-- This will flush the terminal output.

105+put_attr_change_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()

106+put_attr_change_ c = liftIO $ do

107+ mt <- readIORef global_vty_terminal

108+ t <- case mt of

109+ Nothing -> do

110+ t <- current_terminal

111+ writeIORef global_vty_terminal (Just t)

112+ return t

113+ Just t -> return t

114+ hFlush stdout

115+ put_attr_change t c

101− liftIO $ hFlush stdout

116+ hFlush stdout

102

117

src/Graphics/Vty/Inline/Hack.hsnew file+11

@@ -0,0 +1,11 @@

1+module Graphics.Vty.Inline.Hack where

3+import Graphics.Vty.Terminal.Interface (Terminal)

5+import Data.IORef

7+import System.IO.Unsafe

9+global_vty_terminal :: IORef (Maybe Terminal)

10+{-# NOINLINE global_vty_terminal #-}

11+global_vty_terminal = unsafePerformIO $ newIORef Nothing

src/Graphics/Vty/Terminal.hs+25−21

@@ -20,9 +20,9 @@

21{-# LANGUAGE ScopedTypeVariables #-}

22module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal

23− , Terminal(..)

23+ , Terminal(..) -- \todo hide constructors

24− , TerminalHandle(..)

24+ , AssumedState(..)

25− , DisplayHandle(..)

25+ , DisplayContext(..) -- \todo hide constructors

26 , output_picture

27 , display_context

28 )

@@ -47,7 +47,7 @@ import GHC.IO.Handle

47import System.Environment

48import System.IO

50−-- | Returns a TerminalHandle (an abstract Terminal instance) for the current terminal.

50+-- | Returns a `Terminal` for the current terminal.

51--

52-- The specific Terminal implementation used is hidden from the API user. All terminal

53-- implementations are assumed to perform more, or less, the same. Currently all implementations use

@@ -84,27 +84,31 @@ import System.IO

84-- with only what is provided in the haskell platform.

85--

86-- todo: The Terminal interface does not provide any input support.

87−terminal_handle :: ( Applicative m, MonadIO m ) => m TerminalHandle

87+current_terminal :: ( Applicative m, MonadIO m ) => m Terminal

88−terminal_handle = do

88+current_terminal = do

89 term_type <- liftIO $ getEnv "TERM"

90 out_handle <- liftIO $ hDuplicate stdout

91+ terminal_for_type_and_io term_type out_handle

92+

93+terminal_for_type_and_io :: (Applicative m, MonadIO m) => String -> Handle -> m Terminal

94+terminal_for_type_and_io term_type out_handle = do

91 t <- if "xterm" `isPrefixOf` term_type

95 t <- if "xterm" `isPrefixOf` term_type

92 then do

96 then do

93 maybe_terminal_app <- get_env "TERM_PROGRAM"

97 maybe_terminal_app <- get_env "TERM_PROGRAM"

94 case maybe_terminal_app of

98 case maybe_terminal_app of

95− Nothing

99+ Nothing

96− -> XTermColor.terminal_instance term_type out_handle >>= new_terminal_handle

100+ -> XTermColor.reserve_terminal term_type out_handle

97 Just v | v == "Apple_Terminal" || v == "iTerm.app"

101 Just v | v == "Apple_Terminal" || v == "iTerm.app"

98 -> do

102 -> do

99 maybe_xterm <- get_env "XTERM_VERSION"

103 maybe_xterm <- get_env "XTERM_VERSION"

100 case maybe_xterm of

104 case maybe_xterm of

101− Nothing -> MacOSX.terminal_instance v out_handle >>= new_terminal_handle

105+ Nothing -> MacOSX.reserve_terminal v out_handle

102− Just _ -> XTermColor.terminal_instance term_type out_handle >>= new_terminal_handle

106+ Just _ -> XTermColor.reserve_terminal term_type out_handle

103 -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app

107 -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app

104 -- like terminal?

108 -- like terminal?

105− _ -> XTermColor.terminal_instance term_type out_handle >>= new_terminal_handle

109+ _ -> XTermColor.reserve_terminal term_type out_handle

106 -- Not an xterm-like terminal. try for generic terminfo.

110 -- Not an xterm-like terminal. try for generic terminfo.

107− else TerminfoBased.terminal_instance term_type out_handle >>= new_terminal_handle

111+ else TerminfoBased.reserve_terminal term_type out_handle

108 return t

112 return t

109 where

113 where

110 get_env var = do

114 get_env var = do

@@ -120,24 +124,24 @@ terminal_handle = do

120--

124--

121-- Currently, the only way to set the cursor position to a given character coordinate is to specify

125-- Currently, the only way to set the cursor position to a given character coordinate is to specify

122-- the coordinate in the Picture instance provided to output_picture or refresh.

126-- the coordinate in the Picture instance provided to output_picture or refresh.

123−set_cursor_pos :: MonadIO m => TerminalHandle -> Int -> Int -> m ()

127+set_cursor_pos :: MonadIO m => Terminal -> Int -> Int -> m ()

124set_cursor_pos t x y = do

128set_cursor_pos t x y = do

125 bounds <- display_bounds t

129 bounds <- display_bounds t

126 when (x >= 0 && x < region_width bounds && y >= 0 && y < region_height bounds) $ do

130 when (x >= 0 && x < region_width bounds && y >= 0 && y < region_height bounds) $ do

127− d <- display_context t bounds

131+ dc <- display_context t bounds

128− liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)

132+ liftIO $ send_to_terminal t (move_cursor_required_bytes dc x y) (serialize_move_cursor dc x y)

129

133

130-- | Hides the cursor

134-- | Hides the cursor

131−hide_cursor :: MonadIO m => TerminalHandle -> m ()

135+hide_cursor :: MonadIO m => Terminal -> m ()

132hide_cursor t = do

136hide_cursor t = do

133 bounds <- display_bounds t

137 bounds <- display_bounds t

134− d <- display_context t bounds

138+ dc <- display_context t bounds

135− liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)

139+ liftIO $ send_to_terminal t (hide_cursor_required_bytes dc) (serialize_hide_cursor dc)

136

140

137-- | Shows the cursor

141-- | Shows the cursor

138−show_cursor :: MonadIO m => TerminalHandle -> m ()

142+show_cursor :: MonadIO m => Terminal -> m ()

139show_cursor t = do

143show_cursor t = do

140 bounds <- display_bounds t

144 bounds <- display_bounds t

141− d <- display_context t bounds

145+ dc <- display_context t bounds

142− liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d)

146+ liftIO $ send_to_terminal t (show_cursor_required_bytes dc) (serialize_show_cursor dc)

143

147

src/Graphics/Vty/Terminal/Interface.hs+127−196

@@ -1,4 +1,5 @@

1-- Copyright Corey O'Connor

2+-- General philosophy is: MonadIO is for equations exposed to clients.

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

@@ -18,41 +19,17 @@ import Graphics.Vty.DisplayRegion

19import Graphics.Vty.DisplayAttributes

20import Graphics.Vty.DisplayAttributes

21−import Control.Monad ( liftM )

22+import Control.Monad.Fix

22import Control.Monad.Trans

23import Control.Monad.Trans

24import qualified Data.ByteString.Internal as BS

25import qualified Data.ByteString.Internal as BS

25import Data.IORef

26import Data.IORef

26import qualified Data.Vector as Vector

27import qualified Data.Vector as Vector

28−import System.IO

29+data Terminal = Terminal

29−

30−-- | An handle to a terminal that hides the implementation.

31−data TerminalHandle where

32− TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle

33−

34−state_ref :: TerminalHandle -> IORef TerminalState

35−state_ref (TerminalHandle _ s_ref) = s_ref

36−

37−new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle

38−new_terminal_handle t = do

39− s_ref <- liftIO $ newIORef initial_terminal_state

40− return $ TerminalHandle t s_ref

41−

42−-- | The current terminal state. This may not exactly be known.

43−data TerminalState = TerminalState

44− { known_fattr :: Maybe FixedAttr

45− }

46−

47−-- | Initially we know nothing about a terminal's state.

48−initial_terminal_state :: TerminalState

49−initial_terminal_state = TerminalState Nothing

50−

51−class Terminal t where

52− -- | Text identifier for the terminal. Used for debugging.

30+ { -- | Text identifier for the terminal. Used for debugging.

53− terminal_ID :: t -> String

31+ terminal_ID :: String

54− -- |

32+ , release_device :: MonadIO m => m ()

55− release_terminal :: MonadIO m => t -> m ()

56 -- | Clear the display and initialize the terminal to some initial display state.

33 -- | Clear the display and initialize the terminal to some initial display state.

57 --

34 --

58 -- The expectation of a program is that the display starts in some initial state.

35 -- The expectation of a program is that the display starts in some initial state.

@@ -63,77 +40,67 @@ class Terminal t where

63 -- The abstract operation I think all these behaviors are instances of is reserving exclusive

40 -- The abstract operation I think all these behaviors are instances of is reserving exclusive

64 -- access to a display such that:

41 -- access to a display such that:

65 -- - The previous state cannot be determined

42 -- - The previous state cannot be determined

66− -- - When exclusive access to a display is release the display returns to the previous state.

43+ -- - When exclusive access to a display is released the display returns to the previous state.

67− reserve_display :: MonadIO m => t -> m ()

44+ , reserve_display :: MonadIO m => m ()

68−

69 -- | Return the display to the state before reserve_display

45 -- | Return the display to the state before reserve_display

70 -- If no previous state then set the display state to the initial state.

46 -- If no previous state then set the display state to the initial state.

71− release_display :: MonadIO m => t -> m ()

47+ , release_display :: MonadIO m => m ()

72−

73 -- | Returns the current display bounds.

48 -- | Returns the current display bounds.

74− display_bounds :: MonadIO m => t -> m DisplayRegion

49+ , display_bounds :: MonadIO m => m DisplayRegion

75−

76− -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle

77− -- constructor.

78− display_terminal_instance :: MonadIO m

79− => t

80− -> DisplayRegion

81− -> (forall d. DisplayTerminal d => d -> DisplayHandle)

82− -> m DisplayHandle

83−

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

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

85 -- end_ptr - start_ptr

51 -- end_ptr - start_ptr

86− output_byte_buffer :: t -> OutputBuffer -> Int -> IO ()

52+ , output_byte_buffer :: OutputBuffer -> Int -> IO ()

87−

53+ -- | Maximum number of colors supported by the context.

88− -- | Handle of output device

54+ , context_color_count :: Int

89− output_handle :: t -> IO Handle

55+ , assumed_state_ref :: IORef AssumedState

56+ , mk_display_context :: DisplayContext -> IO DisplayContext

57+ }

91−instance Terminal TerminalHandle where

59+data AssumedState = AssumedState

92− terminal_ID (TerminalHandle t _) = terminal_ID t

60+ { prev_fattr :: Maybe FixedAttr

93− release_terminal (TerminalHandle t _) = release_terminal t

61+ , prev_output_ops :: Maybe DisplayOps

94− reserve_display (TerminalHandle t _) = reserve_display t

62+ }

95− release_display (TerminalHandle t _) = release_display t

96− display_bounds (TerminalHandle t _) = display_bounds t

97− display_terminal_instance (TerminalHandle t _) = display_terminal_instance t

98− output_byte_buffer (TerminalHandle t _) = output_byte_buffer t

99− output_handle (TerminalHandle t _) = output_handle t

100

101−data DisplayHandle where

64+initial_assumed_state :: AssumedState

102− DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle

65+initial_assumed_state = AssumedState Nothing Nothing

103

104-- | Acquire display access to the given region of the display.

67-- | Acquire display access to the given region of the display.

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

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

106-- (max display_width provided_width, max display_height provided_height)

69-- (max display_width provided_width, max display_height provided_height)

107−display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle

70+display_context :: MonadIO m

71+ => Terminal

72+ -> DisplayRegion

73+ -> m DisplayContext

108−display_context t b = do

74+display_context t r = liftIO $ do

109− s <- initial_display_state

75+ let def_context self = DisplayContext

110− display_terminal_instance t b (\ d -> DisplayHandle d t s)

76+ { context_region = r

111−

77+ , context_device = t

112−data DisplayState = DisplayState

78+ , move_cursor_required_bytes = move_cursor_required_bytes self

113− { previous_output_ref :: IORef (Maybe DisplayOps)

79+ , serialize_move_cursor = serialize_move_cursor self

114− }

80+ , show_cursor_required_bytes = show_cursor_required_bytes self

115−

81+ , serialize_show_cursor = serialize_show_cursor self

116−initial_display_state :: MonadIO m => m DisplayState

82+ , hide_cursor_required_bytes = hide_cursor_required_bytes self

117−initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing

83+ , serialize_hide_cursor = serialize_hide_cursor self

118−

84+ , attr_required_bytes = attr_required_bytes self

119−class DisplayTerminal d where

85+ , serialize_set_attr = serialize_set_attr self

86+ , default_attr_required_bytes = default_attr_required_bytes self

87+ , serialize_default_attr = serialize_default_attr self

88+ , inline_hack = return ()

89+ }

90+ mfix (mk_display_context t . def_context)

91+

92+data DisplayContext = DisplayContext

120− -- | Provide the bounds of the display context.

93+ { -- | Provide the bounds of the display context.

121− context_region :: d -> DisplayRegion

94+ context_region :: DisplayRegion

122−

95+ , context_device :: Terminal

123− -- | Maximum number of colors supported by the context.

124− context_color_count :: d -> Int

125−

126 -- | sets the output position to the specified row and column. Where the number of bytes

96 -- | sets the output position to the specified row and column. Where the number of bytes

127 -- required for the control codes can be specified seperate from the actual byte sequence.

97 -- required for the control codes can be specified seperate from the actual byte sequence.

128− move_cursor_required_bytes :: d -> Int -> Int -> Int

98+ , move_cursor_required_bytes :: Int -> Int -> Int

129− serialize_move_cursor :: MonadIO m => d -> Int -> Int -> OutputBuffer -> m OutputBuffer

99+ , serialize_move_cursor :: Int -> Int -> OutputBuffer -> IO OutputBuffer

130−

131− show_cursor_required_bytes :: d -> Int

100+ , show_cursor_required_bytes :: Int

132− serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer

101+ , serialize_show_cursor :: OutputBuffer -> IO OutputBuffer

133−

134− hide_cursor_required_bytes :: d -> Int

102+ , hide_cursor_required_bytes :: Int

135− serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer

103+ , serialize_hide_cursor :: OutputBuffer -> IO OutputBuffer

136−

137 -- | Assure the specified output attributes will be applied to all the following text until the

104 -- | Assure the specified output attributes will be applied to all the following text until the

138 -- next output attribute change. Where the number of bytes required for the control codes can

105 -- next output attribute change. Where the number of bytes required for the control codes can

139 -- be specified seperate from the actual byte sequence. The required number of bytes must be

106 -- be specified seperate from the actual byte sequence. The required number of bytes must be

@@ -145,33 +112,15 @@ class DisplayTerminal d where

145 -- attributes. In order to support this the currently applied display attributes are required.

112 -- attributes. In order to support this the currently applied display attributes are required.

146 -- In addition it may be possible to optimize the state changes based off the currently applied

113 -- In addition it may be possible to optimize the state changes based off the currently applied

147 -- display attributes.

114 -- display attributes.

148− attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Int

115+ , attr_required_bytes :: FixedAttr -> Attr -> DisplayAttrDiff -> Int

149− serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer

116+ , serialize_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer

150−

151 -- | Reset the display attributes to the default display attributes

117 -- | Reset the display attributes to the default display attributes

152− default_attr_required_bytes :: d -> Int

118+ , default_attr_required_bytes :: Int

153− serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer

119+ , serialize_default_attr :: OutputBuffer -> IO OutputBuffer

154−

155 -- | See Graphics.Vty.Terminal.XTermColor.inline_hack

120 -- | See Graphics.Vty.Terminal.XTermColor.inline_hack

156− inline_hack :: MonadIO m => d -> m ()

121+ , inline_hack :: IO ()

157− inline_hack _d = return ()

122+ }

158−

159

123

160−instance DisplayTerminal DisplayHandle where

161− context_region (DisplayHandle d _ _) = context_region d

162− context_color_count (DisplayHandle d _ _) = context_color_count d

163− move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d

164− serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d

165− show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d

166− serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d

167− hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d

168− serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d

169− attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d

170− serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d

171− default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d

172− serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d

173− inline_hack (DisplayHandle d _ _) = inline_hack d

174−

175-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.

124-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.

176utf8_text_required_bytes :: BS.ByteString -> Int

125utf8_text_required_bytes :: BS.ByteString -> Int

177utf8_text_required_bytes str =

126utf8_text_required_bytes str =

@@ -179,15 +128,14 @@ utf8_text_required_bytes str =

179 in src_bytes_length

128 in src_bytes_length

180

129

181-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.

130-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.

182−serialize_utf8_text :: MonadIO m => BS.ByteString -> OutputBuffer -> m OutputBuffer

131+serialize_utf8_text :: BS.ByteString -> OutputBuffer -> IO OutputBuffer

183serialize_utf8_text str dest_ptr =

132serialize_utf8_text str dest_ptr =

184 let (src_fptr, src_ptr_offset, src_bytes_length) = BS.toForeignPtr str

133 let (src_fptr, src_ptr_offset, src_bytes_length) = BS.toForeignPtr str

185− in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do

134+ in withForeignPtr src_fptr $ \src_ptr -> do

186 let src_ptr' = src_ptr `plusPtr` src_ptr_offset

135 let src_ptr' = src_ptr `plusPtr` src_ptr_offset

187 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)

136 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)

188 return (dest_ptr `plusPtr` src_bytes_length)

137 return (dest_ptr `plusPtr` src_bytes_length)

189

138

190−

191-- | Displays the given `Picture`.

139-- | Displays the given `Picture`.

192--

140--

193-- 0. The image is cropped to the display size.

141-- 0. The image is cropped to the display size.

@@ -199,159 +147,142 @@ serialize_utf8_text str dest_ptr =

199-- 3. Serialized to the display.

147-- 3. Serialized to the display.

200--

148--

201-- 4. The cursor is then shown and positioned or kept hidden.

149-- 4. The cursor is then shown and positioned or kept hidden.

202−--

203--

150--

204-- todo: specify possible IO exceptions.

151-- todo: specify possible IO exceptions.

205-- abstract from IO monad to a MonadIO instance.

152-- abstract from IO monad to a MonadIO instance.

206−output_picture :: MonadIO m => DisplayHandle -> Picture -> m ()

153+output_picture :: MonadIO m => DisplayContext -> Picture -> m ()

207−output_picture (DisplayHandle d t s) pic = do

154+output_picture dc pic = liftIO $ do

155+ as <- readIORef (assumed_state_ref $ context_device dc)

208− let !r = context_region d

156+ let !r = context_region dc

209− let !ops = spans_for_pic pic r

157+ !ops = spans_for_pic pic r

210− let !initial_attr = FixedAttr default_style_mask Nothing Nothing

158+ !initial_attr = FixedAttr default_style_mask Nothing Nothing

211− -- Diff the previous output against the requested output. Differences are currently on a per-row

159+ -- Diff the previous output against the requested output. Differences are currently on a per-row

212− -- basis.

160+ -- basis.

161+ -- \todo handle resizes that crop the dominate directions better.

213− diffs :: [Bool]

162+ diffs :: [Bool] = case prev_output_ops as of

214− <- liftIO ( readIORef (previous_output_ref s) )

215− >>= \mprevious_ops -> case mprevious_ops of

216− Nothing

217− -> return $ replicate ( fromEnum $ region_height $ effected_region ops )

163+ Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True

218− True

219− Just previous_ops

220− -> if effected_region previous_ops /= effected_region ops

164+ Just previous_ops -> if effected_region previous_ops /= effected_region ops

221− then return $ replicate ( fromEnum $ region_height $ effected_region ops )

165+ then replicate (fromEnum $ region_height $ effected_region ops) True

222− True

223− else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops )

166+ else zipWith (/=) (Vector.toList $ display_ops previous_ops)

224− ( Vector.toList $ display_ops ops )

167+ (Vector.toList $ display_ops ops)

225−

226− -- determine the number of bytes required to completely serialize the output ops.

168+ -- determine the number of bytes required to completely serialize the output ops.

227− let total = hide_cursor_required_bytes d

169+ total = hide_cursor_required_bytes dc

228− + default_attr_required_bytes d

170+ + default_attr_required_bytes dc

229− + required_bytes d initial_attr diffs ops

171+ + required_bytes dc initial_attr diffs ops

230 + case pic_cursor pic of

172 + case pic_cursor pic of

231 NoCursor -> 0

173 NoCursor -> 0

232 Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic

174 Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic

233 ( ox, oy ) = char_to_output_pos m ( x, y )

175 ( ox, oy ) = char_to_output_pos m ( x, y )

234− in show_cursor_required_bytes d

235− + move_cursor_required_bytes d ox oy

176+ in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy

236−

237 -- ... then serialize

177 -- ... then serialize

238− liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do

178+ allocaBytes (fromEnum total) $ \start_ptr -> do

239− ptr <- serialize_hide_cursor d start_ptr

179+ ptr <- serialize_hide_cursor dc start_ptr

240− ptr' <- serialize_default_attr d ptr

180+ ptr' <- serialize_default_attr dc ptr

241− ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops

181+ ptr'' <- serialize_output_ops dc ptr' initial_attr diffs ops

242 end_ptr <- case pic_cursor pic of

182 end_ptr <- case pic_cursor pic of

243 NoCursor -> return ptr''

183 NoCursor -> return ptr''

244 Cursor x y -> do

184 Cursor x y -> do

245 let m = cursor_output_map ops $ pic_cursor pic

185 let m = cursor_output_map ops $ pic_cursor pic

246 (ox, oy) = char_to_output_pos m (x,y)

186 (ox, oy) = char_to_output_pos m (x,y)

247− serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy

187+ serialize_show_cursor dc ptr'' >>= serialize_move_cursor dc ox oy

248 -- todo: How to handle exceptions?

188 -- todo: How to handle exceptions?

249 case end_ptr `minusPtr` start_ptr of

189 case end_ptr `minusPtr` start_ptr of

250 count | count < 0 -> fail "End pointer before start of buffer."

190 count | count < 0 -> fail "End pointer before start of buffer."

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

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

252− | otherwise -> output_byte_buffer t start_ptr (toEnum count)

192+ | otherwise -> output_byte_buffer (context_device dc) start_ptr (toEnum count)

253 -- Cache the output spans.

193 -- Cache the output spans.

254− liftIO $ writeIORef (previous_output_ref s) (Just ops)

194+ let as' = as { prev_output_ops = Just ops }

255− return ()

195+ writeIORef (assumed_state_ref $ context_device dc) as'

256

196

257−required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Int

197+required_bytes :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Int

258−required_bytes d in_fattr diffs ops =

198+required_bytes dc in_fattr diffs ops =

259 let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops )

199 let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops )

260 in n

200 in n

261 where

201 where

262 required_bytes' (y, current_sum, fattr, True : diffs') span_ops

202 required_bytes' (y, current_sum, fattr, True : diffs') span_ops

263− = let (s, fattr') = span_ops_required_bytes d y fattr span_ops

203+ = let (s, fattr') = span_ops_required_bytes dc y fattr span_ops

264 in ( y + 1, s + current_sum, fattr', diffs' )

204 in ( y + 1, s + current_sum, fattr', diffs' )

265 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops

205 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops

266 = ( y + 1, current_sum, fattr, diffs' )

206 = ( y + 1, current_sum, fattr, diffs' )

267 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops

207 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops

268 = error "shouldn't be possible"

208 = error "shouldn't be possible"

269

209

270−span_ops_required_bytes :: DisplayTerminal d => d -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)

210+span_ops_required_bytes :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)

271−span_ops_required_bytes d y in_fattr span_ops =

211+span_ops_required_bytes dc y in_fattr span_ops =

272 -- The first operation is to set the cursor to the start of the row

212 -- The first operation is to set the cursor to the start of the row

273− let header_required_bytes = move_cursor_required_bytes d 0 y

213+ let header_required_bytes = move_cursor_required_bytes dc 0 y

274 -- then the span ops are serialized in the order specified

214 -- then the span ops are serialized in the order specified

275− in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op

215+ in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes dc fattr op

276 in (c + current_sum, fattr')

216 in (c + current_sum, fattr')

277 )

217 )

278 (header_required_bytes, in_fattr)

218 (header_required_bytes, in_fattr)

279 span_ops

219 span_ops

280

220

281−span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Int, FixedAttr)

221+span_op_required_bytes :: DisplayContext -> FixedAttr -> SpanOp -> (Int, FixedAttr)

282−span_op_required_bytes d fattr (AttributeChange attr) =

222+span_op_required_bytes dc fattr (AttributeChange attr) =

283− let attr' = limit_attr_for_display d attr

223+ let attr' = limit_attr_for_display (context_device dc) attr

284 diffs = display_attr_diffs fattr fattr'

224 diffs = display_attr_diffs fattr fattr'

285− c = attr_required_bytes d fattr attr' diffs

225+ c = attr_required_bytes dc fattr attr' diffs

286 fattr' = fix_display_attr fattr attr'

226 fattr' = fix_display_attr fattr attr'

287 in (c, fattr')

227 in (c, fattr')

288−span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)

228+span_op_required_bytes _dc fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)

289

229

290−serialize_output_ops :: ( MonadIO m, DisplayTerminal d )

230+serialize_output_ops :: DisplayContext

291− => d

292 -> OutputBuffer

231 -> OutputBuffer

293 -> FixedAttr

232 -> FixedAttr

294 -> [Bool]

233 -> [Bool]

295 -> DisplayOps

234 -> DisplayOps

296− -> m OutputBuffer

235+ -> IO OutputBuffer

297−serialize_output_ops d start_ptr in_fattr diffs ops = do

236+serialize_output_ops dc start_ptr in_fattr diffs ops = do

298 (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops'

237 (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops'

299 ( 0, start_ptr, in_fattr, diffs )

238 ( 0, start_ptr, in_fattr, diffs )

300 ( display_ops ops )

239 ( display_ops ops )

301 return end_ptr

240 return end_ptr

302 where

241 where

303 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops

242 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops

304− = serialize_span_ops d y out_ptr fattr span_ops

243+ = serialize_span_ops dc y out_ptr fattr span_ops

305 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )

244 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )

306 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops

245 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops

307 = return ( y + 1, out_ptr, fattr, diffs' )

246 = return ( y + 1, out_ptr, fattr, diffs' )

308 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops

247 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops

309 = error "shouldn't be possible"

248 = error "shouldn't be possible"

310

249

311−serialize_span_ops :: ( MonadIO m, DisplayTerminal d )

250+serialize_span_ops :: DisplayContext

312− => d

313 -> Int

251 -> Int

314 -> OutputBuffer

252 -> OutputBuffer

315 -> FixedAttr

253 -> FixedAttr

316 -> SpanOps

254 -> SpanOps

317− -> m (OutputBuffer, FixedAttr)

255+ -> IO (OutputBuffer, FixedAttr)

318−serialize_span_ops d y out_ptr in_fattr span_ops = do

256+serialize_span_ops dc y out_ptr in_fattr span_ops = do

319 -- The first operation is to set the cursor to the start of the row

257 -- The first operation is to set the cursor to the start of the row

320− out_ptr' <- serialize_move_cursor d 0 y out_ptr

258+ out_ptr' <- serialize_move_cursor dc 0 y out_ptr

321 -- then the span ops are serialized in the order specified

259 -- then the span ops are serialized in the order specified

322− Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )

260+ Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op dc op out_ptr'' fattr )

323 (out_ptr', in_fattr)

261 (out_ptr', in_fattr)

324 span_ops

262 span_ops

325

263

326−serialize_span_op :: ( MonadIO m, DisplayTerminal d )

264+serialize_span_op :: DisplayContext

327− => d

328 -> SpanOp

265 -> SpanOp

329 -> OutputBuffer

266 -> OutputBuffer

330 -> FixedAttr

267 -> FixedAttr

331− -> m (OutputBuffer, FixedAttr)

268+ -> IO (OutputBuffer, FixedAttr)

332−serialize_span_op d (AttributeChange attr) out_ptr fattr = do

269+serialize_span_op dc (AttributeChange attr) out_ptr fattr = do

333− let attr' = limit_attr_for_display d attr

270+ let attr' = limit_attr_for_display (context_device dc) attr

334 fattr' = fix_display_attr fattr attr'

271 fattr' = fix_display_attr fattr attr'

335 diffs = display_attr_diffs fattr fattr'

272 diffs = display_attr_diffs fattr fattr'

336− out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr

273+ out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr

337 return (out_ptr', fattr')

274 return (out_ptr', fattr')

338−serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do

275+serialize_span_op _dc (TextSpan _ _ str) out_ptr fattr = do

339 out_ptr' <- serialize_utf8_text str out_ptr

276 out_ptr' <- serialize_utf8_text str out_ptr

340 return (out_ptr', fattr)

277 return (out_ptr', fattr)

341

278

342−marshall_to_terminal :: ( Terminal t )

343− => t -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()

279+send_to_terminal :: Terminal -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()

344−marshall_to_terminal t c f = do

280+send_to_terminal t c f = allocaBytes (fromEnum c) $ \start_ptr -> do

345− start_ptr <- mallocBytes (fromEnum c)

346− --

347− -- todo: capture exceptions?

348 end_ptr <- f start_ptr

281 end_ptr <- f start_ptr

349 case end_ptr `minusPtr` start_ptr of

282 case end_ptr `minusPtr` start_ptr of

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

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

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

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

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

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

353− free start_ptr

354− return ()

355

286

356-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this

287-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this

357-- needs to be translated to column, row positions.

288-- needs to be translated to column, row positions.

@@ -391,8 +322,8 @@ cursor_column_offset span_ops cx cy =

391

322

392-- | Not all terminals support all display attributes. This filters a display attribute to what the

323-- | Not all terminals support all display attributes. This filters a display attribute to what the

393-- given terminal can display.

324-- given terminal can display.

394−limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr

325+limit_attr_for_display :: Terminal -> Attr -> Attr

395−limit_attr_for_display d attr

326+limit_attr_for_display t attr

396 = attr { attr_fore_color = clamp_color $ attr_fore_color attr

327 = attr { attr_fore_color = clamp_color $ attr_fore_color attr

397 , attr_back_color = clamp_color $ attr_back_color attr

328 , attr_back_color = clamp_color $ attr_back_color attr

398 }

329 }

@@ -401,16 +332,16 @@ limit_attr_for_display d attr

401 clamp_color KeepCurrent = KeepCurrent

332 clamp_color KeepCurrent = KeepCurrent

402 clamp_color (SetTo c) = clamp_color' c

333 clamp_color (SetTo c) = clamp_color' c

403 clamp_color' (ISOColor v)

334 clamp_color' (ISOColor v)

404− | context_color_count d < 8 = Default

335+ | context_color_count t < 8 = Default

405− | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

336+ | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

406 | otherwise = SetTo $ ISOColor v

337 | otherwise = SetTo $ ISOColor v

407 clamp_color' (Color240 v)

338 clamp_color' (Color240 v)

408 -- TODO: Choose closes ISO color?

339 -- TODO: Choose closes ISO color?

409− | context_color_count d < 8 = Default

340+ | context_color_count t < 8 = Default

410− | context_color_count d < 16 = Default

341+ | context_color_count t < 16 = Default

411− | context_color_count d == 240 = SetTo $ Color240 v

342+ | context_color_count t == 240 = SetTo $ Color240 v

412 | otherwise

343 | otherwise

413 = let p :: Double = fromIntegral v / 240.0

344 = let p :: Double = fromIntegral v / 240.0

414− v' = floor $ p * (fromIntegral $ context_color_count d)

345+ v' = floor $ p * (fromIntegral $ context_color_count t)

415 in SetTo $ Color240 v'

346 in SetTo $ Color240 v'

416

347

src/Graphics/Vty/Terminal/MacOSX.hs+29−64

@@ -10,8 +10,7 @@

10{-# LANGUAGE MagicHash #-}

11{-# LANGUAGE FlexibleInstances #-}

12{-# LANGUAGE TypeFamilies #-}

13−module Graphics.Vty.Terminal.MacOSX ( terminal_instance

13+module Graphics.Vty.Terminal.MacOSX ( reserve_terminal )

14− )

15 where

14 where

17import Graphics.Vty.Terminal.Interface

16import Graphics.Vty.Terminal.Interface

@@ -22,27 +21,25 @@ import Control.Monad.Trans

23import System.IO

22import System.IO

25−-- | A Mac terminal is assumed to be an xterm based terminal.

26−data Term = Term

27− { super_term :: TerminalHandle

28− , term_app :: String

29− }

30−

31-- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier

24-- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier

32-- "xterm-256color" is used.

25-- "xterm-256color" is used.

33--

26--

34-- This effects the terminfo lookup.

27-- This effects the terminfo lookup.

35−terminal_instance :: ( Applicative m, MonadIO m ) => String -> Handle -> m Term

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

36−terminal_instance v out_handle = do

29+reserve_terminal v out_handle = do

37− let base_term "iTerm.app" = "xterm-256color"

30+ let remap_term "iTerm.app" = "xterm-256color"

38− base_term _ = "xterm"

31+ remap_term _ = "xterm"

32+ flushed_put :: String -> IO ()

33+ flushed_put str = do

34+ hPutStr out_handle str

35+ hFlush out_handle

39− t <- TerminfoBased.terminal_instance (base_term v) out_handle >>= new_terminal_handle

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

40− return $ Term t v

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+ }

42−flushed_put :: MonadIO m => String -> m ()

43−flushed_put str = do

44− liftIO $ hPutStr stdout str

45− liftIO $ hFlush stdout

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

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

48-- Otherwise, Terminal.app expects the xterm caps.

45-- Otherwise, Terminal.app expects the xterm caps.

@@ -50,53 +47,21 @@ smcup_str, rmcup_str :: String

50smcup_str = "\ESC7\ESC[?47h"

47smcup_str = "\ESC7\ESC[?47h"

51rmcup_str = "\ESC[2J\ESC[?47l\ESC8"

48rmcup_str = "\ESC[2J\ESC[?47l\ESC8"

50+-- | always smcup then clear the screen on terminal.app

51+--

52+-- \todo really?

53+terminal_app_reserve_display :: MonadIO m => (String -> IO ()) -> m ()

54+terminal_app_reserve_display flushed_put = liftIO $ do

55+ flushed_put smcup_str

56+ flushed_put clear_screen_str

57+

58+terminal_app_release_display :: MonadIO m => (String -> IO ()) -> m ()

59+terminal_app_release_display flushed_put = liftIO $ do

60+ flushed_put rmcup_str

61+

53-- | iTerm needs a clear screen after smcup as well.

62-- | iTerm needs a clear screen after smcup as well.

63+--

64+-- \todo but we apply to all mac terminals?

54clear_screen_str :: String

65clear_screen_str :: String

55clear_screen_str = "\ESC[H\ESC[2J"

66clear_screen_str = "\ESC[H\ESC[2J"

57−instance Terminal Term where

58− terminal_ID t = term_app t ++ " :: MacOSX"

59−

60− release_terminal t = do

61− release_terminal $ super_term t

62−

63− reserve_display _t = do

64− flushed_put smcup_str

65− flushed_put clear_screen_str

66−

67− release_display _t = do

68− flushed_put rmcup_str

69−

70− display_terminal_instance t b c = do

71− d <- display_context (super_term t) b

72− return $ c (DisplayContext d)

73−

74− display_bounds t = display_bounds (super_term t)

75−

76− output_byte_buffer t = output_byte_buffer (super_term t)

77−

78− output_handle t = output_handle (super_term t)

79−

80−data DisplayContext = DisplayContext

81− { super_display :: DisplayHandle

82− }

83−

84−instance DisplayTerminal DisplayContext where

85− context_region d = context_region (super_display d)

86− context_color_count d = context_color_count (super_display d)

87−

88− move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)

89− serialize_move_cursor d = serialize_move_cursor (super_display d)

90−

91− show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)

92− serialize_show_cursor d = serialize_show_cursor (super_display d)

93−

94− hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)

95− serialize_hide_cursor d = serialize_hide_cursor (super_display d)

96−

97− attr_required_bytes d = attr_required_bytes (super_display d)

98− serialize_set_attr d = serialize_set_attr (super_display d)

99−

100− default_attr_required_bytes d = default_attr_required_bytes (super_display d)

101− serialize_default_attr d = serialize_default_attr (super_display d)

102−

src/Graphics/Vty/Terminal/Mock.hs+48−86

@@ -1,11 +1,7 @@

1-- Copyright Corey O'Connor

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE TypeFamilies #-}

4−module Graphics.Vty.Terminal.Mock ( MockTerminal(..)

4+module Graphics.Vty.Terminal.Mock ( mock_terminal )

5− , MockDisplay(..)

6− , terminal_instance

7− , dehandle

8− )

9 where

5 where

11import Graphics.Vty.DisplayRegion

7import Graphics.Vty.DisplayRegion

@@ -14,8 +10,7 @@ import Graphics.Vty.Terminal.Interface

14import Control.Applicative

10import Control.Applicative

15import Control.Monad.Trans

11import Control.Monad.Trans

17−import qualified Data.ByteString.UTF8 as BS

13+import qualified Data.ByteString as BS

18−import qualified Data.ByteString as BSCore

19import Data.IORef

14import Data.IORef

20import qualified Data.String.UTF8 as UTF8

15import qualified Data.String.UTF8 as UTF8

@@ -23,9 +18,7 @@ import Foreign.Marshal.Array ( peekArray )

23import Foreign.Ptr ( plusPtr )

18import Foreign.Ptr ( plusPtr )

24import Foreign.Storable ( poke )

19import Foreign.Storable ( poke )

26−import System.IO

21+type MockData = IORef (UTF8.UTF8 BS.ByteString)

27−

28−import Unsafe.Coerce

30-- | The mock display terminal produces a string representation of the requested picture. There is

23-- | The mock display terminal produces a string representation of the requested picture. There is

31-- *not* an isomorphism between the string representation and the picture. The string

24-- *not* an isomorphism between the string representation and the picture. The string

@@ -41,81 +34,50 @@ import Unsafe.Coerce

41-- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad

34-- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad

42-- class there exists a monoid that defines it's algebra. The string representation is a sequence of

35-- class there exists a monoid that defines it's algebra. The string representation is a sequence of

43-- identifiers where each identifier is the name of an operation in the algebra.

36-- identifiers where each identifier is the name of an operation in the algebra.

44−

37+mock_terminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Terminal)

45−data MockTerminal = MockTerminal

38+mock_terminal r = liftIO $ do

46− { mock_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString)

39+ out_ref <- newIORef undefined

47− , mock_terminal_bounds :: DisplayRegion

40+ new_assumed_state_ref <- newIORef initial_assumed_state

48− }

41+ return $ (,) out_ref $ Terminal

49−

50−instance Terminal MockTerminal where

51− terminal_ID _t = "mock_terminal"

42+ { terminal_ID = "mock terminal"

52− release_terminal _t = return ()

43+ , release_device = return ()

53− reserve_display _t = return ()

44+ , reserve_display = return ()

54− release_display _t = return ()

45+ , release_display = return ()

55− display_bounds t = return $ mock_terminal_bounds t

46+ , display_bounds = return r

56− display_terminal_instance _t r c = return $ c (MockDisplay r)

57− output_byte_buffer t out_buffer buffer_size

47+ , output_byte_buffer = \out_buffer buffer_size -> do

58− = liftIO $ do

59− putStrLn $ "output_byte_buffer ?? " ++ show buffer_size

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

60 peekArray (fromEnum buffer_size) out_buffer

49 peekArray (fromEnum buffer_size) out_buffer

61− >>= return . UTF8.fromRep . BSCore.pack

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

62− >>= writeIORef (mock_terminal_last_output t)

51+ >>= writeIORef out_ref

63−

52+ , context_color_count = 16

64− output_handle _t = return stdout

53+ , assumed_state_ref = new_assumed_state_ref

65−

54+ , mk_display_context = \self -> return $ self

66−data MockDisplay = MockDisplay

67− { mock_display_bounds :: DisplayRegion

68− }

69−

70−terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle

71−terminal_instance r = do

72− output_ref <- liftIO $ newIORef undefined

73− new_terminal_handle $ MockTerminal output_ref r

74−

75−dehandle :: TerminalHandle -> MockTerminal

76−dehandle (TerminalHandle t _) = unsafeCoerce t

77−

78−instance DisplayTerminal MockDisplay where

79− -- | Provide the current bounds of the output terminal.

80− context_region d = mock_display_bounds d

55+ { context_region = r

81−

82− -- | Assume 16 colors

83− context_color_count _d = 16

84−

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

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

86− move_cursor_required_bytes _d _x _y = 1

57+ , move_cursor_required_bytes = \_x _y -> 1

87−

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

89− serialize_move_cursor _d _x _y ptr = do

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

90− liftIO $ poke ptr (toEnum $ fromEnum 'M')

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

91− return $ ptr `plusPtr` 1

60+ return $ ptr `plusPtr` 1

92−

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

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

94− show_cursor_required_bytes _d = 1

62+ , show_cursor_required_bytes = 1

95−

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

97− serialize_show_cursor _d ptr = do

63+ , serialize_show_cursor = \ptr -> do

98− liftIO $ poke ptr (toEnum $ fromEnum 'S')

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

99− return $ ptr `plusPtr` 1

65+ return $ ptr `plusPtr` 1

100−

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

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

102− hide_cursor_required_bytes _d = 1

67+ , hide_cursor_required_bytes = 1

103−

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

105− serialize_hide_cursor _d ptr = do

68+ , serialize_hide_cursor = \ptr -> do

106− liftIO $ poke ptr (toEnum $ fromEnum 'H')

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

107− return $ ptr `plusPtr` 1

70+ return $ ptr `plusPtr` 1

108−

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

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

110− attr_required_bytes _d _fattr _diffs _attr = 1

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

111−

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

113− serialize_set_attr _d _fattr _diffs _attr ptr = do

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

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

75+ return $ ptr `plusPtr` 1

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

77+ , default_attr_required_bytes = 1

78+ , serialize_default_attr = \ptr -> do

114− liftIO $ poke ptr (toEnum $ fromEnum 'A')

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

115− return $ ptr `plusPtr` 1

80+ return $ ptr `plusPtr` 1

81+ }

82+ }

116

117− default_attr_required_bytes _d = 1

118− serialize_default_attr _d ptr = do

119− liftIO $ poke ptr (toEnum $ fromEnum 'D')

120− return $ ptr `plusPtr` 1

121−

src/Graphics/Vty/Terminal/TerminfoBased.hs+210−248

@@ -3,8 +3,7 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}

6−module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance

6+module Graphics.Vty.Terminal.TerminfoBased ( reserve_terminal )

7− )

8 where

7 where

10import Data.Terminfo.Parse

9import Data.Terminfo.Parse

@@ -17,9 +16,11 @@ import Graphics.Vty.DisplayRegion

18import Control.Applicative

17import Control.Applicative

19import Control.Monad ( foldM )

18import Control.Monad ( foldM )

19+import Control.Monad.Fix (mfix)

20import Control.Monad.Trans

22import Data.Bits ( (.&.) )

23+import Data.IORef

23import Data.Maybe ( isJust, isNothing, fromJust )

24import Data.Maybe ( isJust, isNothing, fromJust )

25import Foreign.C.Types ( CLong(..) )

26import Foreign.C.Types ( CLong(..) )

@@ -27,12 +28,9 @@ import Foreign.C.Types ( CLong(..) )

27import GHC.IO.Handle

28import GHC.IO.Handle

29import qualified System.Console.Terminfo as Terminfo

30import qualified System.Console.Terminfo as Terminfo

30−import System.IO

32−data Term = Term

32+data TerminfoCaps = TerminfoCaps

33− { term_info_ID :: String

34− , term_info :: Terminfo.Terminal

35− , smcup :: Maybe CapExpression

33+ { smcup :: Maybe CapExpression

36 , rmcup :: Maybe CapExpression

34 , rmcup :: Maybe CapExpression

37 , cup :: CapExpression

35 , cup :: CapExpression

38 , cnorm :: CapExpression

36 , cnorm :: CapExpression

@@ -42,7 +40,6 @@ data Term = Term

42 , set_default_attr :: CapExpression

40 , set_default_attr :: CapExpression

43 , clear_screen :: CapExpression

41 , clear_screen :: CapExpression

44 , display_attr_caps :: DisplayAttrCaps

42 , display_attr_caps :: DisplayAttrCaps

45− , term_handle :: Handle

46 }

43 }

48data DisplayAttrCaps = DisplayAttrCaps

45data DisplayAttrCaps = DisplayAttrCaps

@@ -56,11 +53,10 @@ data DisplayAttrCaps = DisplayAttrCaps

56 , enter_bold_mode :: Maybe CapExpression

53 , enter_bold_mode :: Maybe CapExpression

57 }

54 }

59−marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()

56+send_cap_to_terminal :: Terminal -> CapExpression -> [CapParam] -> IO ()

60−marshall_cap_to_terminal t cap_selector cap_params = do

57+send_cap_to_terminal t cap cap_params = do

61− marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )

58+ send_to_terminal t (cap_expression_required_bytes cap cap_params)

62− ( serialize_cap_expression (cap_selector t) cap_params )

59+ (serialize_cap_expression cap cap_params)

63− return ()

65{- | Uses terminfo for all control codes. While this should provide the most compatible terminal

61{- | Uses terminfo for all control codes. While this should provide the most compatible terminal

66 - terminfo does not support some features that would increase efficiency and improve compatibility:

62 - terminfo does not support some features that would increase efficiency and improve compatibility:

@@ -72,257 +68,223 @@ marshall_cap_to_terminal t cap_selector cap_params = do

72 - todo: Some display attributes like underline and bold have independent string capabilities that

68 - todo: Some display attributes like underline and bold have independent string capabilities that

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

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

74 -}

70 -}

75−terminal_instance :: ( Applicative m, MonadIO m ) => String -> Handle -> m Term

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

76−terminal_instance in_ID the_handle = do

72+reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do

77− ti <- liftIO $ Terminfo.setupTerm in_ID

73+ ti <- Terminfo.setupTerm in_ID

78− let require_cap str

74+ terminfo_caps <- pure TerminfoCaps

79− = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of

75+ <*> probe_cap ti "smcup"

80− Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""

81− Just cap_str -> do

82− parse_result <- parse_cap_expression cap_str

83− case parse_result of

84− Left e -> fail $ show e

85− Right cap -> return cap

86− probe_cap cap_name

87− = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

88− Nothing -> return Nothing

89− Just cap_str -> do

90− parse_result <- parse_cap_expression cap_str

91− case parse_result of

92− Left e -> fail $ show e

93− Right cap -> return $ Just cap

94− pure Term

95− <*> pure in_ID

96− <*> pure ti

97− <*> probe_cap "smcup"

98− <*> probe_cap "rmcup"

76+ <*> probe_cap ti "rmcup"

99− <*> require_cap "cup"

77+ <*> require_cap ti "cup"

100− <*> require_cap "cnorm"

78+ <*> require_cap ti "cnorm"

101− <*> require_cap "civis"

79+ <*> require_cap ti "civis"

102− <*> require_cap "setaf"

80+ <*> require_cap ti "setaf"

103− <*> require_cap "setab"

81+ <*> require_cap ti "setab"

104− <*> require_cap "sgr0"

82+ <*> require_cap ti "sgr0"

105− <*> require_cap "clear"

83+ <*> require_cap ti "clear"

106 <*> current_display_attr_caps ti

84 <*> current_display_attr_caps ti

107− <*> pure the_handle

85+ let send_cap s = send_cap_to_terminal self (s terminfo_caps)

86+ new_assumed_state_ref <- newIORef initial_assumed_state

87+ return $ Terminal

88+ { terminal_ID = in_ID

89+ , release_device = liftIO $ do

90+ send_cap set_default_attr []

91+ send_cap cnorm []

92+ hClose out_handle

93+ , reserve_display = liftIO $ do

94+ if (isJust $ smcup terminfo_caps)

95+ then send_cap (fromJust . smcup) []

96+ else return ()

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

99+ -- home position.

100+ hFlush out_handle

101+ send_cap clear_screen []

102+ , release_display = liftIO $ do

103+ if (isJust $ rmcup terminfo_caps)

104+ then send_cap (fromJust . rmcup) []

105+ else return ()

106+ send_cap cnorm []

107+ , display_bounds = do

108+ raw_size <- liftIO $ get_window_size

109+ case raw_size of

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

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

112+ , output_byte_buffer = \out_ptr out_byte_count -> do

113+ hPutBuf out_handle out_ptr (fromEnum out_byte_count)

114+ hFlush out_handle

115+ , context_color_count = case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

116+ Nothing -> 8

117+ Just v -> toEnum v

118+ , assumed_state_ref = new_assumed_state_ref

119+ , mk_display_context = mk_terminfo_display_context terminfo_caps

120+ }

121+

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

123+require_cap ti cap_name

124+ = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

125+ Nothing -> fail $ "Terminal does not define required capability \"" ++ cap_name ++ "\""

126+ Just cap_str -> parse_cap cap_str

127+

128+probe_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)

129+probe_cap ti cap_name

130+ = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

131+ Nothing -> return Nothing

132+ Just cap_str -> Just <$> parse_cap cap_str

133+

134+parse_cap :: (Applicative m, MonadIO m) => String -> m CapExpression

135+parse_cap cap_str = do

136+ parse_result <- parse_cap_expression cap_str

137+ case parse_result of

138+ Left e -> fail $ show e

139+ Right cap -> return cap

108

140

109current_display_attr_caps :: ( Applicative m, MonadIO m )

141current_display_attr_caps :: ( Applicative m, MonadIO m )

110 => Terminfo.Terminal

142 => Terminfo.Terminal

111 -> m DisplayAttrCaps

143 -> m DisplayAttrCaps

112current_display_attr_caps ti

144current_display_attr_caps ti

113 = pure DisplayAttrCaps

145 = pure DisplayAttrCaps

114− <*> probe_cap "sgr"

146+ <*> probe_cap ti "sgr"

115− <*> probe_cap "smso"

147+ <*> probe_cap ti "smso"

116− <*> probe_cap "rmso"

148+ <*> probe_cap ti "rmso"

117− <*> probe_cap "smul"

149+ <*> probe_cap ti "smul"

118− <*> probe_cap "rmul"

150+ <*> probe_cap ti "rmul"

119− <*> probe_cap "rev"

151+ <*> probe_cap ti "rev"

120− <*> probe_cap "dim"

152+ <*> probe_cap ti "dim"

121− <*> probe_cap "bold"

153+ <*> probe_cap ti "bold"

122− where probe_cap cap_name

123− = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

124− Nothing -> return Nothing

125− Just cap_str -> do

126− parse_result <- parse_cap_expression cap_str

127− case parse_result of

128− Left e -> fail $ show e

129− Right cap -> return $ Just cap

130−

131−instance Terminal Term where

132− terminal_ID t = term_info_ID t ++ " :: TerminfoBased"

133−

134− release_terminal t = liftIO $ do

135− marshall_cap_to_terminal t set_default_attr []

136− marshall_cap_to_terminal t cnorm []

137− hClose $ term_handle t

138− return ()

139−

140− reserve_display t = liftIO $ do

141− if (isJust $ smcup t)

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

143− else return ()

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

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

146− -- home position.

147− hFlush stdout

148− marshall_cap_to_terminal t clear_screen []

149− return ()

150

154

151− release_display t = liftIO $ do

152− if (isJust $ rmcup t)

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

154− else return ()

155− marshall_cap_to_terminal t cnorm []

156− return ()

157−

158− display_terminal_instance t b c = do

159− let color_count

160− = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of

161− Nothing -> 8

162− Just v -> toEnum v

163− return $ c (DisplayContext b t color_count)

164−

165− display_bounds _t = do

166− raw_size <- liftIO $ get_window_size

167− case raw_size of

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

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

170−

171− -- | Output the byte buffer of the specified size to the terminal device.

172− output_byte_buffer t out_ptr out_byte_count = do

173− -- if the out fd is actually the same as stdout's then a

174− -- flush is required *before* the c_output_byte_buffer call

175− -- otherwise there may still be data in GHC's internal stdout buffer.

176− -- _ <- handleToFd stdout

177− hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count)

178− hFlush (term_handle t)

179−

180− output_handle t = return (term_handle t)

181−

182−foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size

155+foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: IO CLong

183− :: IO CLong

184

156

185get_window_size :: IO (Int,Int)

157get_window_size :: IO (Int,Int)

186get_window_size = do

158get_window_size = do

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

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

188 return (fromIntegral b, fromIntegral a)

160 return (fromIntegral b, fromIntegral a)

189

161

190−data DisplayContext = DisplayContext

162+mk_terminfo_display_context :: TerminfoCaps -> DisplayContext -> IO DisplayContext

191− { bounds :: DisplayRegion

163+mk_terminfo_display_context terminfo_caps self = do

192− , term :: Term

164+ return $ self

193− , supported_colors :: Int

194− }

195−

196−instance DisplayTerminal DisplayContext where

197− context_region d = bounds d

198−

199− context_color_count d = supported_colors d

200−

201− move_cursor_required_bytes d x y

165+ { move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)

202− = cap_expression_required_bytes (cup $ term d) [toEnum y, toEnum x]

166+ [toEnum y, toEnum x]

203− serialize_move_cursor d x y out_ptr

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

204− = liftIO $ serialize_cap_expression (cup $ term d) [toEnum y, toEnum x] out_ptr

168+ [toEnum y, toEnum x]

205−

169+ out_ptr

206− show_cursor_required_bytes d

207− = cap_expression_required_bytes (cnorm $ term d) []

170+ , show_cursor_required_bytes = cap_expression_required_bytes (cnorm terminfo_caps) []

208− serialize_show_cursor d out_ptr

209− = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr

171+ , serialize_show_cursor = \out_ptr -> serialize_cap_expression (cnorm terminfo_caps) [] out_ptr

210−

211− hide_cursor_required_bytes d

212− = cap_expression_required_bytes (civis $ term d) []

172+ , hide_cursor_required_bytes = cap_expression_required_bytes (civis terminfo_caps) []

213− serialize_hide_cursor d out_ptr

173+ , serialize_hide_cursor = \out_ptr -> serialize_cap_expression (civis terminfo_caps) [] out_ptr

214− = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr

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

215−

175+ , serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps

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

177+ , serialize_default_attr = \out_ptr -> serialize_cap_expression (set_default_attr terminfo_caps) [] out_ptr

178+ }

179+

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

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

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

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

218− -- requirement as big the longest possible control string.

182+-- requirement as big the longest possible control string.

219− --

183+--

220− -- Which is assumed to the be less than 512 for now.

184+-- Which is assumed to the be less than 512 for now.

221− --

185+--

222− -- \todo Not verified as safe and wastes memory.

186+-- \todo Not verified as safe and wastes memory.

223− attr_required_bytes _d _prev_attr _req_attr _diffs = 512

187+assumed_attr_required_bytes :: Int

188+assumed_attr_required_bytes = 512

224

189

225− -- | Portably setting the display attributes is a giant pain in the ass.

190+-- | Portably setting the display attributes is a giant pain in the ass.

226− --

191+--

227− -- If the terminal supports the sgr capability (which sets the on/off state of each style

192+-- If the terminal supports the sgr capability (which sets the on/off state of each style

228− -- directly ; and, for no good reason, resets the colors to the default) this procedure is used:

193+-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:

229− --

194+--

230− -- 0. set the style attributes. This resets the fore and back color.

195+-- 0. set the style attributes. This resets the fore and back color.

231− -- 1, If a foreground color is to be set then set the foreground color

196+-- 1, If a foreground color is to be set then set the foreground color

232− -- 2. likewise with the background color

197+-- 2. likewise with the background color

233− --

198+--

234− -- If the terminal does not support the sgr cap then:

199+-- If the terminal does not support the sgr cap then:

235− -- if there is a change from an applied color to the default (in either the fore or back color)

200+-- if there is a change from an applied color to the default (in either the fore or back color)

236− -- then:

201+-- then:

237− -- 0. reset all display attributes (sgr0)

202+-- 0. reset all display attributes (sgr0)

238− -- 1. enter required style modes

203+-- 1. enter required style modes

239− -- 2. set the fore color if required

204+-- 2. set the fore color if required

240− -- 3. set the back color if required

205+-- 3. set the back color if required

241− --

206+--

242− -- Entering the required style modes could require a reset of the display attributes. If this is

207+-- Entering the required style modes could require a reset of the display attributes. If this is

243− -- the case then the back and fore colors always need to be set if not default.

208+-- the case then the back and fore colors always need to be set if not default.

244− --

209+--

245− -- This equation implements the above logic.

210+-- This equation implements the above logic.

246− --

211+--

247− -- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I

212+-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I

248 -- haven't measured this or even examined terminal implementations. *shrug*

213 -- haven't measured this or even examined terminal implementations. *shrug*

214+terminfo_serialize_set_attr :: DisplayContext

215+ -> TerminfoCaps

216+ -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer

249− serialize_set_attr d prev_attr req_attr diffs out_ptr = do

217+terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr = do

250− case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

218+ case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

251− -- The only way to reset either color, portably, to the default is to use either the set

219+ -- The only way to reset either color, portably, to the default is to use either the set

252− -- state capability or the set default capability.

220+ -- state capability or the set default capability.

253− True -> do

221+ True -> do

254− case req_display_cap_seq_for ( display_attr_caps $ term d )

222+ case req_display_cap_seq_for ( display_attr_caps terminfo_caps )

255− ( fixed_style attr )

223+ ( fixed_style attr )

256− ( style_to_apply_seq $ fixed_style attr )

224+ ( style_to_apply_seq $ fixed_style attr )

257− of

225+ of

258− EnterExitSeq caps

226+ EnterExitSeq caps

259− -- only way to reset a color to the defaults

227+ -- only way to reset a color to the defaults

260− -> serialize_default_attr d out_ptr

228+ -> serialize_default_attr dc out_ptr

261− >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)

229+ >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)

262− >>= set_colors

230+ >>= set_colors

263− SetState state

231+ SetState state

264− -- implicitly resets the colors to the defaults

232+ -- implicitly resets the colors to the defaults

265− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

233+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

266− $ display_attr_caps

234+ $ display_attr_caps

267− $ term d

235+ $ terminfo_caps

268− )

236+ )

269− ( sgr_args_for_state state )

237+ ( sgr_args_for_state state )

270− out_ptr

238+ out_ptr

271− >>= set_colors

239+ >>= set_colors

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

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

273− -- points.

241+ -- points.

274− False -> do

242+ False -> do

275− -- Still, it could be the case that the change in display attributes requires the

243+ -- Still, it could be the case that the change in display attributes requires the

276− -- colors to be reset because the required capability was not available.

244+ -- colors to be reset because the required capability was not available.

277− case req_display_cap_seq_for ( display_attr_caps $ term d )

245+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)

278− ( fixed_style attr )

246+ (fixed_style attr)

279− ( style_diffs diffs )

247+ (style_diffs diffs)

280− of

248+ of

281− -- Really, if terminals were re-implemented with modern concepts instead of

249+ -- Really, if terminals were re-implemented with modern concepts instead of

282− -- bowing down to 40 yr old dumb terminal requirements this would be the

250+ -- bowing down to 40 yr old dumb terminal requirements this would be the

283− -- only case ever reached!

251+ -- only case ever reached!

284− -- Changes the style and color states according to the differences with the

252+ -- Changes the style and color states according to the differences with the

285− -- currently applied states.

253+ -- currently applied states.

286− EnterExitSeq caps

254+ EnterExitSeq caps

287− -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps )

255+ -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps

288− >>= apply_color_diff set_fore_color ( fore_color_diff diffs )

256+ >>= apply_color_diff set_fore_color (fore_color_diff diffs)

289− >>= apply_color_diff set_back_color ( back_color_diff diffs )

257+ >>= apply_color_diff set_back_color (back_color_diff diffs)

290− SetState state

258+ SetState state

291− -- implicitly resets the colors to the defaults

259+ -- implicitly resets the colors to the defaults

292− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

260+ -> serialize_cap_expression (fromJust $ set_attr_states

293− $ display_attr_caps

261+ $ display_attr_caps terminfo_caps

294− $ term d

295− )

262+ )

296− ( sgr_args_for_state state )

263+ (sgr_args_for_state state)

297− out_ptr

264+ out_ptr

298− >>= set_colors

265+ >>= set_colors

299− where

266+ where

300− attr = fix_display_attr prev_attr req_attr

267+ attr = fix_display_attr prev_attr req_attr

301− set_colors ptr = do

268+ set_colors ptr = do

302− ptr' <- case fixed_fore_color attr of

269+ ptr' <- case fixed_fore_color attr of

303− Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d )

270+ Just c -> serialize_cap_expression (set_fore_color terminfo_caps)

304− [ toEnum $ ansi_color_index c ]

271+ [ toEnum $ ansi_color_index c ]

305− ptr

272+ ptr

306− Nothing -> return ptr

273+ Nothing -> return ptr

307− ptr'' <- case fixed_back_color attr of

274+ ptr'' <- case fixed_back_color attr of

308− Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d )

275+ Just c -> serialize_cap_expression (set_back_color terminfo_caps)

309− [ toEnum $ ansi_color_index c ]

276+ [ toEnum $ ansi_color_index c ]

310− ptr'

277+ ptr'

311− Nothing -> return ptr'

278+ Nothing -> return ptr'

312− return ptr''

279+ return ptr''

313− apply_color_diff _f NoColorChange ptr

280+ apply_color_diff _f NoColorChange ptr

314− = return ptr

281+ = return ptr

315− apply_color_diff _f ColorToDefault _ptr

282+ apply_color_diff _f ColorToDefault _ptr

316− = fail "ColorToDefault is not a possible case for apply_color_diffs"

283+ = fail "ColorToDefault is not a possible case for apply_color_diffs"

317− apply_color_diff f ( SetColor c ) ptr

284+ apply_color_diff f ( SetColor c ) ptr

318− = liftIO $ serialize_cap_expression ( f $ term d )

285+ = serialize_cap_expression (f terminfo_caps)

319− [ toEnum $ ansi_color_index c ]

286+ [ toEnum $ ansi_color_index c ]

320− ptr

287+ ptr

321−

322− default_attr_required_bytes d

323− = cap_expression_required_bytes (set_default_attr $ term d) []

324− serialize_default_attr d out_ptr = do

325− liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr

326

288

327-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not

289-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not

328-- be supported by the terminal.

290-- be supported by the terminal.

src/Graphics/Vty/Terminal/XTermColor.hs+24−77

@@ -4,8 +4,7 @@

4{-# LANGUAGE MagicHash #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE TypeFamilies #-}

7−module Graphics.Vty.Terminal.XTermColor ( terminal_instance

7+module Graphics.Vty.Terminal.XTermColor ( reserve_terminal )

8− )

9 where

8 where

11import Graphics.Vty.Terminal.Interface

10import Graphics.Vty.Terminal.Interface

@@ -19,32 +18,26 @@ import qualified Data.Text.Encoding as T

20import System.IO

19import System.IO

22−-- | An xterm color based terminal is some variant paired with a standard TerminfoBased terminal

23−-- interface.

24−--

25−-- For the most part, xterm terminals just use the TerminfoBased implementation.

26−data XTermColor = XTermColor

27− { xterm_variant :: String

28− , super_term :: TerminalHandle

29− }

30−

31-- | Initialize the display to UTF-8.

21-- | Initialize the display to UTF-8.

32−terminal_instance :: ( Applicative m, MonadIO m ) => String -> Handle -> m XTermColor

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

33−terminal_instance variant out_handle = do

23+reserve_terminal variant out_handle = liftIO $ do

24+ let flushed_put str = do

25+ hPutStr out_handle str

26+ hFlush out_handle

34 -- If the terminal variant is xterm-color use xterm instead since, more often than not,

27 -- If the terminal variant is xterm-color use xterm instead since, more often than not,

35 -- xterm-color is broken.

28 -- xterm-color is broken.

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

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

37 flushed_put set_utf8_char_set

30 flushed_put set_utf8_char_set

38− t <- TerminfoBased.terminal_instance variant' out_handle >>= new_terminal_handle

31+ t <- TerminfoBased.reserve_terminal variant' out_handle

39− return $ XTermColor variant' t

32+ return $ t

40−

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

41−-- | Output immediately followed by a flush.

34+ , release_device = do

42−--

35+ liftIO $ flushed_put set_default_char_set

43−-- \todo move out of this module.

36+ release_device t

44−flushed_put :: MonadIO m => String -> m ()

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

45−flushed_put str = do

38+ { inline_hack = xterm_inline_hack t

46− liftIO $ hPutStr stdout str

39+ }

47− liftIO $ hFlush stdout

40+ }

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

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

50--

43--

@@ -53,58 +46,12 @@ set_utf8_char_set, set_default_char_set :: String

53set_utf8_char_set = "\ESC%G"

46set_utf8_char_set = "\ESC%G"

54set_default_char_set = "\ESC%@"

47set_default_char_set = "\ESC%@"

56−instance Terminal XTermColor where

57− terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"

58−

59− release_terminal t = do

60− flushed_put set_default_char_set

61− release_terminal $ super_term t

62−

63− reserve_display t = reserve_display (super_term t)

64−

65− release_display t = release_display (super_term t)

66−

67− display_terminal_instance t b c = do

68− d <- display_context (super_term t) b

69− return $ c (DisplayContext d)

70−

71− display_bounds t = display_bounds (super_term t)

72−

73− output_byte_buffer t = output_byte_buffer (super_term t)

74−

75− output_handle t = output_handle (super_term t)

76−

77−data DisplayContext = DisplayContext

78− { super_display :: DisplayHandle

79− }

80−

81−instance DisplayTerminal DisplayContext where

82− context_region d = context_region (super_display d)

83−

84− context_color_count d = context_color_count (super_display d)

85−

86− move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)

87− serialize_move_cursor d = serialize_move_cursor (super_display d)

88−

89− show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)

90− serialize_show_cursor d = serialize_show_cursor (super_display d)

91−

92− hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)

93− serialize_hide_cursor d = serialize_hide_cursor (super_display d)

94−

95− attr_required_bytes d = attr_required_bytes (super_display d)

96− serialize_set_attr d = serialize_set_attr (super_display d)

97−

98− default_attr_required_bytes d = default_attr_required_bytes (super_display d)

99− serialize_default_attr d = serialize_default_attr (super_display d)

100−

101− -- | I think xterm is broken: Reseting the background color as the first bytes serialized on a

49+-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a

102− -- new line does not effect the background color xterm uses to clear the line. Which is used

50+-- new line does not effect the background color xterm uses to clear the line. Which is used

103− -- *after* the next newline.

51+-- *after* the next newline.

104− inline_hack d = do

52+xterm_inline_hack :: Terminal -> IO ()

105− let t = case super_display d of

53+xterm_inline_hack t = do

106− DisplayHandle _ t_ _ -> t_

107− let s_utf8 = T.encodeUtf8 $ T.pack "\ESC[K"

54+ let s_utf8 = T.encodeUtf8 $ T.pack "\ESC[K"

108− liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)

55+ send_to_terminal t (utf8_text_required_bytes s_utf8)

109− ( serialize_utf8_text s_utf8 )

56+ (serialize_utf8_text s_utf8)

110

test/Verify/Graphics/Vty/Image.hs+5−6

@@ -6,7 +6,6 @@ module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image

6 where

8import Verify.Graphics.Vty.Attributes

9−import Graphics.Vty.Debug.Image

10import Graphics.Vty.Image

9import Graphics.Vty.Image

12import Verify

11import Verify

@@ -22,16 +21,16 @@ instance Arbitrary UnitImage where

22instance Show UnitImage where

21instance Show UnitImage where

23 show (UnitImage c _) = "UnitImage " ++ show c

22 show (UnitImage c _) = "UnitImage " ++ show c

25−data DefaultImage = DefaultImage Image ImageConstructLog

24+data DefaultImage = DefaultImage Image

27instance Show DefaultImage where

26instance Show DefaultImage where

28− show (DefaultImage i image_log)

27+ show (DefaultImage i)

29− = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i) ++ " " ++ show image_log

28+ = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i)

31instance Arbitrary DefaultImage where

30instance Arbitrary DefaultImage where

32 arbitrary = do

31 arbitrary = do

33− i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image)

32+ i <- return $ char def_attr 'X'

34− return $ DefaultImage i []

33+ return $ DefaultImage i

36data SingleRowSingleAttrImage

35data SingleRowSingleAttrImage

37 = SingleRowSingleAttrImage

36 = SingleRowSingleAttrImage

test/Verify/Graphics/Vty/Picture.hs+4−8

@@ -16,35 +16,31 @@ import Verify

16data DefaultPic = DefaultPic

17 { default_pic :: Picture

18 , default_win :: MockWindow

19− , default_construct_log :: ImageConstructLog

20 }

19 }

22instance Show DefaultPic where

21instance Show DefaultPic where

23− show (DefaultPic pic win image_log)

22+ show (DefaultPic pic win)

24− = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n\t" ++ show image_log ++ "\n"

23+ = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n"

26instance Arbitrary DefaultPic where

25instance Arbitrary DefaultPic where

27 arbitrary = do

26 arbitrary = do

28− DefaultImage image image_construct_events <- arbitrary

27+ DefaultImage image <- arbitrary

29 let win = MockWindow (image_width image) (image_height image)

28 let win = MockWindow (image_width image) (image_height image)

30 return $ DefaultPic (pic_for_image image)

29 return $ DefaultPic (pic_for_image image)

31 win

30 win

32− image_construct_events

34data PicWithBGAttr = PicWithBGAttr

32data PicWithBGAttr = PicWithBGAttr

35 { with_attr_pic :: Picture

33 { with_attr_pic :: Picture

36 , with_attr_win :: MockWindow

34 , with_attr_win :: MockWindow

37− , with_attr_construct_log :: ImageConstructLog

38 , with_attr_specified_attr :: Attr

35 , with_attr_specified_attr :: Attr

39 } deriving ( Show )

36 } deriving ( Show )

41instance Arbitrary PicWithBGAttr where

38instance Arbitrary PicWithBGAttr where

42 arbitrary = do

39 arbitrary = do

43− DefaultImage image image_construct_events <- arbitrary

40+ DefaultImage image <- arbitrary

44 let win = MockWindow (image_width image) (image_height image)

41 let win = MockWindow (image_width image) (image_height image)

45 attr <- arbitrary

42 attr <- arbitrary

46 return $ PicWithBGAttr (pic_for_image image)

43 return $ PicWithBGAttr (pic_for_image image)

47 win

44 win

48− image_construct_events

49 attr

45 attr

test/VerifyInline.hs+1−1

@@ -12,7 +12,7 @@ tests = return

12 [ Test $ TestInstance

13 { name = "verify vty inline"

14 , run = do

15− t <- terminal_handle

15+ t <- current_terminal

16 put_attr_change t $ default_all

17 return $ Finished Pass

18 , tags = []

test/VerifySpanOps.hs+3−3

@@ -118,20 +118,20 @@ horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i,

118 in verify_all_spans_have_width i spans greater_width

119

120arb_image_is_cropped :: DefaultImage -> MockWindow -> Bool

121−arb_image_is_cropped (DefaultImage image _) win@(MockWindow w h) =

121+arb_image_is_cropped (DefaultImage image) win@(MockWindow w h) =

122 let pic = pic_for_image image

123 spans = spans_for_pic pic (region_for_window win)

124 in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w )

125

126span_ops_actually_fill_rows :: DefaultPic -> Bool

127−span_ops_actually_fill_rows (DefaultPic pic win _) =

127+span_ops_actually_fill_rows (DefaultPic pic win) =

128 let spans = spans_for_pic pic (region_for_window win)

129 expected_row_count = region_height (region_for_window win)

130 actual_row_count = span_ops_effected_rows spans

131 in expected_row_count == actual_row_count

132

133span_ops_actually_fill_columns :: DefaultPic -> Bool

134−span_ops_actually_fill_columns (DefaultPic pic win _) =

134+span_ops_actually_fill_columns (DefaultPic pic win) =

135 let spans = spans_for_pic pic (region_for_window win)

136 expected_column_count = region_width (region_for_window win)

137 in all_spans_have_width spans expected_column_count

test/VerifyTerminal.hs+22−22

@@ -20,29 +20,29 @@ import System.IO

21unit_image_unit_bounds :: UnitImage -> Property

22unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do

23− t <- terminal_instance (DisplayRegion 1 1)

23+ (_,t) <- mock_terminal (DisplayRegion 1 1)

24− d <- display_bounds t >>= display_context t

24+ dc <- display_bounds t >>= display_context t

25 let pic = pic_for_image i

26− output_picture d pic

26+ output_picture dc pic

27 return succeeded

29unit_image_arb_bounds :: UnitImage -> MockWindow -> Property

30unit_image_arb_bounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do

31− t <- terminal_instance (DisplayRegion w h)

31+ (_,t) <- mock_terminal (DisplayRegion w h)

32− d <- display_bounds t >>= display_context t

32+ dc <- display_bounds t >>= display_context t

33 let pic = pic_for_image i

34− output_picture d pic

34+ output_picture dc pic

35 return succeeded

37single_T_row :: MockWindow -> Property

38single_T_row (MockWindow w h) = liftIOResult $ do

39− t <- terminal_instance (DisplayRegion w h)

39+ (mock_data,t) <- mock_terminal (DisplayRegion w h)

40− d <- display_bounds t >>= display_context t

40+ dc <- display_bounds t >>= display_context t

41 -- create an image that contains just the character T repeated for a single row

42 let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

43 pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

44− output_picture d pic

44+ output_picture dc pic

45− out_bytes <- readIORef (mock_terminal_last_output $ dehandle t) >>= return . UTF8.toRep

45+ out_bytes <- readIORef mock_data >>= return . UTF8.toRep

46 -- The UTF8 string that represents the output bytes a single line containing the T string:

47 let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T'

48 -- Followed by h - 1 lines of a change to the background attribute and then the background

@@ -55,13 +55,13 @@ single_T_row (MockWindow w h) = liftIOResult $ do

56many_T_rows :: MockWindow -> Property

57many_T_rows (MockWindow w h) = liftIOResult $ do

58− t <- terminal_instance (DisplayRegion w h)

58+ (mock_data, t) <- mock_terminal (DisplayRegion w h)

59− d <- display_bounds t >>= display_context t

59+ dc <- display_bounds t >>= display_context t

60 -- create an image that contains the character 'T' repeated for all the rows

61 let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

62 pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

63− output_picture d pic

63+ output_picture dc pic

64− out_bytes <- readIORef (mock_terminal_last_output $ dehandle t) >>= return . UTF8.toRep

64+ out_bytes <- readIORef mock_data >>= return . UTF8.toRep

65 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

66 -- attribute change. 'A', followed by w 'T's

67 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

@@ -72,13 +72,13 @@ many_T_rows (MockWindow w h) = liftIOResult $ do

73many_T_rows_cropped_width :: MockWindow -> Property

74many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do

75− t <- terminal_instance (DisplayRegion w h)

75+ (mock_data,t) <- mock_terminal (DisplayRegion w h)

76− d <- display_bounds t >>= display_context t

76+ dc <- display_bounds t >>= display_context t

77 -- create an image that contains the character 'T' repeated for all the rows

78 let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T')

79 pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

80− output_picture d pic

80+ output_picture dc pic

81− out_bytes <- readIORef (mock_terminal_last_output $ dehandle t) >>= return . UTF8.toRep

81+ out_bytes <- readIORef mock_data >>= return . UTF8.toRep

82 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

83 -- attribute change. 'A', followed by w 'T's

84 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

@@ -89,13 +89,13 @@ many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do

90many_T_rows_cropped_height :: MockWindow -> Property

91many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do

92− t <- terminal_instance (DisplayRegion w h)

92+ (mock_data,t) <- mock_terminal (DisplayRegion w h)

93− d <- display_bounds t >>= display_context t

93+ dc <- display_bounds t >>= display_context t

94 -- create an image that contains the character 'T' repeated for all the rows

95 let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

96 pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

97− output_picture d pic

97+ output_picture dc pic

98− out_bytes <- readIORef (mock_terminal_last_output $ dehandle t) >>= return . UTF8.toRep

98+ out_bytes <- readIORef mock_data >>= return . UTF8.toRep

99 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

100 -- attribute change. 'A', followed by w count 'T's

101 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

test/VerifyTerminfoBased.hsnew file+8

@@ -0,0 +1,8 @@

1+module VerifyTerminfoBased where

2+import Verify

4+import Graphics.Vty.Terminal.TerminfoBased

6+tests :: IO [Test]

7+tests = return

8+ []

test/current_benchmark_results.txt+4

@@ -1,3 +1,7 @@

1+pre-release 5.0

2+[("no-diff-opt-0",147,8),("render-char-0",332,18),("render-char-1",277,16),("vertical-scroll-0",1503,61),("image-fuzz-0",46,3)]

3+[("no-diff-opt-0",137,11),("render-char-0",470,18),("render-char-1",254,18),("vertical-scroll-0",1240,56),("image-fuzz-0",46,3)]

4+release 4.7

1starting no-diff-opt-0

5starting no-diff-opt-0

2user time: 226

6user time: 226

3system time: 13

7system time: 13

test/interactive_terminal_test.hs+38−47

@@ -78,11 +78,11 @@ failure".

78 ( \ (_ :: SomeException) -> return (env_name, "") )

79 )

80 [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]

81− t <- terminal_handle

81+ t <- current_terminal

82 let results_txt = show env_attributes ++ "\n"

83 ++ terminal_ID t ++ "\n"

84 ++ show results ++ "\n"

85− release_terminal t

85+ release_device t

86 writeFile output_file_path results_txt

88wait_for_return = do

@@ -179,7 +179,7 @@ reserve_output_test = Test

179 { test_name = "Initialize and reserve terminal output then restore previous state."

180 , test_ID = "reserve_output_test"

181 , test_action = do

182− t <- terminal_handle

182+ t <- current_terminal

183 reserve_display t

184 putStrLn "Line 1"

185 putStrLn "Line 2"

@@ -188,7 +188,7 @@ reserve_output_test = Test

188 hFlush stdout

189 getLine

190 release_display t

191− release_terminal t

191+ release_device t

192 return ()

193 , print_summary = do

194 putStr $ [s|

@@ -212,7 +212,7 @@ display_bounds_test_0 = Test

212 { test_name = "Verify display bounds are correct test 0: Using spaces."

213 , test_ID = "display_bounds_test_0"

214 , test_action = do

215− t <- terminal_handle

215+ t <- current_terminal

216 reserve_display t

217 DisplayRegion w h <- display_bounds t

218 let row_0 = replicate (fromEnum w) 'X' ++ "\n"

@@ -223,7 +223,7 @@ display_bounds_test_0 = Test

223 hFlush stdout

224 getLine

225 release_display t

226− release_terminal t

226+ release_device t

227 return ()

228 , print_summary = display_bounds_test_summary True

229 , confirm_results = generic_output_match_confirm

@@ -233,7 +233,7 @@ display_bounds_test_1 = Test

233 { test_name = "Verify display bounds are correct test 0: Using cursor movement."

234 , test_ID = "display_bounds_test_1"

235 , test_action = do

236− t <- terminal_handle

236+ t <- current_terminal

237 reserve_display t

238 DisplayRegion w h <- display_bounds t

239 set_cursor_pos t 0 0

@@ -252,7 +252,7 @@ display_bounds_test_1 = Test

252 hFlush stdout

253 getLine

254 release_display t

255− release_terminal t

255+ release_device t

256 return ()

257 , print_summary = display_bounds_test_summary True

258 , confirm_results = generic_output_match_confirm

@@ -262,7 +262,7 @@ display_bounds_test_2 = Test

262 { test_name = "Verify display bounds are correct test 0: Using Image ops."

263 , test_ID = "display_bounds_test_2"

264 , test_action = do

265− t <- terminal_handle

265+ t <- current_terminal

266 reserve_display t

267 bounds@(DisplayRegion w h) <- display_bounds t

268 let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')

@@ -275,7 +275,7 @@ display_bounds_test_2 = Test

275 output_picture d pic

276 getLine

277 release_display t

278− release_terminal t

278+ release_device t

279 return ()

280 , print_summary = display_bounds_test_summary True

281 , confirm_results = generic_output_match_confirm

@@ -285,7 +285,7 @@ display_bounds_test_3 = Test

285 { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."

286 , test_ID = "display_bounds_test_3"

287 , test_action = do

288− t <- terminal_handle

288+ t <- current_terminal

289 reserve_display t

290 DisplayRegion w h <- display_bounds t

291 hide_cursor t

@@ -306,7 +306,7 @@ display_bounds_test_3 = Test

306 getLine

307 show_cursor t

308 release_display t

309− release_terminal t

309+ release_device t

310 return ()

311 , print_summary = display_bounds_test_summary False

312 , confirm_results = generic_output_match_confirm

@@ -397,7 +397,7 @@ unicode_single_width_0 = Test

397 { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"

398 , test_ID = "unicode_single_width_0"

399 , test_action = do

400− t <- terminal_handle

400+ t <- current_terminal

401 reserve_display t

402 hide_cursor t

403 withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)

@@ -406,7 +406,7 @@ unicode_single_width_0 = Test

406 hFlush stdout

407 getLine

408 release_display t

409− release_terminal t

409+ release_device t

410 return ()

411 , print_summary = unicode_single_width_summary

412 , confirm_results = generic_output_match_confirm

@@ -416,7 +416,7 @@ unicode_single_width_1 = Test

416 { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"

417 , test_ID = "unicode_single_width_1"

418 , test_action = do

419− t <- terminal_handle

419+ t <- current_terminal

420 reserve_display t

421 let pic = pic_for_image image

422 image = line_0 <-> line_1

@@ -426,7 +426,7 @@ unicode_single_width_1 = Test

426 output_picture d pic

427 getLine

428 release_display t

429− release_terminal t

429+ release_device t

430 return ()

431 , print_summary = unicode_single_width_summary

432 , confirm_results = generic_output_match_confirm

@@ -479,7 +479,7 @@ unicode_double_width_0 = Test

479 { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"

480 , test_ID = "unicode_double_width_0"

481 , test_action = do

482− t <- terminal_handle

482+ t <- current_terminal

483 reserve_display t

484 hide_cursor t

485 withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)

@@ -488,7 +488,7 @@ unicode_double_width_0 = Test

488 hFlush stdout

489 getLine

490 release_display t

491− release_terminal t

491+ release_device t

492 return ()

493 , print_summary = unicode_double_width_summary

494 , confirm_results = generic_output_match_confirm

@@ -498,7 +498,7 @@ unicode_double_width_1 = Test

498 { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"

499 , test_ID = "unicode_double_width_1"

500 , test_action = do

501− t <- terminal_handle

501+ t <- current_terminal

502 reserve_display t

503 let pic = pic_for_image image

504 image = line_0 <-> line_1

@@ -508,7 +508,7 @@ unicode_double_width_1 = Test

508 output_picture d pic

509 getLine

510 release_display t

511− release_terminal t

511+ release_device t

512 return ()

513 , print_summary = unicode_double_width_summary

514 , confirm_results = generic_output_match_confirm

@@ -552,7 +552,7 @@ attributes_test_0 = Test

552 { test_name = "Character attributes: foreground colors."

553 , test_ID = "attributes_test_0"

554 , test_action = do

555− t <- terminal_handle

555+ t <- current_terminal

556 reserve_display t

557 let pic = pic_for_image image

558 image = border <|> column_0 <|> border <|> column_1 <|> border

@@ -564,7 +564,7 @@ attributes_test_0 = Test

564 output_picture d pic

565 getLine

566 release_display t

567− release_terminal t

567+ release_device t

568 return ()

569 , print_summary = do

570 putStr $ [s|

@@ -598,7 +598,7 @@ attributes_test_1 = Test

598 { test_name = "Character attributes: background colors."

599 , test_ID = "attributes_test_1"

600 , test_action = do

601− t <- terminal_handle

601+ t <- current_terminal

602 reserve_display t

603 let pic = pic_for_image image

604 image = border <|> column_0 <|> border <|> column_1 <|> border

@@ -610,7 +610,7 @@ attributes_test_1 = Test

610 output_picture d pic

611 getLine

612 release_display t

613− release_terminal t

613+ release_device t

614 return ()

615 , print_summary = do

616 putStr $ [s|

@@ -653,7 +653,7 @@ attributes_test_2 = Test

653 { test_name = "Character attributes: Vivid foreground colors."

654 , test_ID = "attributes_test_2"

655 , test_action = do

656− t <- terminal_handle

656+ t <- current_terminal

657 reserve_display t

658 let pic = pic_for_image image

659 image = horiz_cat [border, column_0, border, column_1, border, column_2, border]

@@ -667,7 +667,7 @@ attributes_test_2 = Test

667 output_picture d pic

668 getLine

669 release_display t

670− release_terminal t

670+ release_device t

671 return ()

672 , print_summary = do

673 putStr $ [s|

@@ -712,7 +712,7 @@ attributes_test_3 = Test

712 { test_name = "Character attributes: Vivid background colors."

713 , test_ID = "attributes_test_3"

714 , test_action = do

715− t <- terminal_handle

715+ t <- current_terminal

716 reserve_display t

717 let pic = pic_for_image image

718 image = horiz_cat [border, column_0, border, column_1, border, column_2, border]

@@ -726,7 +726,7 @@ attributes_test_3 = Test

726 output_picture d pic

727 getLine

728 release_display t

729− release_terminal t

729+ release_device t

730 return ()

731 , print_summary = do

732 putStr $ [s|

@@ -790,7 +790,7 @@ attributes_test_4 = Test

790 { test_name = "Character attributes: Bold; Blink; Underline."

791 , test_ID = "attributes_test_4"

792 , test_action = do

793− t <- terminal_handle

793+ t <- current_terminal

794 reserve_display t

795 let pic = pic_for_image image

796 image = horiz_cat [border, column_0, border, column_1, border]

@@ -802,7 +802,7 @@ attributes_test_4 = Test

802 output_picture d pic

803 getLine

804 release_display t

805− release_terminal t

805+ release_device t

806 return ()

807 , print_summary = do

808 putStr $ [s|

@@ -842,7 +842,7 @@ attributes_test_5 = Test

842 { test_name = "Character attributes: 240 color palette"

843 , test_ID = "attributes_test_5"

844 , test_action = do

845− t <- terminal_handle

845+ t <- current_terminal

846 reserve_display t

847 let pic = pic_for_image image

848 image = vert_cat $ map horiz_cat $ split_color_images color_images

@@ -853,7 +853,7 @@ attributes_test_5 = Test

853 output_picture d pic

854 getLine

855 release_display t

856− release_terminal t

856+ release_device t

857 return ()

858 , print_summary = do

859 putStr $ [s|

@@ -880,14 +880,11 @@ inline_test_0 = Test

880 { test_name = "Verify styled output can be performed without clearing the screen."

881 , test_ID = "inline_test_0"

882 , test_action = do

883− t <- terminal_handle

884 putStrLn "line 1."

883 putStrLn "line 1."

885− put_attr_change t $ back_color red >> apply_style underline

884+ put_attr_change_ $ back_color red >> apply_style underline

886 putStrLn "line 2."

885 putStrLn "line 2."

887− put_attr_change t $ default_all

886+ put_attr_change_ $ default_all

888 putStrLn "line 3."

887 putStrLn "line 3."

889− release_terminal t

890− return ()

891 , print_summary = putStr $ [s|

888 , print_summary = putStr $ [s|

892lines are in order.

889lines are in order.

893The second line "line 2" should have a red background and the text underline.

890The second line "line 2" should have a red background and the text underline.

@@ -901,14 +898,11 @@ inline_test_1 = Test

901 { test_name = "Verify styled output can be performed without clearing the screen."

898 { test_name = "Verify styled output can be performed without clearing the screen."

902 , test_ID = "inline_test_1"

899 , test_ID = "inline_test_1"

903 , test_action = do

900 , test_action = do

904− t <- terminal_handle

905 putStr "Not styled. "

901 putStr "Not styled. "

906− put_attr_change t $ back_color red >> apply_style underline

902+ put_attr_change_ $ back_color red >> apply_style underline

907 putStr " Styled! "

903 putStr " Styled! "

908− put_attr_change t $ default_all

904+ put_attr_change_ $ default_all

909 putStrLn "Not styled."

905 putStrLn "Not styled."

910− release_terminal t

911− return ()

912 , print_summary = putStr $ [s|

906 , print_summary = putStr $ [s|

913|]

907|]

914

908

@@ -919,14 +913,11 @@ inline_test_2 = Test

919 { test_name = "Verify styled output can be performed without clearing the screen."

913 { test_name = "Verify styled output can be performed without clearing the screen."

920 , test_ID = "inline_test_1"

914 , test_ID = "inline_test_1"

921 , test_action = do

915 , test_action = do

922− t <- terminal_handle

923 putStr "Not styled. "

916 putStr "Not styled. "

924− put_attr_change t $ back_color red >> apply_style underline

917+ put_attr_change_ $ back_color red >> apply_style underline

925 putStr " Styled! "

918 putStr " Styled! "

926− put_attr_change t $ default_all

919+ put_attr_change_ $ default_all

927 putStr "Not styled.\n"

920 putStr "Not styled.\n"

928− release_terminal t

929− return ()

930 , print_summary = putStr $ [s|

921 , print_summary = putStr $ [s|

931|]

922|]

932 , confirm_results = generic_output_match_confirm

923 , confirm_results = generic_output_match_confirm

test/vty_inline_example.hs+2−5

@@ -2,11 +2,8 @@ import Graphics.Vty

2import Graphics.Vty.Inline

4main = do

5− t <- terminal_handle

6 putStr "Not styled. "

5 putStr "Not styled. "

7− put_attr_change t $ back_color red >> apply_style underline

6+ put_attr_change_ t $ back_color red >> apply_style underline

8 putStr " Styled! "

7 putStr " Styled! "

9− put_attr_change t $ default_all

8+ put_attr_change_ t $ default_all

10 putStrLn "Not styled."

9 putStrLn "Not styled."

11− release_terminal t

12− return ()

vty.cabal+3−2

@@ -43,7 +43,7 @@ library

43 containers,

44 deepseq >= 1.1 && < 1.4,

45 ghc-prim,

46− lens,

46+ lens >= 3.9.0.2,

47 mtl >= 1.1.1.0 && < 2.2,

48 parallel >= 2.2 && < 3.3,

49 parsec >= 2 && < 4,

@@ -68,7 +68,6 @@ library

68 Data.Terminfo.Eval

69 Data.Marshalling

70 Graphics.Vty.Debug

71− Graphics.Vty.Debug.Image

72 Graphics.Vty.DisplayRegion

71 Graphics.Vty.DisplayRegion

73 Graphics.Vty.DisplayAttributes

72 Graphics.Vty.DisplayAttributes

74 Graphics.Vty.Image.Internal

73 Graphics.Vty.Image.Internal

@@ -80,6 +79,8 @@ library

80 Graphics.Vty.Terminal.XTermColor

79 Graphics.Vty.Terminal.XTermColor

81 Graphics.Vty.Terminal.TerminfoBased

80 Graphics.Vty.Terminal.TerminfoBased

82+ other-modules: Graphics.Vty.Inline.Hack

83+

83 c-sources: cbits/gwinsz.c

84 c-sources: cbits/gwinsz.c

84 cbits/set_term_timing.c

85 cbits/set_term_timing.c

85 cbits/mk_wcwidth.c

86 cbits/mk_wcwidth.c