fd3df90 · vty · git.iko.soy

git.iko.soy/vty

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

commitfd3df90f1f90c959405f5d86116bb3665da13e29 authorCorey O'Connor <coreyoconnor@gmail.com> dateSun 7 Jul 2013, 13:55 (13 years ago) parent4f05357

20 files changed+616−822

compare with master

unifiedsplit

README.md+8−7

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

5959

6060## Coverage

6161

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

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

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

65−

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

67−

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

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

63+follows:

64+

65+~~~

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

67+ --disable-library-profiling \

68+ --disable-executable-profiling

69+~~~

src/Graphics/Vty.hs+11−11

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

4444 update :: Picture -> IO ()

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

4646 , next_event :: IO Event

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

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

4848 --

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

5050 --

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

6060 -- input backend for implementation.

6161 --

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

63− , terminal :: TerminalHandle

63+ , terminal :: Terminal

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

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

6666 -- might want to force a refresh.

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

8181mkVtyEscDelay :: Int -> IO Vty

8282mkVtyEscDelay escDelay = do

8383 term_info <- Terminfo.setupTermFromEnv

84− t <- terminal_handle

84+ t <- current_terminal

8585 reserve_display t

8686 (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

8888

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

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

9090intMkVty kvar fend t = do

9191 last_pic_ref <- newIORef Nothing

9292 last_update_ref <- newIORef Nothing

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

111111 mlast_update <- readIORef last_update_ref

112112 update_data <- case mlast_update of

113113 Nothing -> do

114− d <- display_context t b

115− output_picture d in_pic'

116− return (b, d)

114+ dc <- display_context t b

115+ output_picture dc in_pic'

116+ return (b, dc)

117117 Just (last_bounds, last_context) -> do

118118 if b /= last_bounds

119119 then do

120− d <- display_context t b

121− output_picture d in_pic'

122− return (b, d)

120+ dc <- display_context t b

121+ output_picture dc in_pic'

122+ return (b, dc)

123123 else do

124124 output_picture last_context in_pic'

125125 return (b, last_context)

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

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

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

1010--

1111-- @

12−-- t <- terminal_handle

1312-- putStr \"Not styled. \"

14−-- put_attr_change t $ do

13+-- put_attr_change_ $ do

1514-- back_color red

1615-- apply_style underline

1716-- putStr \" Styled! \"

18−-- put_attr_change t $ default_all

17+-- put_attr_change_ $ default_all

1918-- putStrLn \"Not styled.\"

20−-- release_terminal t

2119-- @

2220--

2321-- '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

3331

3432import Graphics.Vty.Attributes

3533import Graphics.Vty.DisplayAttributes

34+import Graphics.Vty.Inline.Hack

3635import Graphics.Vty.Terminal.Interface

36+import Graphics.Vty.Terminal

3737

3838import Control.Applicative

3939import Control.Monad.State.Strict

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

7676default_all :: InlineM ()

7777default_all = put def_attr

7878

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

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

8080--

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

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

83−put_attr_change t c = do

81+-- This does not flush the terminal.

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

83+put_attr_change t c = liftIO $ do

8484 bounds <- display_bounds t

85− d <- display_context t bounds

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

85+ dc <- display_context t bounds

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

8787 fattr <- case mfattr of

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

9090 return $ FixedAttr default_style_mask Nothing Nothing

9191 Just v -> return v

9292 let attr = execState c current_attr

93− attr' = limit_attr_for_display d attr

93+ attr' = limit_attr_for_display t attr

9494 fattr' = fix_display_attr fattr attr'

9595 diffs = display_attr_diffs fattr fattr'

96− liftIO $ hFlush stdout

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

98− ( serialize_set_attr d fattr attr' diffs )

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

100− inline_hack d

101− liftIO $ hFlush stdout

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

97+ (serialize_set_attr dc fattr attr' diffs)

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

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

116+ hFlush stdout

102117

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

2121{-# LANGUAGE ScopedTypeVariables #-}

2222module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal

23− , Terminal(..)

24− , TerminalHandle(..)

25− , DisplayHandle(..)

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

24+ , AssumedState(..)

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

2626 , output_picture

2727 , display_context

2828 )

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

4747import System.Environment

4848import System.IO

4949

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

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

5151--

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

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

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

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

8585--

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

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

88−terminal_handle = do

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

88+current_terminal = do

8989 term_type <- liftIO $ getEnv "TERM"

9090 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

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

9296 then do

9397 maybe_terminal_app <- get_env "TERM_PROGRAM"

9498 case maybe_terminal_app of

95− Nothing

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

99+ Nothing

100+ -> XTermColor.reserve_terminal term_type out_handle

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

98102 -> do

99103 maybe_xterm <- get_env "XTERM_VERSION"

100104 case maybe_xterm of

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

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

105+ Nothing -> MacOSX.reserve_terminal v out_handle

106+ Just _ -> XTermColor.reserve_terminal term_type out_handle

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

104108 -- like terminal?

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

109+ _ -> XTermColor.reserve_terminal term_type out_handle

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

108112 return t

109113 where

110114 get_env var = do

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

120124--

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

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

124128set_cursor_pos t x y = do

125129 bounds <- display_bounds t

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

127− d <- display_context t bounds

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

131+ dc <- display_context t bounds

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

129133

130134-- | Hides the cursor

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

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

132136hide_cursor t = do

133137 bounds <- display_bounds t

134− d <- display_context t bounds

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

138+ dc <- display_context t bounds

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

136140

137141-- | Shows the cursor

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

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

139143show_cursor t = do

140144 bounds <- display_bounds t

141− d <- display_context t bounds

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

145+ dc <- display_context t bounds

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

143147

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

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

11-- Copyright Corey O'Connor

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

23{-# LANGUAGE BangPatterns #-}

34{-# LANGUAGE RankNTypes #-}

45{-# LANGUAGE ScopedTypeVariables #-}

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

1819

1920import Graphics.Vty.DisplayAttributes

2021

21−import Control.Monad ( liftM )

22+import Control.Monad.Fix

2223import Control.Monad.Trans

2324

2425import qualified Data.ByteString.Internal as BS

2526import Data.IORef

2627import qualified Data.Vector as Vector

2728

28−import System.IO

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.

53− terminal_ID :: t -> String

54− -- |

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

29+data Terminal = Terminal

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

31+ terminal_ID :: String

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

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

5734 --

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

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

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

6441 -- access to a display such that:

6542 -- - The previous state cannot be determined

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

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

68−

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

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

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

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

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

72−

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

7348 -- | Returns the current display bounds.

74− display_bounds :: MonadIO m => t -> 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−

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

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

8551 -- end_ptr - start_ptr

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

87−

88− -- | Handle of output device

89− output_handle :: t -> IO Handle

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

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

54+ , context_color_count :: Int

55+ , assumed_state_ref :: IORef AssumedState

56+ , mk_display_context :: DisplayContext -> IO DisplayContext

57+ }

9058

91−instance Terminal TerminalHandle where

92− terminal_ID (TerminalHandle t _) = terminal_ID t

93− release_terminal (TerminalHandle t _) = release_terminal t

94− reserve_display (TerminalHandle t _) = reserve_display t

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

59+data AssumedState = AssumedState

60+ { prev_fattr :: Maybe FixedAttr

61+ , prev_output_ops :: Maybe DisplayOps

62+ }

10063

101−data DisplayHandle where

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

64+initial_assumed_state :: AssumedState

65+initial_assumed_state = AssumedState Nothing Nothing

10366

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

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

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

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

108−display_context t b = do

109− s <- initial_display_state

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

111−

112−data DisplayState = DisplayState

113− { previous_output_ref :: IORef (Maybe DisplayOps)

114− }

115−

116−initial_display_state :: MonadIO m => m DisplayState

117−initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing

118−

119−class DisplayTerminal d where

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

121− context_region :: d -> DisplayRegion

122−

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

124− context_color_count :: d -> Int

125−

70+display_context :: MonadIO m

71+ => Terminal

72+ -> DisplayRegion

73+ -> m DisplayContext

74+display_context t r = liftIO $ do

75+ let def_context self = DisplayContext

76+ { context_region = r

77+ , context_device = t

78+ , move_cursor_required_bytes = move_cursor_required_bytes self

79+ , serialize_move_cursor = serialize_move_cursor self

80+ , show_cursor_required_bytes = show_cursor_required_bytes self

81+ , serialize_show_cursor = serialize_show_cursor self

82+ , hide_cursor_required_bytes = hide_cursor_required_bytes self

83+ , serialize_hide_cursor = serialize_hide_cursor self

84+ , attr_required_bytes = attr_required_bytes self

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

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

94+ context_region :: DisplayRegion

95+ , context_device :: Terminal

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

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

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

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

130−

131− show_cursor_required_bytes :: d -> Int

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

133−

134− hide_cursor_required_bytes :: d -> Int

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

136−

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

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

100+ , show_cursor_required_bytes :: Int

101+ , serialize_show_cursor :: OutputBuffer -> IO OutputBuffer

102+ , hide_cursor_required_bytes :: Int

103+ , serialize_hide_cursor :: OutputBuffer -> IO OutputBuffer

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

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

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

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

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

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

147114 -- display attributes.

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

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

150−

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

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

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

152− default_attr_required_bytes :: d -> Int

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

154−

118+ , default_attr_required_bytes :: Int

119+ , serialize_default_attr :: OutputBuffer -> IO OutputBuffer

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

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

157− inline_hack _d = return ()

158−

121+ , inline_hack :: IO ()

122+ }

159123

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−

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

176125utf8_text_required_bytes :: BS.ByteString -> Int

177126utf8_text_required_bytes str =

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

179128 in src_bytes_length

180129

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

183132serialize_utf8_text str dest_ptr =

184133 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

186135 let src_ptr' = src_ptr `plusPtr` src_ptr_offset

187136 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)

188137 return (dest_ptr `plusPtr` src_bytes_length)

189138

190−

191139-- | Displays the given `Picture`.

192140--

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

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

199147-- 3. Serialized to the display.

200148--

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

202−--

203150--

204151-- todo: specify possible IO exceptions.

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

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

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

208− let !r = context_region d

209− let !ops = spans_for_pic pic r

210− let !initial_attr = FixedAttr default_style_mask Nothing Nothing

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

212− -- basis.

213− diffs :: [Bool]

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 )

218− True

219− Just previous_ops

220− -> if effected_region previous_ops /= effected_region ops

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

222− True

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

224− ( Vector.toList $ display_ops ops )

225−

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

227− let total = hide_cursor_required_bytes d

228− + default_attr_required_bytes d

229− + required_bytes d initial_attr diffs ops

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

154+output_picture dc pic = liftIO $ do

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

156+ let !r = context_region dc

157+ !ops = spans_for_pic pic r

158+ !initial_attr = FixedAttr default_style_mask Nothing Nothing

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

160+ -- basis.

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

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

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

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

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

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

167+ (Vector.toList $ display_ops ops)

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

169+ total = hide_cursor_required_bytes dc

170+ + default_attr_required_bytes dc

171+ + required_bytes dc initial_attr diffs ops

230172 + case pic_cursor pic of

231173 NoCursor -> 0

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

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

234− in show_cursor_required_bytes d

235− + move_cursor_required_bytes d ox oy

236−

176+ in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy

237177 -- ... then serialize

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

239− ptr <- serialize_hide_cursor d start_ptr

240− ptr' <- serialize_default_attr d ptr

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

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

179+ ptr <- serialize_hide_cursor dc start_ptr

180+ ptr' <- serialize_default_attr dc ptr

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

242182 end_ptr <- case pic_cursor pic of

243183 NoCursor -> return ptr''

244184 Cursor x y -> do

245185 let m = cursor_output_map ops $ pic_cursor pic

246186 (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

248188 -- todo: How to handle exceptions?

249189 case end_ptr `minusPtr` start_ptr of

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

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

253193 -- Cache the output spans.

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

255− return ()

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

195+ writeIORef (assumed_state_ref $ context_device dc) as'

256196

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

258−required_bytes d in_fattr diffs ops =

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

198+required_bytes dc in_fattr diffs ops =

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

260200 in n

261201 where

262202 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

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

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

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

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

268208 = error "shouldn't be possible"

269209

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

271−span_ops_required_bytes d y in_fattr span_ops =

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

211+span_ops_required_bytes dc y in_fattr span_ops =

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

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

276216 in (c + current_sum, fattr')

277217 )

278218 (header_required_bytes, in_fattr)

279219 span_ops

280220

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

282−span_op_required_bytes d fattr (AttributeChange attr) =

283− let attr' = limit_attr_for_display d attr

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

222+span_op_required_bytes dc fattr (AttributeChange attr) =

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

284224 diffs = display_attr_diffs fattr fattr'

285− c = attr_required_bytes d fattr attr' diffs

225+ c = attr_required_bytes dc fattr attr' diffs

286226 fattr' = fix_display_attr fattr attr'

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

289229

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

291− => d

230+serialize_output_ops :: DisplayContext

292231 -> OutputBuffer

293232 -> FixedAttr

294233 -> [Bool]

295234 -> DisplayOps

296− -> m OutputBuffer

297−serialize_output_ops d start_ptr in_fattr diffs ops = do

235+ -> IO OutputBuffer

236+serialize_output_ops dc start_ptr in_fattr diffs ops = do

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

299238 ( 0, start_ptr, in_fattr, diffs )

300239 ( display_ops ops )

301240 return end_ptr

302241 where

303242 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

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

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

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

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

309248 = error "shouldn't be possible"

310249

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

312− => d

250+serialize_span_ops :: DisplayContext

313251 -> Int

314252 -> OutputBuffer

315253 -> FixedAttr

316254 -> SpanOps

317− -> m (OutputBuffer, FixedAttr)

318−serialize_span_ops d y out_ptr in_fattr span_ops = do

255+ -> IO (OutputBuffer, FixedAttr)

256+serialize_span_ops dc y out_ptr in_fattr span_ops = do

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

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

323261 (out_ptr', in_fattr)

324262 span_ops

325263

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

327− => d

264+serialize_span_op :: DisplayContext

328265 -> SpanOp

329266 -> OutputBuffer

330267 -> FixedAttr

331− -> m (OutputBuffer, FixedAttr)

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

333− let attr' = limit_attr_for_display d attr

268+ -> IO (OutputBuffer, FixedAttr)

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

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

334271 fattr' = fix_display_attr fattr attr'

335272 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

337274 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

339276 out_ptr' <- serialize_utf8_text str out_ptr

340277 return (out_ptr', fattr)

341278

342−marshall_to_terminal :: ( Terminal t )

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

344−marshall_to_terminal t c f = do

345− start_ptr <- mallocBytes (fromEnum c)

346− --

347− -- todo: capture exceptions?

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

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

348281 end_ptr <- f start_ptr

349282 case end_ptr `minusPtr` start_ptr of

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

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

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

353− free start_ptr

354− return ()

355286

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

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

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

391322

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

393324-- given terminal can display.

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

395−limit_attr_for_display d attr

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

326+limit_attr_for_display t attr

396327 = attr { attr_fore_color = clamp_color $ attr_fore_color attr

397328 , attr_back_color = clamp_color $ attr_back_color attr

398329 }

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

401332 clamp_color KeepCurrent = KeepCurrent

402333 clamp_color (SetTo c) = clamp_color' c

403334 clamp_color' (ISOColor v)

404− | context_color_count d < 8 = Default

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

335+ | context_color_count t < 8 = Default

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

406337 | otherwise = SetTo $ ISOColor v

407338 clamp_color' (Color240 v)

408339 -- TODO: Choose closes ISO color?

409− | context_color_count d < 8 = Default

410− | context_color_count d < 16 = Default

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

340+ | context_color_count t < 8 = Default

341+ | context_color_count t < 16 = Default

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

412343 | otherwise

413344 = 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)

415346 in SetTo $ Color240 v'

416347

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

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

1010{-# LANGUAGE MagicHash #-}

1111{-# LANGUAGE FlexibleInstances #-}

1212{-# LANGUAGE TypeFamilies #-}

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

14− )

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

1514 where

1615

1716import Graphics.Vty.Terminal.Interface

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

2221

2322import System.IO

2423

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−

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

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

3326--

3427-- This effects the terminfo lookup.

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

36−terminal_instance v out_handle = do

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

38− base_term _ = "xterm"

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

40− return $ Term t v

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

29+reserve_terminal v out_handle = do

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

31+ remap_term _ = "xterm"

32+ flushed_put :: String -> IO ()

33+ flushed_put str = do

34+ hPutStr out_handle str

35+ hFlush out_handle

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

37+ return $ t

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

39+ , reserve_display = terminal_app_reserve_display flushed_put

40+ , release_display = terminal_app_release_display flushed_put

41+ }

4142

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

43−flushed_put str = do

44− liftIO $ hPutStr stdout str

45− liftIO $ hFlush stdout

4643

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

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

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

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

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

5249

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+

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

63+--

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

5465clear_screen_str :: String

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

5667

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

11-- Copyright Corey O'Connor

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE TypeFamilies #-}

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

5− , MockDisplay(..)

6− , terminal_instance

7− , dehandle

8− )

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

95 where

106

117import Graphics.Vty.DisplayRegion

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

1410import Control.Applicative

1511import Control.Monad.Trans

1612

17−import qualified Data.ByteString.UTF8 as BS

18−import qualified Data.ByteString as BSCore

13+import qualified Data.ByteString as BS

1914import Data.IORef

2015import qualified Data.String.UTF8 as UTF8

2116

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

2318import Foreign.Ptr ( plusPtr )

2419import Foreign.Storable ( poke )

2520

26−import System.IO

27−

28−import Unsafe.Coerce

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

2922

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

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

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

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

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

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

44−

45−data MockTerminal = MockTerminal

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

47− , mock_terminal_bounds :: DisplayRegion

48− }

49−

50−instance Terminal MockTerminal where

51− terminal_ID _t = "mock_terminal"

52− release_terminal _t = return ()

53− reserve_display _t = return ()

54− release_display _t = return ()

55− display_bounds t = return $ mock_terminal_bounds t

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

57− output_byte_buffer t out_buffer buffer_size

58− = liftIO $ do

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

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

38+mock_terminal r = liftIO $ do

39+ out_ref <- newIORef undefined

40+ new_assumed_state_ref <- newIORef initial_assumed_state

41+ return $ (,) out_ref $ Terminal

42+ { terminal_ID = "mock terminal"

43+ , release_device = return ()

44+ , reserve_display = return ()

45+ , release_display = return ()

46+ , display_bounds = return r

47+ , output_byte_buffer = \out_buffer buffer_size -> do

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

6049 peekArray (fromEnum buffer_size) out_buffer

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

62− >>= writeIORef (mock_terminal_last_output t)

63−

64− output_handle _t = return stdout

65−

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

81−

82− -- | Assume 16 colors

83− context_color_count _d = 16

84−

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

86− move_cursor_required_bytes _d _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

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

91− return $ ptr `plusPtr` 1

92−

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

94− show_cursor_required_bytes _d = 1

95−

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

97− serialize_show_cursor _d ptr = do

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

99− return $ ptr `plusPtr` 1

100−

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

102− hide_cursor_required_bytes _d = 1

103−

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

105− serialize_hide_cursor _d ptr = do

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

107− return $ ptr `plusPtr` 1

108−

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

110− attr_required_bytes _d _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

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

115− return $ ptr `plusPtr` 1

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

51+ >>= writeIORef out_ref

52+ , context_color_count = 16

53+ , assumed_state_ref = new_assumed_state_ref

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

55+ { context_region = r

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

57+ , move_cursor_required_bytes = \_x _y -> 1

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

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

60+ return $ ptr `plusPtr` 1

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

62+ , show_cursor_required_bytes = 1

63+ , serialize_show_cursor = \ptr -> do

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

65+ return $ ptr `plusPtr` 1

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

67+ , hide_cursor_required_bytes = 1

68+ , serialize_hide_cursor = \ptr -> do

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

70+ return $ ptr `plusPtr` 1

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

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

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

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

80+ return $ ptr `plusPtr` 1

81+ }

82+ }

11683

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

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE FlexibleInstances #-}

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

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

7− )

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

87 where

109import Data.Terminfo.Parse

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

1716

1817import Control.Applicative

1918import Control.Monad ( foldM )

19+import Control.Monad.Fix (mfix)

2020import Control.Monad.Trans

2121

2222import Data.Bits ( (.&.) )

23+import Data.IORef

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

2425

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

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

2728import GHC.IO.Handle

2829

2930import qualified System.Console.Terminfo as Terminfo

30−import System.IO

3131

32−data Term = Term

33− { term_info_ID :: String

34− , term_info :: Terminfo.Terminal

35− , smcup :: Maybe CapExpression

32+data TerminfoCaps = TerminfoCaps

33+ { smcup :: Maybe CapExpression

3634 , rmcup :: Maybe CapExpression

3735 , cup :: CapExpression

3836 , cnorm :: CapExpression

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

4240 , set_default_attr :: CapExpression

4341 , clear_screen :: CapExpression

4442 , display_attr_caps :: DisplayAttrCaps

45− , term_handle :: Handle

4643 }

4744

4845data DisplayAttrCaps = DisplayAttrCaps

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

5653 , enter_bold_mode :: Maybe CapExpression

5754 }

5855

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

60−marshall_cap_to_terminal t cap_selector cap_params = do

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

62− ( serialize_cap_expression (cap_selector t) cap_params )

63− return ()

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

57+send_cap_to_terminal t cap cap_params = do

58+ send_to_terminal t (cap_expression_required_bytes cap cap_params)

59+ (serialize_cap_expression cap cap_params)

6460

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

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

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

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

7470 -}

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

76−terminal_instance in_ID the_handle = do

77− ti <- liftIO $ Terminfo.setupTerm in_ID

78− let require_cap str

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

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"

99− <*> require_cap "cup"

100− <*> require_cap "cnorm"

101− <*> require_cap "civis"

102− <*> require_cap "setaf"

103− <*> require_cap "setab"

104− <*> require_cap "sgr0"

105− <*> require_cap "clear"

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

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

73+ ti <- Terminfo.setupTerm in_ID

74+ terminfo_caps <- pure TerminfoCaps

75+ <*> probe_cap ti "smcup"

76+ <*> probe_cap ti "rmcup"

77+ <*> require_cap ti "cup"

78+ <*> require_cap ti "cnorm"

79+ <*> require_cap ti "civis"

80+ <*> require_cap ti "setaf"

81+ <*> require_cap ti "setab"

82+ <*> require_cap ti "sgr0"

83+ <*> require_cap ti "clear"

10684 <*> 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

108140

109141current_display_attr_caps :: ( Applicative m, MonadIO m )

110142 => Terminfo.Terminal

111143 -> m DisplayAttrCaps

112144current_display_attr_caps ti

113145 = pure DisplayAttrCaps

114− <*> probe_cap "sgr"

115− <*> probe_cap "smso"

116− <*> probe_cap "rmso"

117− <*> probe_cap "smul"

118− <*> probe_cap "rmul"

119− <*> probe_cap "rev"

120− <*> probe_cap "dim"

121− <*> probe_cap "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 ()

146+ <*> probe_cap ti "sgr"

147+ <*> probe_cap ti "smso"

148+ <*> probe_cap ti "rmso"

149+ <*> probe_cap ti "smul"

150+ <*> probe_cap ti "rmul"

151+ <*> probe_cap ti "rev"

152+ <*> probe_cap ti "dim"

153+ <*> probe_cap ti "bold"

150154

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

183− :: IO CLong

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

184156

185157get_window_size :: IO (Int,Int)

186158get_window_size = do

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

188160 return (fromIntegral b, fromIntegral a)

189161

190−data DisplayContext = DisplayContext

191− { bounds :: DisplayRegion

192− , term :: Term

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

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

203− serialize_move_cursor d x y out_ptr

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

205−

206− show_cursor_required_bytes d

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

208− serialize_show_cursor d out_ptr

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

210−

211− hide_cursor_required_bytes d

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

213− serialize_hide_cursor d out_ptr

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

215−

216− -- | 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

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

219− --

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

221− --

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

223− attr_required_bytes _d _prev_attr _req_attr _diffs = 512

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

163+mk_terminfo_display_context terminfo_caps self = do

164+ return $ self

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

166+ [toEnum y, toEnum x]

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

168+ [toEnum y, toEnum x]

169+ out_ptr

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

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

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

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

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

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+

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

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

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

183+--

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

185+--

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

187+assumed_attr_required_bytes :: Int

188+assumed_attr_required_bytes = 512

224189

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

226− --

227− -- 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:

229− --

230− -- 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

232− -- 2. likewise with the background color

233− --

234− -- 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)

236− -- then:

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

238− -- 1. enter required style modes

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

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

241− --

242− -- 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.

244− --

245− -- This equation implements the above logic.

246− --

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

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

191+--

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

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

194+--

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

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

197+-- 2. likewise with the background color

198+--

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

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

201+-- then:

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

203+-- 1. enter required style modes

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

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

206+--

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

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

209+--

210+-- This equation implements the above logic.

211+--

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

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

249− serialize_set_attr d prev_attr req_attr diffs out_ptr = do

250− 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

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

253− True -> do

254− case req_display_cap_seq_for ( display_attr_caps $ term d )

255− ( fixed_style attr )

256− ( style_to_apply_seq $ fixed_style attr )

257− of

258− EnterExitSeq caps

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

260− -> serialize_default_attr d out_ptr

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

262− >>= set_colors

263− SetState state

264− -- implicitly resets the colors to the defaults

265− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

266− $ display_attr_caps

267− $ term d

268− )

269− ( sgr_args_for_state state )

270− out_ptr

271− >>= set_colors

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

273− -- points.

274− False -> do

275− -- 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.

277− case req_display_cap_seq_for ( display_attr_caps $ term d )

278− ( fixed_style attr )

279− ( style_diffs diffs )

280− of

281− -- 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

283− -- only case ever reached!

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

285− -- currently applied states.

286− EnterExitSeq caps

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

288− >>= apply_color_diff set_fore_color ( fore_color_diff diffs )

289− >>= apply_color_diff set_back_color ( back_color_diff diffs )

290− SetState state

291− -- implicitly resets the colors to the defaults

292− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

293− $ display_attr_caps

294− $ term d

295− )

