b7d8b6d · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

resolve compile failure

b7d8b6dCorey O'Connor13 years ago

src/Graphics/Vty/Inline.hs+4−3

compare with master

unifiedsplit

@@ -35,6 +35,8 @@ import Graphics.Vty.DisplayAttributes

35import Graphics.Vty.Inline.Unsafe

36import Graphics.Vty.Output.Interface

38+import Blaze.ByteString.Builder (writeToByteString)

39+

38import Control.Applicative

40import Control.Applicative

39import Control.Monad.State.Strict

41import Control.Monad.State.Strict

@@ -86,15 +88,14 @@ put_attr_change out c = liftIO $ do

86 mfattr <- prev_fattr <$> readIORef (assumed_state_ref out)

88 mfattr <- prev_fattr <$> readIORef (assumed_state_ref out)

87 fattr <- case mfattr of

89 fattr <- case mfattr of

88 Nothing -> do

90 Nothing -> do

89− liftIO $ send_to_terminal out (default_attr_required_bytes dc) (serialize_default_attr dc)

91+ liftIO $ output_byte_buffer out $ writeToByteString $ write_default_attr dc

90 return $ FixedAttr default_style_mask Nothing Nothing

92 return $ FixedAttr default_style_mask Nothing Nothing

91 Just v -> return v

93 Just v -> return v

92 let attr = execState c current_attr

94 let attr = execState c current_attr

93 attr' = limit_attr_for_display out attr

95 attr' = limit_attr_for_display out attr

94 fattr' = fix_display_attr fattr attr'

96 fattr' = fix_display_attr fattr attr'

95 diffs = display_attr_diffs fattr fattr'

97 diffs = display_attr_diffs fattr fattr'

