b7d8b6d · vty · git.iko.soy

git.iko.soy/vty

resolve compile failure

commitb7d8b6d87e87128f181d3c7599f57683a2817c4e authorCorey O'Connor <coreyoconnor@gmail.com> dateTue 28 Jan 2014, 08:33 (13 years ago) parentf165d08

7 files changed+150−273

compare with master

unifiedsplit

src/Graphics/Vty/Inline.hs+4−3 src/Graphics/Vty/Output.hs+6−3 src/Graphics/Vty/Output/Interface.hs+51−124 src/Graphics/Vty/Output/Mock.hs+11−33 src/Graphics/Vty/Output/TerminfoBased.hs+70−102 src/Graphics/Vty/Output/XTermColor.hs+3−2 test/VerifyEvalTerminfoCaps.hs+5−6

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

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

3535import Graphics.Vty.Inline.Unsafe

3636import Graphics.Vty.Output.Interface

3737

38+import Blaze.ByteString.Builder (writeToByteString)

39+

3840import Control.Applicative

3941import Control.Monad.State.Strict

4042

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

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

8789 fattr <- case mfattr of

8890 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

9092 return $ FixedAttr default_style_mask Nothing Nothing

9193 Just v -> return v

9294 let attr = execState c current_attr

9395 attr' = limit_attr_for_display out attr

9496 fattr' = fix_display_attr fattr attr'

9597 diffs = display_attr_diffs fattr fattr'

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

97− (serialize_set_attr dc fattr attr' diffs)

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

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

99100 inline_hack dc

100101

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

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

3333import Graphics.Vty.Output.XTermColor as XTermColor

3434import Graphics.Vty.Output.TerminfoBased as TerminfoBased

3535

36+import Blaze.ByteString.Builder (writeToByteString)

37+

3638import Control.Exception ( SomeException, try )

3739import Control.Monad.Trans

3840

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

118120 bounds <- display_bounds t

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

120122 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

122124

123125-- | Hides the cursor

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

125127hide_cursor t = do

126128 bounds <- display_bounds t

127129 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

129131

130132-- | Shows the cursor

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

132134show_cursor t = do

133135 bounds <- display_bounds t

134136 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

1616

1717import Graphics.Vty.DisplayAttributes

1818

19−import Blaze.ByteString.Builder (Write)

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

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

2121

2222import Control.Monad.Trans

2323

2424import qualified Data.ByteString as BS

25+import Data.IORef

26+import Data.Monoid (mempty, mappend)

2527import qualified Data.Text.Encoding as T

2628import 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

2930

3031data Output = Output

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

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

105106

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

107108write_utf8_text :: BS.ByteString -> Write

108−write_utf8_text str dest_ptr = writeByteString

109+write_utf8_text = writeByteString

109110

110111-- | Displays the given `Picture`.

111112--

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

125126output_picture dc pic = liftIO $ do

126127 as <- readIORef (assumed_state_ref $ context_device dc)

127128 let manip_cursor = supports_cursor_visibility (context_device dc)

128− let !r = context_region dc

129− !ops = display_ops_for_pic pic r

130− !initial_attr = FixedAttr default_style_mask Nothing Nothing

129+ r = context_region dc

130+ ops = display_ops_for_pic pic r

131+ initial_attr = FixedAttr default_style_mask Nothing Nothing

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

132133 -- basis.

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

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

137138 then replicate (display_ops_rows ops) True

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

139140 (Vector.toList ops)

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

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

142− + default_attr_required_bytes dc

143− + required_bytes dc initial_attr diffs ops

144− + case pic_cursor pic of

145− _ | not manip_cursor -> 0

146− NoCursor -> 0

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

142+ out = write_default_attr dc

143+ `mappend` write_output_ops dc initial_attr diffs ops

144+ `mappend`

145+ (case pic_cursor pic of

146+ _ | not manip_cursor -> mempty

147+ NoCursor -> write_hide_cursor dc

147148 Cursor x y ->

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

149− in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy

149+ let m = cursor_output_map ops $ pic_cursor pic

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

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

152+ )

150153 -- ... 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)

170− -- Cache the output spans.

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

172− writeIORef (assumed_state_ref $ context_device dc) as'

173−

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

175−required_bytes dc in_fattr diffs ops =

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

177− in n

154+ output_byte_buffer (context_device dc) (writeToByteString out)

155+ -- Cache the output spans.

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

157+ writeIORef (assumed_state_ref $ context_device dc) as'

158+

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

160+write_output_ops dc in_fattr diffs ops =

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

162+ (0, mempty, in_fattr, diffs)

163+ ops

164+ in out

178165 where

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

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

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

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

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

184− required_bytes' (_y, _current_sum, _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

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

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

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

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

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

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

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

227173

228−serialize_span_ops :: DisplayContext

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

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

175+write_span_ops dc y in_fattr span_ops =

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

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