296− ( sgr_args_for_state state )

297− out_ptr

298− >>= set_colors

299− where

300− attr = fix_display_attr prev_attr req_attr

301− set_colors ptr = do

302− ptr' <- case fixed_fore_color attr of

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

304− [ toEnum $ ansi_color_index c ]

305− ptr

306− Nothing -> return ptr

307− ptr'' <- case fixed_back_color attr of

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

309− [ toEnum $ ansi_color_index c ]

310− ptr'

311− Nothing -> return ptr'

312− return ptr''

313− apply_color_diff _f NoColorChange ptr

314− = return ptr

315− apply_color_diff _f ColorToDefault _ptr

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

317− apply_color_diff f ( SetColor c ) ptr

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

319− [ toEnum $ ansi_color_index c ]

320− 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

214+terminfo_serialize_set_attr :: DisplayContext

215+ -> TerminfoCaps

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

217+terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr = do

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

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

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

221+ True -> do

222+ case req_display_cap_seq_for ( display_attr_caps terminfo_caps )

223+ ( fixed_style attr )

224+ ( style_to_apply_seq $ fixed_style attr )

225+ of

226+ EnterExitSeq caps

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

228+ -> serialize_default_attr dc out_ptr

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

230+ >>= set_colors

231+ SetState state

232+ -- implicitly resets the colors to the defaults