96− send_to_terminal out (attr_required_bytes dc fattr attr' diffs)

98+ output_byte_buffer out $ writeToByteString $ write_set_attr dc fattr attr' diffs

97− (serialize_set_attr dc fattr attr' diffs)

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

99 modifyIORef (assumed_state_ref out) $ \s -> s { prev_fattr = Just fattr' }

99 inline_hack dc

100 inline_hack dc

100

101

src/Graphics/Vty/Output.hs+6−3

@@ -33,6 +33,8 @@ import Graphics.Vty.Output.MacOSX as MacOSX

33import Graphics.Vty.Output.XTermColor as XTermColor

34import Graphics.Vty.Output.TerminfoBased as TerminfoBased

36+import Blaze.ByteString.Builder (writeToByteString)

37+

36import Control.Exception ( SomeException, try )

38import Control.Exception ( SomeException, try )

37import Control.Monad.Trans

39import Control.Monad.Trans

@@ -118,18 +120,19 @@ set_cursor_pos t x y = do

118 bounds <- display_bounds t

120 bounds <- display_bounds t

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

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

120 dc <- display_context t bounds

122 dc <- display_context t bounds

121− liftIO $ send_to_terminal t (move_cursor_required_bytes dc x y) (serialize_move_cursor dc x y)

123+ liftIO $ output_byte_buffer t $ writeToByteString $ write_move_cursor dc x y

122

124

123-- | Hides the cursor

125-- | Hides the cursor

124hide_cursor :: MonadIO m => Output -> m ()

126hide_cursor :: MonadIO m => Output -> m ()

125hide_cursor t = do

127hide_cursor t = do

126 bounds <- display_bounds t

128 bounds <- display_bounds t

127 dc <- display_context t bounds

129 dc <- display_context t bounds

128− liftIO $ send_to_terminal t (hide_cursor_required_bytes dc) (serialize_hide_cursor dc)

130+ liftIO $ output_byte_buffer t $ writeToByteString $ write_hide_cursor dc

129

131

130-- | Shows the cursor

132-- | Shows the cursor

131show_cursor :: MonadIO m => Output -> m ()

133show_cursor :: MonadIO m => Output -> m ()

132show_cursor t = do

134show_cursor t = do

133 bounds <- display_bounds t

135 bounds <- display_bounds t

134 dc <- display_context t bounds

136 dc <- display_context t bounds

135− liftIO $ send_to_terminal t (show_cursor_required_bytes dc) (serialize_show_cursor dc)

137+ liftIO $ output_byte_buffer t $ writeToByteString $ write_show_cursor dc

138+

src/Graphics/Vty/Output/Interface.hs+51−124

@@ -16,16 +16,17 @@ import Graphics.Vty.Span

17import Graphics.Vty.DisplayAttributes

19−import Blaze.ByteString.Builder (Write)

19+import Blaze.ByteString.Builder (Write, writeToByteString)

20import Blaze.ByteString.Builder.ByteString (writeByteString)

22import Control.Monad.Trans

24import qualified Data.ByteString as BS

25+import Data.IORef

26+import Data.Monoid (mempty, mappend)

25import qualified Data.Text.Encoding as T

27import qualified Data.Text.Encoding as T

26import qualified Data.Text.Lazy as TL

28import qualified Data.Text.Lazy as TL

27−import Data.IORef

28−import qualified Data.Vector.Unboxed as Vector

29+import qualified Data.Vector as Vector

30data Output = Output

31data Output = Output

31 { -- | Text identifier for the output device. Used for debugging.

32 { -- | Text identifier for the output device. Used for debugging.

@@ -105,7 +106,7 @@ data DisplayContext = DisplayContext

105

106

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

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

107write_utf8_text :: BS.ByteString -> Write

108write_utf8_text :: BS.ByteString -> Write

108−write_utf8_text str dest_ptr = writeByteString

109+write_utf8_text = writeByteString

109

110

110-- | Displays the given `Picture`.

111-- | Displays the given `Picture`.

111--

112--

@@ -125,9 +126,9 @@ output_picture :: MonadIO m => DisplayContext -> Picture -> m ()

125output_picture dc pic = liftIO $ do

126output_picture dc pic = liftIO $ do

126 as <- readIORef (assumed_state_ref $ context_device dc)

127 as <- readIORef (assumed_state_ref $ context_device dc)

127 let manip_cursor = supports_cursor_visibility (context_device dc)

128 let manip_cursor = supports_cursor_visibility (context_device dc)

128− let !r = context_region dc

129+ r = context_region dc

129− !ops = display_ops_for_pic pic r

130+ ops = display_ops_for_pic pic r

130− !initial_attr = FixedAttr default_style_mask Nothing Nothing

131+ initial_attr = FixedAttr default_style_mask Nothing Nothing

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

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

132 -- basis.

133 -- basis.

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

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

@@ -137,134 +138,60 @@ output_picture dc pic = liftIO $ do

137 then replicate (display_ops_rows ops) True

138 then replicate (display_ops_rows ops) True

138 else zipWith (/=) (Vector.toList previous_ops)

139 else zipWith (/=) (Vector.toList previous_ops)

139 (Vector.toList ops)

140 (Vector.toList ops)

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

141+ -- build the Write corresponding to the output image

141− total = (if manip_cursor then hide_cursor_required_bytes dc else 0)

142+ out = write_default_attr dc

142− + default_attr_required_bytes dc

143− + required_bytes dc initial_attr diffs ops

143+ `mappend` write_output_ops dc initial_attr diffs ops

144+ `mappend`

144− + case pic_cursor pic of

145+ (case pic_cursor pic of

145− _ | not manip_cursor -> 0

146+ _ | not manip_cursor -> mempty

146− NoCursor -> 0

147+ NoCursor -> write_hide_cursor dc

147 Cursor x y ->

148 Cursor x y ->

148− let { m = cursor_output_map ops $ pic_cursor pic; (ox, oy) = char_to_output_pos m ( x, y ) }

149+ let m = cursor_output_map ops $ pic_cursor pic

149− in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy

150+ (ox, oy) = char_to_output_pos m (x,y)

151+ in write_show_cursor dc `mappend` write_move_cursor dc ox oy

152+ )

150 -- ... then serialize

153 -- ... then serialize

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

152− ptr <- case manip_cursor of

153− True -> serialize_hide_cursor dc start_ptr

154− False -> return start_ptr

155− ptr' <- serialize_default_attr dc ptr

156− ptr'' <- serialize_output_ops dc ptr' initial_attr diffs ops

157− end_ptr <- case pic_cursor pic of

158− _ | not manip_cursor -> return ptr''

159− NoCursor -> return ptr''

160− Cursor x y -> do

161− let m = cursor_output_map ops $ pic_cursor pic

162− (ox, oy) = char_to_output_pos m (x,y)

163− serialize_show_cursor dc ptr'' >>= serialize_move_cursor dc ox oy

164− -- todo: How to handle exceptions?

165− -- probably set the prev_output_ops to Nothing

166− case end_ptr `minusPtr` start_ptr of

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

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

169− | otherwise -> output_byte_buffer (context_device dc) start_ptr (toEnum count)

154+ output_byte_buffer (context_device dc) (writeToByteString out)

170− -- Cache the output spans.

155+ -- Cache the output spans.

171− let as' = as { prev_output_ops = Just ops }

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

172− writeIORef (assumed_state_ref $ context_device dc) as'

157+ writeIORef (assumed_state_ref $ context_device dc) as'

173−

158+

174−required_bytes :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Int

159+write_output_ops :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write

175−required_bytes dc in_fattr diffs ops =

160+write_output_ops dc in_fattr diffs ops =

161+ let (_, out, _, _) = Vector.foldl' write_output_ops'

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

162+ (0, mempty, in_fattr, diffs)

163+ ops

177− in n

164+ in out

178 where

165 where

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

166+ write_output_ops' (y, out, fattr, True : diffs') span_ops

180− = let (s, fattr') = span_ops_required_bytes dc y fattr span_ops

167+ = let (span_out, fattr') = write_span_ops dc y fattr span_ops

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

168+ in (y+1, out `mappend` span_out, fattr', diffs')

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

169+ write_output_ops' (y, out, fattr, False : diffs') _span_ops

183− = ( y + 1, current_sum, fattr, diffs' )

170+ = (y + 1, out, fattr, diffs')

184− required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops

171+ write_output_ops' (_y, _out, _fattr, []) _span_ops

185− = error "shouldn't be possible"

186−

187−span_ops_required_bytes :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)

188−span_ops_required_bytes dc y in_fattr span_ops =

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

190− let header_required_bytes = move_cursor_required_bytes dc 0 y

191− -- then the span ops are serialized in the order specified

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

193− in (c + current_sum, fattr')

194− )

195− (header_required_bytes, in_fattr)

196− span_ops

197−

198−span_op_required_bytes :: DisplayContext -> FixedAttr -> SpanOp -> (Int, FixedAttr)

199−span_op_required_bytes dc fattr (TextSpan attr _ _ str) =

200− let attr' = limit_attr_for_display (context_device dc) attr

201− diffs = display_attr_diffs fattr fattr'

202− c = attr_required_bytes dc fattr attr' diffs

203− fattr' = fix_display_attr fattr attr'

204− in (c + utf8_text_required_bytes (T.encodeUtf8 $ TL.toStrict str), fattr')

205−span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."

206−span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)

207−

208−serialize_output_ops :: DisplayContext

209− -> OutputBuffer

210− -> FixedAttr

211− -> [Bool]

212− -> DisplayOps

213− -> IO OutputBuffer

214−serialize_output_ops dc start_ptr in_fattr diffs ops = do

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

216− ( 0, start_ptr, in_fattr, diffs )

217− ops

218− return end_ptr

219− where

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

221− = serialize_span_ops dc y out_ptr fattr span_ops

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

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

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

225− serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops

226 = error "vty - output spans without a corresponding diff."

172 = error "vty - output spans without a corresponding diff."

227

173

228−serialize_span_ops :: DisplayContext

174+write_span_ops :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)

229− -> Int

230− -> OutputBuffer

231− -> FixedAttr

232− -> SpanOps

233− -> IO (OutputBuffer, FixedAttr)

234−serialize_span_ops dc y out_ptr in_fattr span_ops = do

175+write_span_ops dc y in_fattr span_ops =

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

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

236− out_ptr' <- serialize_move_cursor dc 0 y out_ptr

177+ let start = write_move_cursor dc 0 y

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

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

238− Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op dc op out_ptr'' fattr )

179+ in Vector.foldl' (\(out, fattr) op -> case write_span_op dc op fattr of

180+ (op_out, fattr') -> (out `mappend` op_out, fattr')

181+ )

239− (out_ptr', in_fattr)

182+ (start, in_fattr)

240− span_ops

183+ span_ops

241

184

242−-- |

185+write_span_op :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)

243−-- TODO: move this into the terminal implementation?

244−serialize_span_op :: DisplayContext

245− -> SpanOp

246− -> OutputBuffer

247− -> FixedAttr

248− -> IO (OutputBuffer, FixedAttr)

249−serialize_span_op dc (TextSpan attr _ _ str) out_ptr fattr = do

186+write_span_op dc (TextSpan attr _ _ str) fattr =

250 let attr' = limit_attr_for_display (context_device dc) attr

187 let attr' = limit_attr_for_display (context_device dc) attr

251 fattr' = fix_display_attr fattr attr'

188 fattr' = fix_display_attr fattr attr'

252 diffs = display_attr_diffs fattr fattr'

189 diffs = display_attr_diffs fattr fattr'

253− out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr

190+ out = write_set_attr dc fattr attr' diffs

254− out_ptr'' <- serialize_utf8_text (T.encodeUtf8 $ TL.toStrict str) out_ptr'

191+ `mappend` write_utf8_text (T.encodeUtf8 $ TL.toStrict str)

255− return (out_ptr'', fattr')

192+ in (out, fattr')

256−serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"

193+write_span_op _dc (Skip _) _fattr = error "serialize_span_op for Skip"

257−serialize_span_op dc (RowEnd _) out_ptr fattr = do

194+write_span_op dc (RowEnd _) fattr = (write_row_end dc, fattr)

258− out_ptr' <- serialize_row_end dc out_ptr

259− return (out_ptr', fattr)

260−

261−send_to_terminal :: Output -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()

262−send_to_terminal t c f = allocaBytes (fromEnum c) $ \start_ptr -> do

263− end_ptr <- f start_ptr

264− case end_ptr `minusPtr` start_ptr of

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

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

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

268

195

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

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

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

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

src/Graphics/Vty/Output/Mock.hs+11−33

@@ -10,16 +10,14 @@ import Graphics.Vty.Prelude

11import Graphics.Vty.Output.Interface

13+import Blaze.ByteString.Builder.Word (writeWord8)

14+

13import Control.Monad.Trans

15import Control.Monad.Trans

15import qualified Data.ByteString as BS

17import qualified Data.ByteString as BS

16import Data.IORef

18import Data.IORef

17import qualified Data.String.UTF8 as UTF8

19import qualified Data.String.UTF8 as UTF8

19−import Foreign.Marshal.Array ( peekArray )

20−import Foreign.Ptr ( plusPtr )

21−import Foreign.Storable ( poke )

22−

23type MockData = IORef (UTF8.UTF8 BS.ByteString)

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

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

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

@@ -44,11 +42,9 @@ mock_terminal r = liftIO $ do

44 , reserve_display = return ()

42 , reserve_display = return ()

45 , release_display = return ()

43 , release_display = return ()

46 , display_bounds = return r

44 , display_bounds = return r

47− , output_byte_buffer = \out_buffer buffer_size -> do

45+ , output_byte_buffer = \bytes -> do

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

46+ putStrLn $ "mock output_byte_buffer of " ++ show (BS.length bytes) ++ " bytes"

49− peekArray (fromEnum buffer_size) out_buffer

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

51− >>= writeIORef out_ref

47+ writeIORef out_ref $ UTF8.fromRep bytes

52 , context_color_count = 16

48 , context_color_count = 16

53 , supports_cursor_visibility = True

49 , supports_cursor_visibility = True

54 , assumed_state_ref = new_assumed_state_ref

50 , assumed_state_ref = new_assumed_state_ref

@@ -56,35 +52,17 @@ mock_terminal r = liftIO $ do

56 { context_region = r_actual

52 { context_region = r_actual

57 , context_device = t_actual

53 , context_device = t_actual

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

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

59− , move_cursor_required_bytes = \_x _y -> 1

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

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

55+ , write_move_cursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'

62− return $ ptr `plusPtr` 1

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

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

64− , show_cursor_required_bytes = 1

65− , serialize_show_cursor = \ptr -> do

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

57+ , write_show_cursor = writeWord8 $ toEnum $ fromEnum 'S'

67− return $ ptr `plusPtr` 1

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

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

69− , hide_cursor_required_bytes = 1

70− , serialize_hide_cursor = \ptr -> do

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

59+ , write_hide_cursor = writeWord8 $ toEnum $ fromEnum 'H'

72− return $ ptr `plusPtr` 1

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

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

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

61+ , write_set_attr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'

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

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

77− return $ ptr `plusPtr` 1

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

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

79− , default_attr_required_bytes = 1

80− , serialize_default_attr = \ptr -> do

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

63+ , write_default_attr = writeWord8 $ toEnum $ fromEnum 'D'

82− return $ ptr `plusPtr` 1

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

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

84− , row_end_required_bytes = 1

85− , serialize_row_end = \ptr -> do

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

65+ , write_row_end = writeWord8 $ toEnum $ fromEnum 'E'

87− return $ ptr `plusPtr` 1

88 , inline_hack = return ()

66 , inline_hack = return ()

89 }

67 }

90 }

68 }

src/Graphics/Vty/Output/TerminfoBased.hs+70−102

@@ -13,6 +13,7 @@ module Graphics.Vty.Output.TerminfoBased ( reserve_terminal )

14import Graphics.Vty.Prelude

16+import qualified Data.ByteString as BS

16import Data.Terminfo.Parse

17import Data.Terminfo.Parse

17import Data.Terminfo.Eval

18import Data.Terminfo.Eval

@@ -20,11 +21,15 @@ import Graphics.Vty.Attributes

20import Graphics.Vty.DisplayAttributes

21import Graphics.Vty.DisplayAttributes

21import Graphics.Vty.Output.Interface

22import Graphics.Vty.Output.Interface

24+import Blaze.ByteString.Builder (Write, writeToByteString)

25+

23import Control.Monad.Trans

26import Control.Monad.Trans

25−import Data.Bits ( (.&.) )

28+import Data.Bits ((.&.))

29+import Data.Foldable (foldMap)

26import Data.IORef

30import Data.IORef

27−import Data.Maybe ( isJust, isNothing, fromJust )

31+import Data.Maybe (isJust, isNothing, fromJust)

32+import Data.Monoid

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

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

@@ -61,8 +66,7 @@ data DisplayAttrCaps = DisplayAttrCaps

62send_cap_to_terminal :: Output -> CapExpression -> [CapParam] -> IO ()

67send_cap_to_terminal :: Output -> CapExpression -> [CapParam] -> IO ()

63send_cap_to_terminal t cap cap_params = do

68send_cap_to_terminal t cap cap_params = do

64− send_to_terminal t (cap_expression_required_bytes cap cap_params)

69+ output_byte_buffer t $ writeToByteString $ write_cap_expr cap cap_params

65− (serialize_cap_expression cap cap_params)

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

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

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

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

@@ -130,8 +134,8 @@ reserve_terminal in_ID out_handle = liftIO $ do

130 case raw_size of

134 case raw_size of

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

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

132 | otherwise -> return (w,h)

136 | otherwise -> return (w,h)

133− , output_byte_buffer = \out_ptr out_byte_count -> do

137+ , output_byte_buffer = \out_bytes -> do

134− hPutBuf out_handle out_ptr (fromEnum out_byte_count)

138+ BS.hPut out_handle out_bytes

135 hFlush out_handle

139 hFlush out_handle

136 , context_color_count

140 , context_color_count

137 = case supports_no_colors terminfo_caps of

141 = case supports_no_colors terminfo_caps of

@@ -163,8 +167,7 @@ probe_cap ti cap_name

163

167

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

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

165parse_cap cap_str = do

169parse_cap cap_str = do

166− parse_result <- parse_cap_expression cap_str

170+ case parse_cap_expression cap_str of

167− case parse_result of

168 Left e -> fail $ show e

171 Left e -> fail $ show e

169 Right cap -> return cap

172 Right cap -> return cap

170

173

@@ -194,45 +197,20 @@ terminfo_display_context t_actual terminfo_caps r =

194 let dc = DisplayContext

197 let dc = DisplayContext

195 { context_device = t_actual

198 { context_device = t_actual

196 , context_region = r

199 , context_region = r

197− , move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)

200+ , write_move_cursor = \x y -> write_cap_expr (cup terminfo_caps) [toEnum y, toEnum x]

198− [toEnum y, toEnum x]

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

200− [toEnum y, toEnum x]

201− out_ptr

202− , show_cursor_required_bytes = case cnorm terminfo_caps of

201+ , write_show_cursor = case cnorm terminfo_caps of

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

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

204− Just c -> cap_expression_required_bytes c []

203+ Just c -> write_cap_expr c []

205− , serialize_show_cursor = \out_ptr -> do

206− case cnorm terminfo_caps of

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

208− Just c -> serialize_cap_expression c [] out_ptr

209− , hide_cursor_required_bytes = case civis terminfo_caps of

204+ , write_hide_cursor = case civis terminfo_caps of

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

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

211− Just c -> cap_expression_required_bytes c []

206+ Just c -> write_cap_expr c []

212− , serialize_hide_cursor = \out_ptr -> do

207+ , write_set_attr = terminfo_write_set_attr dc terminfo_caps

213− case civis terminfo_caps of

208+ , write_default_attr = write_cap_expr (set_default_attr terminfo_caps) []

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

209+ , write_row_end = write_cap_expr (clear_eol terminfo_caps) []

215− Just c -> serialize_cap_expression c [] out_ptr

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

217− , serialize_set_attr = terminfo_serialize_set_attr dc terminfo_caps

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

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

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

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

222 , inline_hack = return ()

210 , inline_hack = return ()

223 }

211 }

224 in return dc

212 in return dc

225

213

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

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

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

229−--

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

231−--

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

233−assumed_attr_required_bytes :: Int

234−assumed_attr_required_bytes = 512

235−

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

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

237--

215--

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

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

@@ -260,32 +238,29 @@ assumed_attr_required_bytes = 512

260--

238--

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

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

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

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

263−terminfo_serialize_set_attr :: DisplayContext

264− -> TerminfoCaps

265− -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer

241+terminfo_write_set_attr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

266−terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr = do

242+terminfo_write_set_attr dc terminfo_caps prev_attr req_attr diffs = do

267 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

243 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

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

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

269 -- state capability or the set default capability.

245 -- state capability or the set default capability.

270 True -> do

246 True -> do

271− case req_display_cap_seq_for ( display_attr_caps terminfo_caps )

247+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)

272− ( fixed_style attr )

248+ (fixed_style attr )

273− ( style_to_apply_seq $ fixed_style attr )

249+ (style_to_apply_seq $ fixed_style attr) of

274− of

275− EnterExitSeq caps

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

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

277− -> serialize_default_attr dc out_ptr

251+ EnterExitSeq caps -> write_default_attr dc

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

252+ `mappend`

253+ foldMap (\cap -> write_cap_expr cap []) caps

254+ `mappend`

279− >>= set_colors

255+ set_colors

280− SetState state

281− -- implicitly resets the colors to the defaults

256+ -- implicitly resets the colors to the defaults

282− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

257+ SetState state -> write_cap_expr (fromJust $ set_attr_states

283− $ display_attr_caps

258+ $ display_attr_caps

284− $ terminfo_caps

259+ $ terminfo_caps

285− )

260+ )

286− ( sgr_args_for_state state )

261+ (sgr_args_for_state state)

287− out_ptr

262+ `mappend`

288− >>= set_colors

263+ set_colors

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

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

290 -- points.

265 -- points.

291 False -> do

266 False -> do

@@ -293,50 +268,43 @@ terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr =

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

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

294 case req_display_cap_seq_for (display_attr_caps terminfo_caps)

269 case req_display_cap_seq_for (display_attr_caps terminfo_caps)

295 (fixed_style attr)

270 (fixed_style attr)

296− (style_diffs diffs)

271+ (style_diffs diffs) of

297− of

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

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

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

273+ -- down to 40 yr old dumb terminal requirements this would be the only case ever

300− -- only case ever reached!

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

274+ -- reached! Changes the style and color states according to the differences with

302− -- currently applied states.

275+ -- the currently applied states.

303− EnterExitSeq caps

276+ EnterExitSeq caps -> foldMap (\cap -> write_cap_expr cap []) caps

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

277+ `mappend`

305− >>= apply_color_diff set_fore_color (fore_color_diff diffs)

278+ write_color_diff set_fore_color (fore_color_diff diffs)

279+ `mappend`

306− >>= apply_color_diff set_back_color (back_color_diff diffs)

280+ write_color_diff set_back_color (back_color_diff diffs)

307− SetState state

308− -- implicitly resets the colors to the defaults

281+ -- implicitly resets the colors to the defaults

309− -> serialize_cap_expression (fromJust $ set_attr_states

282+ SetState state -> write_cap_expr (fromJust $ set_attr_states

310− $ display_attr_caps terminfo_caps

283+ $ display_attr_caps terminfo_caps

311− )

284+ )

312− (sgr_args_for_state state)

285+ (sgr_args_for_state state)

313− out_ptr

314− >>= set_colors

286+ `mappend` set_colors

315 where

287 where

316 color_map = case use_alt_color_map terminfo_caps of

288 color_map = case use_alt_color_map terminfo_caps of

317 False -> ansi_color_index

289 False -> ansi_color_index

318 True -> alt_color_index

290 True -> alt_color_index

319 attr = fix_display_attr prev_attr req_attr

291 attr = fix_display_attr prev_attr req_attr

320− set_colors ptr = do

292+ set_colors =

321− ptr' <- case fixed_fore_color attr of

293+ (case fixed_fore_color attr of

322− Just c -> serialize_cap_expression (set_fore_color terminfo_caps)

294+ Just c -> write_cap_expr (set_fore_color terminfo_caps)

323− [ toEnum $ color_map c ]

295+ [toEnum $ color_map c]

324− ptr

325− Nothing -> return ptr

296+ Nothing -> mempty)

297+ `mappend`

326− ptr'' <- case fixed_back_color attr of

298+ (case fixed_back_color attr of

327− Just c -> serialize_cap_expression (set_back_color terminfo_caps)

299+ Just c -> write_cap_expr (set_back_color terminfo_caps)

328− [ toEnum $ color_map c ]

300+ [toEnum $ color_map c]

329− ptr'

330− Nothing -> return ptr'

301+ Nothing -> mempty)

331− return ptr''

332− apply_color_diff _f NoColorChange ptr

302+ write_color_diff _f NoColorChange

333− = return ptr

303+ = mempty

334− apply_color_diff _f ColorToDefault _ptr

304+ write_color_diff _f ColorToDefault

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

305+ = error "ColorToDefault is not a possible case for apply_color_diffs"

336− apply_color_diff f ( SetColor c ) ptr

306+ write_color_diff f (SetColor c)

337− = serialize_cap_expression (f terminfo_caps)

338− [ toEnum $ color_map c ]

307+ = write_cap_expr (f terminfo_caps) [toEnum $ color_map c]

339− ptr

340

308

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

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

342-- be supported by the terminal.

310-- be supported by the terminal.

src/Graphics/Vty/Output/XTermColor.hs+3−2

@@ -5,6 +5,8 @@ module Graphics.Vty.Output.XTermColor ( reserve_terminal )

5import Graphics.Vty.Output.Interface

6import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

8+import Blaze.ByteString.Builder (writeToByteString)

8import Control.Applicative

10import Control.Applicative

9import Control.Monad.Trans

11import Control.Monad.Trans

@@ -48,6 +50,5 @@ set_default_char_set = "\ESC%@"

48xterm_inline_hack :: Output -> IO ()

50xterm_inline_hack :: Output -> IO ()

49xterm_inline_hack t = do

51xterm_inline_hack t = do

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

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

51− send_to_terminal t (utf8_text_required_bytes s_utf8)

53+ output_byte_buffer t $ writeToByteString $ write_utf8_text s_utf8

52− (serialize_utf8_text s_utf8)

test/VerifyEvalTerminfoCaps.hs+5−6

@@ -2,8 +2,7 @@

2{-# LANGUAGE NamedFieldPuns #-}

3module VerifyEvalTerminfoCaps where

5−import Data.Marshalling

5+import Blaze.ByteString.Builder.Internal.Write (runWrite)

6−

7import Data.Terminfo.Eval

6import Data.Terminfo.Eval

8import Data.Terminfo.Parse

7import Data.Terminfo.Parse

9import Control.DeepSeq

8import Control.DeepSeq

@@ -63,8 +62,8 @@ tests = do

63 let test_name = term_name ++ "(" ++ cap_name ++ ")"

62 let test_name = term_name ++ "(" ++ cap_name ++ ")"

64 parse_result <- parse_cap_expression cap_def

63 parse_result <- parse_cap_expression cap_def

65 case parse_result of

64 case parse_result of

66− Left error -> return [ verify test_name ( failed { reason = "parse error " ++ show error } ) ]

65+ Left error -> return [verify test_name (failed {reason = "parse error " ++ show error})]

67− Right !cap_expr -> return [ verify test_name ( verify_eval_cap eval_buffer cap_expr ) ]

66+ Right !cap_expr -> return [verify test_name (verify_eval_cap eval_buffer cap_expr)]

68 Nothing -> do

67 Nothing -> do

69 return []

68 return []

@@ -75,8 +74,8 @@ verify_eval_cap eval_buffer expr !junk_int = do

75 let !byte_count = cap_expression_required_bytes expr input_values

74 let !byte_count = cap_expression_required_bytes expr input_values

76 in liftIOResult $ do

75 in liftIOResult $ do

77 let start_ptr :: Ptr Word8 = eval_buffer

76 let start_ptr :: Ptr Word8 = eval_buffer

78− forM_ [0..100] $ \i -> serialize_cap_expression expr input_values start_ptr

77+ forM_ [0..100] $ \i -> runWrite (write_cap_expr expr input_values) start_ptr

79− end_ptr <- serialize_cap_expression expr input_values start_ptr

78+ end_ptr <- runWrite(write_cap_expr expr input_values) start_ptr

80 case end_ptr `minusPtr` start_ptr of

79 case end_ptr `minusPtr` start_ptr of

81 count | count < 0 ->

80 count | count < 0 ->

82 return $ failed { reason = "End pointer before start pointer." }

81 return $ failed { reason = "End pointer before start pointer." }