239− (out_ptr', in_fattr)

240− span_ops

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

182+ (start, in_fattr)

183+ span_ops

241184

242−-- |

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

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

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

250187 let attr' = limit_attr_for_display (context_device dc) attr

251188 fattr' = fix_display_attr fattr attr'

252189 diffs = display_attr_diffs fattr fattr'

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

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

255− return (out_ptr'', fattr')

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

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

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)

190+ out = write_set_attr dc fattr attr' diffs

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

192+ in (out, fattr')

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

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

268195

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

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

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

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

1010

1111import Graphics.Vty.Output.Interface

1212

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

14+

1315import Control.Monad.Trans

1416

1517import qualified Data.ByteString as BS

1618import Data.IORef

1719import qualified Data.String.UTF8 as UTF8

1820

19−import Foreign.Marshal.Array ( peekArray )

20−import Foreign.Ptr ( plusPtr )

21−import Foreign.Storable ( poke )

22−

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

2422

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

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

4442 , reserve_display = return ()

4543 , release_display = return ()

4644 , display_bounds = return r

47− , output_byte_buffer = \out_buffer buffer_size -> do

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

49− peekArray (fromEnum buffer_size) out_buffer

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

51− >>= writeIORef out_ref

45+ , output_byte_buffer = \bytes -> do

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

47+ writeIORef out_ref $ UTF8.fromRep bytes

5248 , context_color_count = 16

5349 , supports_cursor_visibility = True

5450 , assumed_state_ref = new_assumed_state_ref

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

5652 { context_region = r_actual

5753 , context_device = t_actual

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

59− , move_cursor_required_bytes = \_x _y -> 1

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

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

62− return $ ptr `plusPtr` 1

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

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

64− , show_cursor_required_bytes = 1

65− , serialize_show_cursor = \ptr -> do

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

67− return $ ptr `plusPtr` 1

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

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

69− , hide_cursor_required_bytes = 1

70− , serialize_hide_cursor = \ptr -> do

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

72− return $ ptr `plusPtr` 1

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

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

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

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

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

77− return $ ptr `plusPtr` 1

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

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

79− , default_attr_required_bytes = 1

80− , serialize_default_attr = \ptr -> do

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

82− return $ ptr `plusPtr` 1

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

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

84− , row_end_required_bytes = 1

85− , serialize_row_end = \ptr -> do

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

87− return $ ptr `plusPtr` 1

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

8866 , inline_hack = return ()

8967 }

9068 }

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

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

1313

1414import Graphics.Vty.Prelude

1515

16+import qualified Data.ByteString as BS

1617import Data.Terminfo.Parse

1718import Data.Terminfo.Eval

1819

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

2021import Graphics.Vty.DisplayAttributes

2122import Graphics.Vty.Output.Interface

2223

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

25+

2326import Control.Monad.Trans

2427

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

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

29+import Data.Foldable (foldMap)

2630import Data.IORef

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

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

32+import Data.Monoid

2833

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

3035

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

6166

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

6368send_cap_to_terminal t cap cap_params = do

64− send_to_terminal t (cap_expression_required_bytes cap cap_params)

65− (serialize_cap_expression cap cap_params)

69+ output_byte_buffer t $ writeToByteString $ write_cap_expr cap cap_params

6670

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

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

130134 case raw_size of

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

132136 | otherwise -> return (w,h)

133− , output_byte_buffer = \out_ptr out_byte_count -> do

134− hPutBuf out_handle out_ptr (fromEnum out_byte_count)

137+ , output_byte_buffer = \out_bytes -> do

138+ BS.hPut out_handle out_bytes

135139 hFlush out_handle

136140 , context_color_count

137141 = case supports_no_colors terminfo_caps of

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

163167

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

165169parse_cap cap_str = do

166− parse_result <- parse_cap_expression cap_str

167− case parse_result of

170+ case parse_cap_expression cap_str of

168171 Left e -> fail $ show e

169172 Right cap -> return cap

170173

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

194197 let dc = DisplayContext

195198 { context_device = t_actual

196199 , context_region = r

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

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

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

201+ , write_show_cursor = case cnorm terminfo_caps of

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

204− Just c -> cap_expression_required_bytes 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

203+ Just c -> write_cap_expr c []

204+ , write_hide_cursor = case civis terminfo_caps of

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

211− Just c -> cap_expression_required_bytes c []

212− , serialize_hide_cursor = \out_ptr -> do

213− case civis terminfo_caps of

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

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) []

206+ Just c -> write_cap_expr c []

207+ , write_set_attr = terminfo_write_set_attr dc terminfo_caps

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

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

222210 , inline_hack = return ()

223211 }

224212 in return dc

225213

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−

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

237215--

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

260238--

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

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

266−terminfo_serialize_set_attr dc terminfo_caps prev_attr req_attr diffs out_ptr = do

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

242+terminfo_write_set_attr dc terminfo_caps prev_attr req_attr diffs = do

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

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

269245 -- state capability or the set default capability.

270246 True -> do

271− case req_display_cap_seq_for ( display_attr_caps terminfo_caps )

272− ( fixed_style attr )

273− ( style_to_apply_seq $ fixed_style attr )

274− of

275− EnterExitSeq caps

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

277− -> serialize_default_attr dc out_ptr

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

279− >>= set_colors

280− SetState state