233+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

234+ $ display_attr_caps

235+ $ terminfo_caps

236+ )

237+ ( sgr_args_for_state state )

238+ out_ptr

239+ >>= set_colors

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

241+ -- points.

242+ False -> do

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

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

245+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)

246+ (fixed_style attr)

247+ (style_diffs diffs)

248+ of

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

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

251+ -- only case ever reached!

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

253+ -- currently applied states.

254+ EnterExitSeq caps

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

256+ >>= apply_color_diff set_fore_color (fore_color_diff diffs)

257+ >>= apply_color_diff set_back_color (back_color_diff diffs)

258+ SetState state

259+ -- implicitly resets the colors to the defaults

260+ -> serialize_cap_expression (fromJust $ set_attr_states

261+ $ display_attr_caps terminfo_caps

262+ )

263+ (sgr_args_for_state state)

264+ out_ptr

265+ >>= set_colors

266+ where

267+ attr = fix_display_attr prev_attr req_attr

268+ set_colors ptr = do

269+ ptr' <- case fixed_fore_color attr of

270+ Just c -> serialize_cap_expression (set_fore_color terminfo_caps)

271+ [ toEnum $ ansi_color_index c ]

272+ ptr

273+ Nothing -> return ptr

274+ ptr'' <- case fixed_back_color attr of

275+ Just c -> serialize_cap_expression (set_back_color terminfo_caps)

276+ [ toEnum $ ansi_color_index c ]

277+ ptr'

278+ Nothing -> return ptr'

279+ return ptr''

280+ apply_color_diff _f NoColorChange ptr

281+ = return ptr

282+ apply_color_diff _f ColorToDefault _ptr

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

284+ apply_color_diff f ( SetColor c ) ptr

285+ = serialize_cap_expression (f terminfo_caps)

286+ [ toEnum $ ansi_color_index c ]

287+ ptr

326288

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

328290-- be supported by the terminal.

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

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

44{-# LANGUAGE MagicHash #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE TypeFamilies #-}

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

8− )

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

98 where

109

1110import Graphics.Vty.Terminal.Interface

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

1918

2019import System.IO

2120

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−

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

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

33−terminal_instance variant out_handle = do

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

23+reserve_terminal variant out_handle = liftIO $ do

24+ let flushed_put str = do

25+ hPutStr out_handle str

26+ hFlush out_handle

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

3528 -- xterm-color is broken.

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

3730 flushed_put set_utf8_char_set

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

39− return $ XTermColor variant' t

40−

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

42−--

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

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

45−flushed_put str = do

46− liftIO $ hPutStr stdout str

47− liftIO $ hFlush stdout