281− -- implicitly resets the colors to the defaults

282− -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states

283− $ display_attr_caps

284− $ terminfo_caps

285− )

286− ( sgr_args_for_state state )

287− out_ptr

288− >>= set_colors

247+ case req_display_cap_seq_for (display_attr_caps terminfo_caps)

248+ (fixed_style attr )

249+ (style_to_apply_seq $ fixed_style attr) of

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

251+ EnterExitSeq caps -> write_default_attr dc

252+ `mappend`

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

254+ `mappend`

255+ set_colors

256+ -- implicitly resets the colors to the defaults

257+ SetState state -> write_cap_expr (fromJust $ set_attr_states

258+ $ display_attr_caps

259+ $ terminfo_caps

260+ )

261+ (sgr_args_for_state state)

262+ `mappend`

263+ set_colors

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

290265 -- points.

291266 False -> do

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

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

294269 case req_display_cap_seq_for (display_attr_caps terminfo_caps)

295270 (fixed_style attr)

296− (style_diffs diffs)

297− of

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

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

300− -- only case ever reached!

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

302− -- currently applied states.

303− EnterExitSeq caps

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

305− >>= apply_color_diff set_fore_color (fore_color_diff diffs)

306− >>= apply_color_diff set_back_color (back_color_diff diffs)

307− SetState state

308− -- implicitly resets the colors to the defaults

309− -> serialize_cap_expression (fromJust $ set_attr_states

310− $ display_attr_caps terminfo_caps

311− )

312− (sgr_args_for_state state)

313− out_ptr

314− >>= set_colors

271+ (style_diffs diffs) of

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

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

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

275+ -- the currently applied states.

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

277+ `mappend`

278+ write_color_diff set_fore_color (fore_color_diff diffs)

279+ `mappend`

280+ write_color_diff set_back_color (back_color_diff diffs)

281+ -- implicitly resets the colors to the defaults

282+ SetState state -> write_cap_expr (fromJust $ set_attr_states

283+ $ display_attr_caps terminfo_caps

284+ )

285+ (sgr_args_for_state state)

286+ `mappend` set_colors

315287 where

316288 color_map = case use_alt_color_map terminfo_caps of

317289 False -> ansi_color_index

318290 True -> alt_color_index

319291 attr = fix_display_attr prev_attr req_attr

320− set_colors ptr = do

321− ptr' <- case fixed_fore_color attr of

322− Just c -> serialize_cap_expression (set_fore_color terminfo_caps)

323− [ toEnum $ color_map c ]

324− ptr

325− Nothing -> return ptr

326− ptr'' <- case fixed_back_color attr of

327− Just c -> serialize_cap_expression (set_back_color terminfo_caps)

328− [ toEnum $ color_map c ]

329− ptr'

330− Nothing -> return ptr'

331− return ptr''

332− apply_color_diff _f NoColorChange ptr

333− = return ptr

334− apply_color_diff _f ColorToDefault _ptr

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

336− apply_color_diff f ( SetColor c ) ptr

337− = serialize_cap_expression (f terminfo_caps)

338− [ toEnum $ color_map c ]

339− ptr

292+ set_colors =

293+ (case fixed_fore_color attr of

294+ Just c -> write_cap_expr (set_fore_color terminfo_caps)

295+ [toEnum $ color_map c]

296+ Nothing -> mempty)

297+ `mappend`

298+ (case fixed_back_color attr of

299+ Just c -> write_cap_expr (set_back_color terminfo_caps)

300+ [toEnum $ color_map c]

301+ Nothing -> mempty)

302+ write_color_diff _f NoColorChange

303+ = mempty

304+ write_color_diff _f ColorToDefault

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

306+ write_color_diff f (SetColor c)

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

340308

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

342310-- be supported by the terminal.

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

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

55import Graphics.Vty.Output.Interface

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

8+import Blaze.ByteString.Builder (writeToByteString)

810import Control.Applicative

911import Control.Monad.Trans

1012

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

4850xterm_inline_hack :: Output -> IO ()

4951xterm_inline_hack t = do

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

51− send_to_terminal t (utf8_text_required_bytes s_utf8)

52− (serialize_utf8_text s_utf8)

53+ output_byte_buffer t $ writeToByteString $ write_utf8_text s_utf8

5354

test/VerifyEvalTerminfoCaps.hs+5−6

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

22{-# LANGUAGE NamedFieldPuns #-}

33module VerifyEvalTerminfoCaps where

5−import Data.Marshalling

6−

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

76import Data.Terminfo.Eval

87import Data.Terminfo.Parse

98import Control.DeepSeq

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

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

6463 parse_result <- parse_cap_expression cap_def

6564 case parse_result of

66− 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 ) ]

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

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

6867 Nothing -> do

6968 return []

7069

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

7574 let !byte_count = cap_expression_required_bytes expr input_values

7675 in liftIOResult $ do

7776 let start_ptr :: Ptr Word8 = eval_buffer

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

79− end_ptr <- serialize_cap_expression expr input_values start_ptr

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

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

8079 case end_ptr `minusPtr` start_ptr of

8180 count | count < 0 ->

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