31+ t <- TerminfoBased.reserve_terminal variant' out_handle

32+ return $ t

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

34+ , release_device = do

35+ liftIO $ flushed_put set_default_char_set

36+ release_device t

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

38+ { inline_hack = xterm_inline_hack t

39+ }

40+ }

4841

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

5043--

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

5346set_utf8_char_set = "\ESC%G"

5447set_default_char_set = "\ESC%@"

5548

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

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

103− -- *after* the next newline.

104− inline_hack d = do

105− let t = case super_display d of

106− DisplayHandle _ t_ _ -> t_

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

108− liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)

109− ( serialize_utf8_text s_utf8 )

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

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

51+-- *after* the next newline.

52+xterm_inline_hack :: Terminal -> IO ()

53+xterm_inline_hack t = do

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

55+ send_to_terminal t (utf8_text_required_bytes s_utf8)

56+ (serialize_utf8_text s_utf8)

11057

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

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

66 where

88import Verify.Graphics.Vty.Attributes

9−import Graphics.Vty.Debug.Image

109import Graphics.Vty.Image

1110

1211import Verify

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

2221instance Show UnitImage where

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

2423

25−data DefaultImage = DefaultImage Image ImageConstructLog

24+data DefaultImage = DefaultImage Image

2625

2726instance Show DefaultImage where

28− show (DefaultImage i image_log)

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

27+ show (DefaultImage i)

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

3029

3130instance Arbitrary DefaultImage where

3231 arbitrary = do

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

34− return $ DefaultImage i []

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

33+ return $ DefaultImage i

3534

3635data SingleRowSingleAttrImage

3736 = SingleRowSingleAttrImage

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

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

1616data DefaultPic = DefaultPic

1717 { default_pic :: Picture

1818 , default_win :: MockWindow

19− , default_construct_log :: ImageConstructLog

2019 }

2120

2221instance Show DefaultPic where

23− show (DefaultPic pic win image_log)

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

22+ show (DefaultPic pic win)

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

2524

2625instance Arbitrary DefaultPic where

2726 arbitrary = do

28− DefaultImage image image_construct_events <- arbitrary

27+ DefaultImage image <- arbitrary

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

3029 return $ DefaultPic (pic_for_image image)

3130 win

32− image_construct_events

3331

3432data PicWithBGAttr = PicWithBGAttr

3533 { with_attr_pic :: Picture

3634 , with_attr_win :: MockWindow

37− , with_attr_construct_log :: ImageConstructLog

3835 , with_attr_specified_attr :: Attr

3936 } deriving ( Show )

4037

4138instance Arbitrary PicWithBGAttr where

4239 arbitrary = do

43− DefaultImage image image_construct_events <- arbitrary

40+ DefaultImage image <- arbitrary

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

4542 attr <- arbitrary

4643 return $ PicWithBGAttr (pic_for_image image)

4744 win

48− image_construct_events

4945 attr

5046

test/VerifyInline.hs+1−1

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

1212 [ Test $ TestInstance

1313 { name = "verify vty inline"

1414 , run = do

15− t <- terminal_handle

15+ t <- current_terminal

1616 put_attr_change t $ default_all

1717 return $ Finished Pass

1818 , tags = []

test/VerifySpanOps.hs+3−3

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

118118 in verify_all_spans_have_width i spans greater_width

119119

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

122122 let pic = pic_for_image image

123123 spans = spans_for_pic pic (region_for_window win)

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

125125

126126span_ops_actually_fill_rows :: DefaultPic -> Bool

127−span_ops_actually_fill_rows (DefaultPic pic win _) =

127+span_ops_actually_fill_rows (DefaultPic pic win) =

128128 let spans = spans_for_pic pic (region_for_window win)

129129 expected_row_count = region_height (region_for_window win)

130130 actual_row_count = span_ops_effected_rows spans

131131 in expected_row_count == actual_row_count

132132

133133span_ops_actually_fill_columns :: DefaultPic -> Bool

134−span_ops_actually_fill_columns (DefaultPic pic win _) =

134+span_ops_actually_fill_columns (DefaultPic pic win) =

135135 let spans = spans_for_pic pic (region_for_window win)

136136 expected_column_count = region_width (region_for_window win)

137137 in all_spans_have_width spans expected_column_count

test/VerifyTerminal.hs+22−22

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

2020

2121unit_image_unit_bounds :: UnitImage -> Property

2222unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do

23− t <- terminal_instance (DisplayRegion 1 1)

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

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

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

2525 let pic = pic_for_image i

26− output_picture d pic

26+ output_picture dc pic

2727 return succeeded

2828

2929unit_image_arb_bounds :: UnitImage -> MockWindow -> Property

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

31− t <- terminal_instance (DisplayRegion w h)

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

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

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

3333 let pic = pic_for_image i

34− output_picture d pic

34+ output_picture dc pic

3535 return succeeded

3636

3737single_T_row :: MockWindow -> Property

3838single_T_row (MockWindow w h) = liftIOResult $ do

39− t <- terminal_instance (DisplayRegion w h)

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

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

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

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

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

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

44− output_picture d pic

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

44+ output_picture dc pic

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

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

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

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

5555

5656many_T_rows :: MockWindow -> Property

5757many_T_rows (MockWindow w h) = liftIOResult $ do

58− t <- terminal_instance (DisplayRegion w h)

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

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

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

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

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

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

63− output_picture d pic

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

63+ output_picture dc pic

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

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

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

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

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

7272

7373many_T_rows_cropped_width :: MockWindow -> Property

7474many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do

75− t <- terminal_instance (DisplayRegion w h)

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

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

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

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

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

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

80− output_picture d pic

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

80+ output_picture dc pic

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

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

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

8484 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

8989

9090many_T_rows_cropped_height :: MockWindow -> Property

9191many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do

92− t <- terminal_instance (DisplayRegion w h)

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

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

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

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

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

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

97− output_picture d pic

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

97+ output_picture dc pic

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

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

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

101101 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

15starting no-diff-opt-0

26user time: 226

37system time: 13

test/interactive_terminal_test.hs+38−47

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

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

7979 )

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

81− t <- terminal_handle

81+ t <- current_terminal

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

8383 ++ terminal_ID t ++ "\n"

8484 ++ show results ++ "\n"

85− release_terminal t

85+ release_device t

8686 writeFile output_file_path results_txt

8787

8888wait_for_return = do

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

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

180180 , test_ID = "reserve_output_test"

181181 , test_action = do

182− t <- terminal_handle

182+ t <- current_terminal

183183 reserve_display t

184184 putStrLn "Line 1"

185185 putStrLn "Line 2"

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

188188 hFlush stdout

189189 getLine

190190 release_display t

191− release_terminal t

191+ release_device t

192192 return ()

193193 , print_summary = do

194194 putStr $ [s|

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

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

213213 , test_ID = "display_bounds_test_0"

214214 , test_action = do

215− t <- terminal_handle

215+ t <- current_terminal

216216 reserve_display t

217217 DisplayRegion w h <- display_bounds t

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

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

223223 hFlush stdout

224224 getLine

225225 release_display t

226− release_terminal t

226+ release_device t

227227 return ()

228228 , print_summary = display_bounds_test_summary True

229229 , confirm_results = generic_output_match_confirm

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

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

234234 , test_ID = "display_bounds_test_1"

235235 , test_action = do

236− t <- terminal_handle

236+ t <- current_terminal

237237 reserve_display t

238238 DisplayRegion w h <- display_bounds t

239239 set_cursor_pos t 0 0

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

252252 hFlush stdout

253253 getLine

254254 release_display t

255− release_terminal t

255+ release_device t

256256 return ()

257257 , print_summary = display_bounds_test_summary True

258258 , confirm_results = generic_output_match_confirm

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

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

263263 , test_ID = "display_bounds_test_2"

264264 , test_action = do

265− t <- terminal_handle

265+ t <- current_terminal

266266 reserve_display t

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

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

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

275275 output_picture d pic

276276 getLine

277277 release_display t

278− release_terminal t

278+ release_device t

279279 return ()

280280 , print_summary = display_bounds_test_summary True

281281 , confirm_results = generic_output_match_confirm

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

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

286286 , test_ID = "display_bounds_test_3"

287287 , test_action = do

288− t <- terminal_handle

288+ t <- current_terminal

289289 reserve_display t

290290 DisplayRegion w h <- display_bounds t

291291 hide_cursor t

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

306306 getLine

307307 show_cursor t

308308 release_display t

309− release_terminal t

309+ release_device t

310310 return ()

311311 , print_summary = display_bounds_test_summary False

312312 , confirm_results = generic_output_match_confirm

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

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

398398 , test_ID = "unicode_single_width_0"

399399 , test_action = do

400− t <- terminal_handle

400+ t <- current_terminal

401401 reserve_display t

402402 hide_cursor t

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

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

406406 hFlush stdout

407407 getLine

408408 release_display t

409− release_terminal t

409+ release_device t

410410 return ()

411411 , print_summary = unicode_single_width_summary

412412 , confirm_results = generic_output_match_confirm

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

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

417417 , test_ID = "unicode_single_width_1"

418418 , test_action = do

419− t <- terminal_handle

419+ t <- current_terminal

420420 reserve_display t

421421 let pic = pic_for_image image

422422 image = line_0 <-> line_1

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

426426 output_picture d pic

427427 getLine

428428 release_display t

429− release_terminal t

429+ release_device t

430430 return ()

431431 , print_summary = unicode_single_width_summary

432432 , confirm_results = generic_output_match_confirm

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

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

480480 , test_ID = "unicode_double_width_0"

481481 , test_action = do

482− t <- terminal_handle

482+ t <- current_terminal

483483 reserve_display t

484484 hide_cursor t

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

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

488488 hFlush stdout

489489 getLine

490490 release_display t

491− release_terminal t

491+ release_device t

492492 return ()

493493 , print_summary = unicode_double_width_summary

494494 , confirm_results = generic_output_match_confirm

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

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

499499 , test_ID = "unicode_double_width_1"

500500 , test_action = do

501− t <- terminal_handle

501+ t <- current_terminal

502502 reserve_display t

503503 let pic = pic_for_image image

504504 image = line_0 <-> line_1

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

508508 output_picture d pic

509509 getLine

510510 release_display t

511− release_terminal t

511+ release_device t

512512 return ()

513513 , print_summary = unicode_double_width_summary

514514 , confirm_results = generic_output_match_confirm

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

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

553553 , test_ID = "attributes_test_0"

554554 , test_action = do

555− t <- terminal_handle

555+ t <- current_terminal

556556 reserve_display t

557557 let pic = pic_for_image image

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

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

564564 output_picture d pic

565565 getLine

566566 release_display t

567− release_terminal t

567+ release_device t

568568 return ()

569569 , print_summary = do

570570 putStr $ [s|

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

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

599599 , test_ID = "attributes_test_1"

600600 , test_action = do

601− t <- terminal_handle

601+ t <- current_terminal

602602 reserve_display t

603603 let pic = pic_for_image image

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

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

610610 output_picture d pic

611611 getLine

612612 release_display t

613− release_terminal t

613+ release_device t

614614 return ()

615615 , print_summary = do

616616 putStr $ [s|

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

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

654654 , test_ID = "attributes_test_2"

655655 , test_action = do

656− t <- terminal_handle

656+ t <- current_terminal

657657 reserve_display t

658658 let pic = pic_for_image image

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

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

667667 output_picture d pic

668668 getLine

669669 release_display t

670− release_terminal t

670+ release_device t

671671 return ()

672672 , print_summary = do

673673 putStr $ [s|

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

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

713713 , test_ID = "attributes_test_3"

714714 , test_action = do

715− t <- terminal_handle

715+ t <- current_terminal

716716 reserve_display t

717717 let pic = pic_for_image image

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

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

726726 output_picture d pic

727727 getLine

728728 release_display t

729− release_terminal t

729+ release_device t

730730 return ()

731731 , print_summary = do

732732 putStr $ [s|

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

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

791791 , test_ID = "attributes_test_4"

792792 , test_action = do

793− t <- terminal_handle

793+ t <- current_terminal

794794 reserve_display t

795795 let pic = pic_for_image image

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

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

802802 output_picture d pic

803803 getLine

804804 release_display t

805− release_terminal t

805+ release_device t

806806 return ()

807807 , print_summary = do

808808 putStr $ [s|

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

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

843843 , test_ID = "attributes_test_5"

844844 , test_action = do

845− t <- terminal_handle

845+ t <- current_terminal

846846 reserve_display t

847847 let pic = pic_for_image image

848848 image = vert_cat $ map horiz_cat $ split_color_images color_images

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

853853 output_picture d pic

854854 getLine

855855 release_display t

856− release_terminal t

856+ release_device t

857857 return ()

858858 , print_summary = do

859859 putStr $ [s|

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

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

881881 , test_ID = "inline_test_0"

882882 , test_action = do

883− t <- terminal_handle

884883 putStrLn "line 1."

885− put_attr_change t $ back_color red >> apply_style underline

884+ put_attr_change_ $ back_color red >> apply_style underline

886885 putStrLn "line 2."

887− put_attr_change t $ default_all

886+ put_attr_change_ $ default_all

888887 putStrLn "line 3."

889− release_terminal t

890− return ()

891888 , print_summary = putStr $ [s|

892889lines are in order.

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

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

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

902899 , test_ID = "inline_test_1"

903900 , test_action = do

904− t <- terminal_handle

905901 putStr "Not styled. "

906− put_attr_change t $ back_color red >> apply_style underline

902+ put_attr_change_ $ back_color red >> apply_style underline

907903 putStr " Styled! "

908− put_attr_change t $ default_all

904+ put_attr_change_ $ default_all

909905 putStrLn "Not styled."

910− release_terminal t

911− return ()

912906 , print_summary = putStr $ [s|

913907|]

914908

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

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

920914 , test_ID = "inline_test_1"

921915 , test_action = do

922− t <- terminal_handle

923916 putStr "Not styled. "

924− put_attr_change t $ back_color red >> apply_style underline

917+ put_attr_change_ $ back_color red >> apply_style underline

925918 putStr " Styled! "

926− put_attr_change t $ default_all

919+ put_attr_change_ $ default_all

927920 putStr "Not styled.\n"

928− release_terminal t

929− return ()

930921 , print_summary = putStr $ [s|

931922|]

932923 , confirm_results = generic_output_match_confirm

test/vty_inline_example.hs+2−5

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

22import Graphics.Vty.Inline

44main = do

5− t <- terminal_handle

65 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

87 putStr " Styled! "

9− put_attr_change t $ default_all

8+ put_attr_change_ t $ default_all

109 putStrLn "Not styled."

11− release_terminal t

12− return ()

vty.cabal+3−2

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

4343 containers,

4444 deepseq >= 1.1 && < 1.4,

4545 ghc-prim,

46− lens,

46+ lens >= 3.9.0.2,

4747 mtl >= 1.1.1.0 && < 2.2,

4848 parallel >= 2.2 && < 3.3,

4949 parsec >= 2 && < 4,

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

6868 Data.Terminfo.Eval

6969 Data.Marshalling

7070 Graphics.Vty.Debug

71− Graphics.Vty.Debug.Image

7271 Graphics.Vty.DisplayRegion

7372 Graphics.Vty.DisplayAttributes

7473 Graphics.Vty.Image.Internal

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

8079 Graphics.Vty.Terminal.XTermColor

8180 Graphics.Vty.Terminal.TerminfoBased

8281

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

83+

8384 c-sources: cbits/gwinsz.c

8485 cbits/set_term_timing.c

8586 cbits/mk_wcwidth.c