4f3cd6c · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

optimize span generation. Use string-qq for tests.

4f3cd6cCorey O'Connor15 years ago

src/Graphics/Vty/Debug.hs+8−8

compare with master

unifiedsplit

@@ -10,20 +10,20 @@ import Graphics.Vty.Debug.Image

10import Graphics.Vty.Span

11import Graphics.Vty.DisplayRegion

13−import Data.Array

13+import qualified Data.Vector as Vector

14import Data.Word

16−row_ops_effected_columns :: SpanOpSequence -> [Word]

16+row_ops_effected_columns :: DisplayOps -> [Word]

17row_ops_effected_columns spans

18− = map span_ops_effected_columns (elems $ row_ops spans)

18+ = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans

20−all_spans_have_width :: SpanOpSequence -> Word -> Bool

20+all_spans_have_width :: DisplayOps -> Word -> Bool

21all_spans_have_width spans expected

22− = all (== expected) ( map span_ops_effected_columns (elems $ row_ops spans) )

22+ = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans

24−span_ops_effected_rows :: SpanOpSequence -> Word

24+span_ops_effected_rows :: DisplayOps -> Word

25−span_ops_effected_rows (SpanOpSequence _ the_row_ops)

25+span_ops_effected_rows (DisplayOps _ the_row_ops)

26− = toEnum $ length (filter (not . null) (elems the_row_ops))

26+ = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops))

28type SpanConstructLog = [SpanConstructEvent]

29data SpanConstructEvent = SpanSetAttr Attr

src/Graphics/Vty/Span.hs+150−89

@@ -18,18 +18,19 @@ import Codec.Binary.UTF8.String ( encode )

18import Control.Monad ( forM_ )

19import Control.Monad.ST.Strict

21−import Data.Array.ST

21+import Data.Vector (Vector)

22+import qualified Data.Vector as Vector hiding ( take, replicate )

23+import Data.Vector.Mutable ( MVector(..))

24+import qualified Data.Vector.Mutable as Vector

25+

22import qualified Data.ByteString as B

26import qualified Data.ByteString as B

23import qualified Data.ByteString.Internal as BInt

27import qualified Data.ByteString.Internal as BInt

24import qualified Data.Foldable as Foldable

28import qualified Data.Foldable as Foldable

25−import Data.List

26import qualified Data.String.UTF8 as UTF8

29import qualified Data.String.UTF8 as UTF8

27import Data.Word

30import Data.Word

29import Foreign.Storable ( pokeByteOff )

32import Foreign.Storable ( pokeByteOff )

31−import GHC.Arr

32−

33{- | A picture is translated into a sequences of state changes and character spans.

34{- | A picture is translated into a sequences of state changes and character spans.

34 - State changes are currently limited to new attribute values. The attribute is applied to all

35 - State changes are currently limited to new attribute values. The attribute is applied to all

35 - following spans. Including spans of the next row. The nth element of the sequence represents the

36 - following spans. Including spans of the next row. The nth element of the sequence represents the

@@ -37,39 +38,45 @@ import GHC.Arr

37 -

38 -

38 - A span op sequence will be defined for all rows and columns (and no more) of the region provided

39 - A span op sequence will be defined for all rows and columns (and no more) of the region provided

39 - with the picture to spans_for_pic.

40 - with the picture to spans_for_pic.

40− -

41 -

42 - todo: Partition attribute changes into multiple categories according to the serialized

43 - representation of the various attributes.

44 -}

45−data SpanOpSequence = SpanOpSequence

46− { effected_region :: DisplayRegion

47− , row_ops :: RowOps

48− }

46+data DisplayOps = DisplayOps

47+ { effected_region :: DisplayRegion

48+ , display_ops :: RowOps

49+ }

50+

51+-- vector of span operation vectors. One per row of the screen.

50−type RowOps = Array Word SpanOps

52+type RowOps = Vector SpanOps

51−type SpanOps = [SpanOp]

53+

54+type MRowOps s = MVector s SpanOps

56+-- vector of span operations. executed in succession

57+type SpanOps = Vector SpanOp

58+

59+type MSpanOps s = MVector s SpanOp

60+

53−instance Show SpanOpSequence where

61+instance Show DisplayOps where

54− show (SpanOpSequence _ the_row_ops)

62+ show (DisplayOps _ the_row_ops)

55− = concat $ ["{ "] ++ map (\ops -> show ops ++ "; " ) (elems the_row_ops) ++ [" }"]

63+ = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"

57instance Show SpanOp where

65instance Show SpanOp where

58 show (AttributeChange attr) = show attr

66 show (AttributeChange attr) = show attr

59 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw

67 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw

61−span_ops_columns :: SpanOpSequence -> Word

69+span_ops_columns :: DisplayOps -> Word

62span_ops_columns ops = region_width $ effected_region ops

70span_ops_columns ops = region_width $ effected_region ops

64−span_ops_rows :: SpanOpSequence -> Word

72+span_ops_rows :: DisplayOps -> Word

65span_ops_rows ops = region_height $ effected_region ops

73span_ops_rows ops = region_height $ effected_region ops

67−span_ops_effected_columns :: [SpanOp] -> Word

75+span_ops_effected_columns :: SpanOps -> Word

68−span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops

76+span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops

69 where

77 where

70− span_ops_effected_columns' t [] = t

78+ span_ops_effected_columns' t (TextSpan w _ _ ) = t + w

71− span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r

72− span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r

79+ span_ops_effected_columns' t _ = t

74-- |

81-- |

75--

82--

@@ -84,54 +91,70 @@ data SpanOp =

84 | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)

91 | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)

85 deriving Eq

92 deriving Eq

94+-- used to determine the width of a span operation , if it has one.

87span_op_has_width :: SpanOp -> Maybe (Word, Word)

95span_op_has_width :: SpanOp -> Maybe (Word, Word)

88span_op_has_width (TextSpan ow cw _) = Just (cw, ow)

96span_op_has_width (TextSpan ow cw _) = Just (cw, ow)

89span_op_has_width _ = Nothing

97span_op_has_width _ = Nothing

99+-- returns the number of columns to the character at the given position in the span op

91columns_to_char_offset :: Word -> SpanOp -> Word

100columns_to_char_offset :: Word -> SpanOp -> Word

92columns_to_char_offset cx (TextSpan _ _ utf8_str) =

101columns_to_char_offset cx (TextSpan _ _ utf8_str) =

93 let str = UTF8.toString utf8_str

102 let str = UTF8.toString utf8_str

94− in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str

103+ in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str

95columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"

104columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"

105

97-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the

106-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the

98-- specified region.

107-- specified region.

99−spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence

108+spans_for_pic :: Picture -> DisplayRegion -> DisplayOps

100−spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r)

109+spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r)

101

110

102−build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp])

111+build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)

103build_spans pic region = do

112build_spans pic region = do

104− -- m for mutable

113+ -- m for mutable! ;-)

105− mrow_ops <- newSTArray (0, region_height region - 1) []

114+ mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty

106− -- I think this can be better optimized if the build produced span operations in display order.

115+ -- XXX: I think building the span operations in display order would provide better performance.

107 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

116 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

108 -- as a possible future optimization.

117 -- as a possible future optimization.

109 --

118 --

110− -- A depth first traversal of the image is performed.

119+ -- A depth first traversal of the image is performed. ordered according to the column range

111− -- ordered according to the column range defined by the image from least to greatest.

120+ -- defined by the image from least to greatest. The output row ops will at least have the

112− -- The output row ops will at least have the region of the image specified. Iterate over all

113− -- output rows and output background fills for all unspecified columns.

121+ -- region of the image specified. Iterate over all output rows and output background fills for

122+ -- all unspecified columns.

123+ --

124+ -- The images are made into span operations from left to right. It's possible that this could

125+ -- easily be made to assure top to bottom output as well.

114 if region_height region > 0

126 if region_height region > 0

115 then do

127 then do

116 -- The ops builder recursively descends the image and outputs span ops that would

128 -- The ops builder recursively descends the image and outputs span ops that would

117 -- display that image. The number of columns remaining in this row before exceeding the

129 -- display that image. The number of columns remaining in this row before exceeding the

118− -- bounds is also provided. This is used to clip the span ops produced.

130+ -- bounds is also provided. This is used to clip the span ops produced to the display.

119− _ <- ops_for_row mrow_ops (pic_background pic) region (pic_image pic) (0,0) 0 (region_width region)

131+ -- The skip dimensions provided do....???

132+ _ <- row_ops_for_image mrow_ops

133+ (pic_image pic)

134+ (pic_background pic)

135+ region

136+ (0,0)

137+ 0

138+ (region_width region)

120 -- Fill in any unspecified columns with the background pattern.

139 -- Fill in any unspecified columns with the background pattern.

121− forM_ [0 .. region_height region - 1] $ \row -> do

140+ forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do

122− end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns

141+ end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns

123 if end_x < region_width region

142 if end_x < region_width region

124 then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row

143 then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row

125 else return ()

144 else return ()

126 else return ()

145 else return ()

127 return mrow_ops

146 return mrow_ops

128

147

129−type MRowOps s = STArray s Word SpanOps

130−

131−ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> (Word, Word) -> Word -> Word -> ST s (Word, Word)

148+row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> ST s (Word, Word)

149+row_ops_for_image mrow_ops -- the image to output the ops to

150+ image -- the image to rasterize in column order to mrow_ops

151+ bg -- the background fill

152+ region -- ???

132−ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_columns

153+ skip_dim@(skip_row,skip_col) -- the number of rows

154+ y -- ???

155+ remaining_columns -- ???

133 | remaining_columns == 0 = return skip_dim

156 | remaining_columns == 0 = return skip_dim

134− | y >= region_height region = return skip_dim

157+ | y >= fromEnum (region_height region) = return skip_dim

135 | otherwise = case image of

158 | otherwise = case image of

136 EmptyImage -> return skip_dim

159 EmptyImage -> return skip_dim

137 -- The width provided is the number of columns this text span will occupy when displayed.

160 -- The width provided is the number of columns this text span will occupy when displayed.

@@ -143,22 +166,34 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co

143 else do

166 else do

144 skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns

167 skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns

145 return (skip_row, skip_col')

168 return (skip_row, skip_col')

146− VertJoin t b _ _ -> do

169+ VertJoin top_image bottom_image _ _ -> do

147− (skip_row',skip_col') <- ops_for_row mrow_ops bg region t skip_dim y remaining_columns

170+ (skip_row',skip_col') <- row_ops_for_image mrow_ops

148− (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region b (skip_row', skip_col) (y + image_height t - (skip_row - skip_row')) remaining_columns

171+ top_image

172+ bg

173+ region

174+ skip_dim

175+ y

176+ remaining_columns

177+ (skip_row'',skip_col'') <- row_ops_for_image mrow_ops

178+ bottom_image

179+ bg

180+ region

181+ (skip_row', skip_col)

182+ (y + (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row'))

183+ remaining_columns

149 return (skip_row'', min skip_col' skip_col'')

184 return (skip_row'', min skip_col' skip_col'')

150 HorizJoin l r _ _ -> do

185 HorizJoin l r _ _ -> do

151− (skip_row',skip_col') <- ops_for_row mrow_ops bg region l skip_dim y remaining_columns

186+ (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns

152 -- Don't output the right part unless there is at least a single column left after

187 -- Don't output the right part unless there is at least a single column left after

153 -- outputting the left part.

188 -- outputting the left part.

154 if image_width l - (skip_col - skip_col') > remaining_columns

189 if image_width l - (skip_col - skip_col') > remaining_columns

155 then return (skip_row,skip_col')

190 then return (skip_row,skip_col')

156 else do

191 else do

157− (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region r (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col'))

192+ (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col'))

158 return (min skip_row' skip_row'', skip_col'')

193 return (min skip_row' skip_row'', skip_col'')

159 BGFill width height -> do

194 BGFill width height -> do

160− let min_height = if y + height > region_height region

195+ let min_height = if y + (fromEnum height) > (fromEnum $! region_height region)

161− then region_height region - y

196+ then region_height region - (toEnum y)

162 else height

197 else height

163 min_width = if width > remaining_columns

198 min_width = if width > remaining_columns

164 then remaining_columns

199 then remaining_columns

@@ -169,7 +204,7 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co

169 actual_width = if skip_col > min_width

204 actual_width = if skip_col > min_width

170 then 0

205 then 0

171 else min_width - skip_col

206 else min_width - skip_col

172− forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'

207+ forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y'

173 let skip_row' = if actual_height > skip_row

208 let skip_row' = if actual_height > skip_row

174 then 0

209 then 0

175 else skip_row - min_height

210 else skip_row - min_height

@@ -181,25 +216,25 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co

181 if dx < 0

216 if dx < 0

182 -- Translation left

217 -- Translation left

183 -- Extract the delta and add it to skip_col.

218 -- Extract the delta and add it to skip_col.

184− then ops_for_row mrow_ops bg region (translate (0, dy) i) (skip_row, skip_col + dw) y remaining_columns

219+ then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns

185 -- Translation right

220 -- Translation right

186 else if dy < 0

221 else if dy < 0

187 -- Translation up

222 -- Translation up

188 -- Extract the delta and add it to skip_row.

223 -- Extract the delta and add it to skip_row.

189− then ops_for_row mrow_ops bg region (translate (dx, 0) i) (skip_row + dh, skip_col) y remaining_columns

224+ then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns

190 -- Translation down

225 -- Translation down

191 -- Pad the start of lines and above the image with a

226 -- Pad the start of lines and above the image with a

192 -- background_fill image.

227 -- background_fill image.

193− else ops_for_row mrow_ops bg region (background_fill ow dh <-> (background_fill dw ih <|> i)) skip_dim y remaining_columns

228+ else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns

194 where

229 where

195 dw = toEnum $ abs dx

230 dw = toEnum $ abs dx

196 dh = toEnum $ abs dy

231 dh = toEnum $ abs dy

197 ow = image_width image

232 ow = image_width image

198 ih = image_height i

233 ih = image_height i

199 ImageCrop (max_w,max_h) i ->

234 ImageCrop (max_w,max_h) i ->

200− if y >= max_h

235+ if y >= fromEnum max_h

201 then return skip_dim

236 then return skip_dim

202− else ops_for_row mrow_ops bg region i skip_dim y (min remaining_columns max_w)

237+ else row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w)

203 ImagePad (min_w,min_h) i -> do

238 ImagePad (min_w,min_h) i -> do

204 let hpad = if image_width i < min_w

239 let hpad = if image_width i < min_w

205 then background_fill (min_w - image_width i) (image_height i)

240 then background_fill (min_w - image_width i) (image_height i)

@@ -207,41 +242,68 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co

207 let vpad = if image_height i < min_h

242 let vpad = if image_height i < min_h

208 then background_fill (image_width i) (min_h - image_height i)

243 then background_fill (image_width i) (min_h - image_height i)

209 else empty_image

244 else empty_image

210− ops_for_row mrow_ops bg region ((i <|> hpad) <-> vpad) skip_dim y remaining_columns

245+ row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns

211

246

212−snoc_text_span :: Attr

247+snoc_text_span :: Attr -- the display attributes of the text span

213− -> DisplayString

248+ -> DisplayString -- the text to output

214− -> MRowOps s

249+ -> MRowOps s -- the display operations to add to

215− -> Word

250+ -> Word -- the number of display columns in the text span to

216− -> Word

251+ -- skip before outputting

217− -> Word

252+ -> Int -- the row of the display operations to add to

253+ -> Word -- the number of columns from the next column to be

254+ -- defined to the end of the display for the row.

218 -> ST s Word

255 -> ST s Word

219−snoc_text_span a text_str mrow_ops skip_col y remaining_columns = do

256+snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do

220 snoc_op mrow_ops y $ AttributeChange a

257 snoc_op mrow_ops y $ AttributeChange a

221− let (ow', dw', cw', txt) = Foldable.foldl'

258+ -- At most a text span will consist of remaining_columns characters

259+ -- we keep track of the position of the next character.

260+ let max_len :: Int = fromEnum remaining_columns

261+ mspan_chars <- Vector.new max_len

262+ ( used_display_columns, display_columns_skipped, used_char_count )

222− build_text_span

263+ <- Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str

223− ( 0, 0, 0, B.empty )

264+ -- once all characters have been output to mspan_chars we grab the used head

224− text_str

265+ out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars

266+ -- convert to UTF8 bytestring.

267+ -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold

268+ -- contained in fromString with the unfold in toList. No biggy right now then.

225− snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt)

269+ snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count)

226− return $ skip_col - dw'

270+ $! UTF8.fromString

271+ $! Vector.toList out_text

272+ return $ columns_to_skip - display_columns_skipped

227 where

273 where

228− build_text_span (ow', dw', char_count', b0) (c,w) = {-# SCC "build_text_span" #-}

274+ build_text_span mspan_chars (used_display_columns, display_columns_skipped, used_char_count)

229− if dw' == skip_col

275+ (out_char, char_display_width) = {-# SCC "build_text_span" #-}

276+ -- Only valid if the maximum width of a character is 2 display columns.

277+ -- XXX: Optimize into a skip pass then clipped fill pass

278+ if display_columns_skipped == columns_to_skip

230− then if ow' == remaining_columns

279+ then if used_display_columns == remaining_columns

231− then ( ow', dw', char_count', b0 )

280+ then return $! ( used_display_columns, display_columns_skipped, used_char_count )

232− else if (w + ow') > remaining_columns

281+ else if ( used_display_columns + char_display_width ) > remaining_columns

233− then ( remaining_columns, dw', char_count' + ooverflow, B.append b0 oelipses )

282+ then do

234− else ( ow' + w, dw', char_count' + 1, B.append b0 $ B.pack $ encode [c] )

283+ Vector.write mspan_chars used_char_count '…'

235− else if (w + dw') > skip_col

284+ return $! ( used_display_columns

236− then ( doverflow, skip_col, doverflow, B.append b0 delipses )

285+ , display_columns_skipped

237− else ( ow', w + dw', char_count', b0 )

286+ , used_char_count + 1

238− where

287+ )

239− doverflow = skip_col - dw'

288+ else do

240− delipses = B.pack $ encode $ genericReplicate doverflow '…'

289+ Vector.write mspan_chars used_char_count out_char

241− ooverflow = remaining_columns - ow'

290+ return $! ( used_display_columns + char_display_width

242− oelipses = B.pack $ encode $ genericReplicate ooverflow '…'

291+ , display_columns_skipped

292+ , used_char_count + 1

293+ )

294+ else if (display_columns_skipped + char_display_width) > columns_to_skip

295+ then do

296+ Vector.write mspan_chars used_char_count '…'

297+ return $! ( used_display_columns + 1

298+ , columns_to_skip

299+ , used_char_count + 1

300+ )

301+ else return $ ( used_display_columns

302+ , display_columns_skipped + char_display_width

303+ , used_char_count

304+ )

243

305

244−snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s ()

306+snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()

245snoc_bg_fill _row_ops _bg 0 _row

307snoc_bg_fill _row_ops _bg 0 _row

246 = return ()

308 = return ()

247snoc_bg_fill mrow_ops (Background c back_attr) fill_length row

309snoc_bg_fill mrow_ops (Background c back_attr) fill_length row

@@ -264,10 +326,9 @@ snoc_bg_fill mrow_ops (Background c back_attr) fill_length row

264 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)

326 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)

265 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)

327 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)

266

328

267−snoc_op :: MRowOps s -> Word -> SpanOp -> ST s ()

329+snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()

268snoc_op !mrow_ops !row !op = do

330snoc_op !mrow_ops !row !op = do

269− ops <- readSTArray mrow_ops row

331+ ops <- Vector.read mrow_ops row

270− let ops' = ops ++ [op]

332+ let ops' = Vector.snoc ops op

271− writeSTArray mrow_ops row ops'

333+ Vector.write mrow_ops row ops'

272− return ()

273

334

src/Graphics/Vty/Terminal/Generic.hs+21−22

@@ -21,11 +21,10 @@ import Graphics.Vty.DisplayAttributes

21import Control.Monad ( liftM )

22import Control.Monad.Trans

24−import Data.Array

25import qualified Data.ByteString.Internal as BSCore

24import qualified Data.ByteString.Internal as BSCore

26−import Data.Foldable

27import Data.IORef

25import Data.IORef

28import Data.String.UTF8 hiding ( foldl )

26import Data.String.UTF8 hiding ( foldl )

27+import qualified Data.Vector as Vector

30import System.IO

29import System.IO

@@ -110,7 +109,7 @@ display_context t b = do

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

109 display_terminal_instance t b (\ d -> DisplayHandle d t s)

111

110

112data DisplayState = DisplayState

111data DisplayState = DisplayState

113− { previous_output_ref :: IORef (Maybe SpanOpSequence)

112+ { previous_output_ref :: IORef (Maybe DisplayOps)

114 }

113 }

115

114

116initial_display_state :: MonadIO m => m DisplayState

115initial_display_state :: MonadIO m => m DisplayState

@@ -220,8 +219,8 @@ output_picture (DisplayHandle d t s) pic = do

220 -> if effected_region previous_ops /= effected_region ops

219 -> if effected_region previous_ops /= effected_region ops

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

220 then return $ replicate ( fromEnum $ region_height $ effected_region ops )

222 True

221 True

223− else return $ zipWith (/=) ( elems $ row_ops previous_ops )

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

224− ( elems $ row_ops ops )

223+ ( Vector.toList $ display_ops ops )

225

224

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

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

227 let total = hide_cursor_required_bytes d

226 let total = hide_cursor_required_bytes d

@@ -254,9 +253,9 @@ output_picture (DisplayHandle d t s) pic = do

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

253 liftIO $ writeIORef (previous_output_ref s) (Just ops)

255 return ()

254 return ()

256

255

257−required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word

256+required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Word

258required_bytes d in_fattr diffs ops =

257required_bytes d in_fattr diffs ops =

259− let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops )

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

260 in n

259 in n

261 where

260 where

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

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

@@ -272,11 +271,11 @@ span_ops_required_bytes d y in_fattr span_ops =

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

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

272 let header_required_bytes = move_cursor_required_bytes d 0 y

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

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

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

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

276− in (c + current_sum, fattr')

275+ in (c + current_sum, fattr')

277− )

276+ )

278− (header_required_bytes, in_fattr)

277+ (header_required_bytes, in_fattr)

279− span_ops

278+ span_ops

280

279

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

280span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)

282span_op_required_bytes d fattr (AttributeChange attr) =

281span_op_required_bytes d fattr (AttributeChange attr) =

@@ -292,12 +291,12 @@ serialize_output_ops :: ( MonadIO m, DisplayTerminal d )

292 -> OutputBuffer

291 -> OutputBuffer

293 -> FixedAttr

292 -> FixedAttr

294 -> [Bool]

293 -> [Bool]

295− -> SpanOpSequence

294+ -> DisplayOps

296 -> m OutputBuffer

295 -> m OutputBuffer

297serialize_output_ops d start_ptr in_fattr diffs ops = do

296serialize_output_ops d start_ptr in_fattr diffs ops = do

298− (_, end_ptr, _, _) <- foldlM serialize_output_ops'

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

299 ( 0, start_ptr, in_fattr, diffs )

298 ( 0, start_ptr, in_fattr, diffs )

300− ( row_ops ops )

299+ ( display_ops ops )

301 return end_ptr

300 return end_ptr

302 where

301 where

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

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

@@ -319,9 +318,9 @@ serialize_span_ops d y out_ptr in_fattr span_ops = do

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

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

319 out_ptr' <- serialize_move_cursor d 0 y out_ptr

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

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

322− foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )

321+ Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )

323− (out_ptr', in_fattr)

322+ (out_ptr', in_fattr)

324− span_ops

323+ span_ops

325

324

326serialize_span_op :: ( MonadIO m, DisplayTerminal d )

325serialize_span_op :: ( MonadIO m, DisplayTerminal d )

327 => d

326 => d

@@ -357,16 +356,16 @@ data CursorOutputMap = CursorOutputMap

357 { char_to_output_pos :: (Word, Word) -> (Word, Word)

356 { char_to_output_pos :: (Word, Word) -> (Word, Word)

358 }

357 }

359

358

360−cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap

359+cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap

361cursor_output_map span_ops _cursor = CursorOutputMap

360cursor_output_map span_ops _cursor = CursorOutputMap

362 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)

361 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)

363 }

362 }

364

363

365−cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word

364+cursor_column_offset :: DisplayOps -> Word -> Word -> Word

366cursor_column_offset span_ops cx cy =

365cursor_column_offset span_ops cx cy =

367− let cursor_row_ops = row_ops span_ops ! cy

366+ let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy)

368 (out_offset, _, _)

367 (out_offset, _, _)

369− = foldl' ( \(d, current_cx, done) op ->

368+ = Vector.foldl' ( \(d, current_cx, done) op ->

370 if done then (d, current_cx, done) else case span_op_has_width op of

369 if done then (d, current_cx, done) else case span_op_has_width op of

371 Nothing -> (d, current_cx, False)

370 Nothing -> (d, current_cx, False)

372 Just (cw, ow) -> case compare cx (current_cx + cw) of

371 Just (cw, ow) -> case compare cx (current_cx + cw) of

test/Verify.hs−5

@@ -24,7 +24,6 @@ import Test.QuickCheck.Monadic ( monadicIO )

25import qualified Codec.Binary.UTF8.String as UTF8

27−import Control.Applicative

28import Control.Monad.State.Strict

27import Control.Monad.State.Strict

30import Data.IORef

29import Data.IORef

@@ -37,10 +36,6 @@ import System.Random

38type Test = StateT TestState IO

37type Test = StateT TestState IO

40−instance Applicative Test where

41− pure = return

42− ( <*> ) = ap

43−

44data TestState = TestState

39data TestState = TestState

45 { results_ref :: IORef [QC.Result]

40 { results_ref :: IORef [QC.Result]

46 }

41 }

test/interactive_terminal_test.hs+28−28

@@ -13,10 +13,10 @@ import Control.Monad

13import Data.List ( lookup )

14import Data.Maybe ( isJust, fromJust )

15import Data.Monoid

16+import Data.String.QQ

16import Data.Word

17import Data.Word

18import Foreign.Marshal.Array

19import Foreign.Marshal.Array

19−import HereDoc

21import qualified System.Environment as Env

@@ -28,14 +28,14 @@ main = do

28output_file_path = "test_results.list"

30print_intro = do

31− putStr $ [$heredoc|

31+ putStr $ [s|

32This is an interactive verification program for the terminal input and output

33support of the VTY library. This will ask a series of questions about what you

34see on screen. The goal is to verify that VTY's output and input support

35performs as expected with your terminal.

37This program produces a file named

38− |] ++ output_file_path ++ [$heredoc|

38+ |] ++ output_file_path ++ [s|

39in the current directory that contains the results for each test assertion. This

40can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve

41support for your terminal. No personal information is contained in the report.

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

186 release_terminal t

187 return ()

188 , print_summary = do

189− putStr $ [$heredoc|

189+ putStr $ [s|

190Once return is pressed:

191 0. The screen will be cleared.

192 1. Four lines of text should be visible.

@@ -197,7 +197,7 @@ After return is pressed for the second time this test then:

197 * The cursor is visible.

198|]

199 , confirm_results = do

200− putStr $ [$heredoc|

200+ putStr $ [s|

201Did the test output match the description?

202|]

203 default_success_confirm_results

@@ -308,14 +308,14 @@ display_bounds_test_3 = Test

308 }

309

310display_bounds_test_summary has_cursor = do

311− putStr $ [$heredoc|

311+ putStr $ [s|

312Once return is pressed:

313 0. The screen will be cleared.

314|]

315 if has_cursor

316 then putStr " 1. The cursor will be visible."

317 else putStr " 1. The cursor will NOT be visible."

318− putStr [$heredoc|

318+ putStr [s|

319 2. The border of the display will be outlined in Xs.

320 So if - and | represented the edge of the terminal window:

321 |-------------|

@@ -323,12 +323,12 @@ Once return is pressed:

323 |X X||]

324

325 if has_cursor

326− then putStr $ [$heredoc|

326+ then putStr $ [s|

327 |XXXXXXXXXXXXC| |]

328− else putStr $ [$heredoc|

328+ else putStr $ [s|

329 |XXXXXXXXXXXXX| |]

330

331− putStr $ [$heredoc|

331+ putStr $ [s|

332 |-------------|

333

334 ( Where C is the final position of the cursor. There may be an X drawn

@@ -341,7 +341,7 @@ After return is pressed for the second time:

341|]

342

343generic_output_match_confirm = do

344− putStr $ [$heredoc|

344+ putStr $ [s|

345Did the test output match the description?

346|]

347 default_success_confirm_results

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

423 , confirm_results = generic_output_match_confirm

424 }

425

426−unicode_single_width_summary = putStr [$heredoc|

426+unicode_single_width_summary = putStr [s|

427Once return is pressed:

428 0. The screen will be cleared.

429 1. The cursor will be hidden.

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

505 , confirm_results = generic_output_match_confirm

506 }

507

508−unicode_double_width_summary = putStr [$heredoc|

508+unicode_double_width_summary = putStr [s|

509Once return is pressed:

510 0. The screen will be cleared.

511 1. The cursor will be hidden.

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

558 release_terminal t

559 return ()

560 , print_summary = do

561− putStr $ [$heredoc|

561+ putStr $ [s|

562Once return is pressed:

563 0. The screen will be cleared.

564 1. The cursor will be hidden.

@@ -579,7 +579,7 @@ After return is pressed for the second time:

579 1. The cursor should be visible.

580|]

581 , confirm_results = do

582− putStr $ [$heredoc|

582+ putStr $ [s|

583Did the test output match the description?

584|]

585 default_success_confirm_results

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

604 release_terminal t

605 return ()

606 , print_summary = do

607− putStr $ [$heredoc|

607+ putStr $ [s|

608Once return is pressed:

609 0. The screen will be cleared.

610 1. The cursor will be hidden.

@@ -634,7 +634,7 @@ After return is pressed for the second time:

634 1. The cursor should be visible.

635|]

636 , confirm_results = do

637− putStr $ [$heredoc|

637+ putStr $ [s|

638Did the test output match the description?

639|]

640 default_success_confirm_results

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

661 release_terminal t

662 return ()

663 , print_summary = do

664− putStr $ [$heredoc|

664+ putStr $ [s|

665Once return is pressed:

666 0. The screen will be cleared.

667 1. The cursor will be hidden.

@@ -693,7 +693,7 @@ After return is pressed for the second time:

693 1. The cursor should be visible.

694|]

695 , confirm_results = do

696− putStr $ [$heredoc|

696+ putStr $ [s|

697Did the test output match the description?

698|]

699 default_success_confirm_results

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

720 release_terminal t

721 return ()

722 , print_summary = do

723− putStr $ [$heredoc|

723+ putStr $ [s|

724Once return is pressed:

725 0. The screen will be cleared.

726 1. The cursor will be hidden.

@@ -760,7 +760,7 @@ After return is pressed for the second time:

760 1. The cursor should be visible.

761|]

762 , confirm_results = do

763− putStr $ [$heredoc|

763+ putStr $ [s|

764Did the test output match the description?

765|]

766 default_success_confirm_results

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

796 release_terminal t

797 return ()

798 , print_summary = do

799− putStr $ [$heredoc|

799+ putStr $ [s|

800Once return is pressed:

801 0. The screen will be cleared.

802 1. The cursor will be hidden.

@@ -823,7 +823,7 @@ After return is pressed for the second time:

823 1. The cursor should be visible.

824|]

825 , confirm_results = do

826− putStr $ [$heredoc|

826+ putStr $ [s|

827Did the test output match the description?

828|]

829 default_success_confirm_results

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

847 release_terminal t

848 return ()

849 , print_summary = do

850− putStr $ [$heredoc|

850+ putStr $ [s|

851Once return is pressed:

852 0. The screen will be cleared.

853 1. The cursor will be hidden.

@@ -861,7 +861,7 @@ After return is pressed for the second time:

861 1. The cursor should be visible.

862|]

863 , confirm_results = do

864− putStr $ [$heredoc|

864+ putStr $ [s|

865Did the test output match the description?

866|]

867 default_success_confirm_results

@@ -879,7 +879,7 @@ inline_test_0 = Test

879 putStrLn "line 3."

880 release_terminal t

881 return ()

882− , print_summary = putStr $ [$heredoc|

882+ , print_summary = putStr $ [s|

883lines are in order.

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

885The third line "line 3" should be drawn in the same style as the first line.

@@ -900,7 +900,7 @@ inline_test_1 = Test

900 putStrLn "Not styled."

901 release_terminal t

902 return ()

903− , print_summary = putStr $ [$heredoc|

903+ , print_summary = putStr $ [s|

904|]

905

906 , confirm_results = generic_output_match_confirm

@@ -918,7 +918,7 @@ inline_test_2 = Test

918 putStr "Not styled.\n"

919 release_terminal t

920 return ()

921− , print_summary = putStr $ [$heredoc|

921+ , print_summary = putStr $ [s|

922|]

923

924 , confirm_results = generic_output_match_confirm

test/verify_debug_terminal.hs+4−4

@@ -50,7 +50,7 @@ single_T_row (DebugWindow w h) = liftIOResult $ do

50 ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')

51 expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected

52 if out_bytes /= expected_bytes

53− then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

53+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

54 else return succeeded

56many_T_rows :: DebugWindow -> Property

@@ -67,7 +67,7 @@ many_T_rows (DebugWindow w h) = liftIOResult $ do

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

68 expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected

69 if out_bytes /= expected_bytes

70− then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

70+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

71 else return succeeded

73many_T_rows_cropped_width :: DebugWindow -> Property

@@ -84,7 +84,7 @@ many_T_rows_cropped_width (DebugWindow w h) = liftIOResult $ do

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

85 expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected

86 if out_bytes /= expected_bytes

87− then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

87+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

88 else return succeeded

90many_T_rows_cropped_height :: DebugWindow -> Property

@@ -101,7 +101,7 @@ many_T_rows_cropped_height (DebugWindow w h) = liftIOResult $ do

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

102 expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected

103 if out_bytes /= expected_bytes

104− then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

104+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }

105 else return succeeded

106

107main = run_test $ do

test/verify_eval_terminfo_caps.hs+5−6

@@ -104,8 +104,7 @@ main = do

104 parse_result <- parse_cap_expression cap_def

105 let test_name = "\teval cap " ++ cap_name ++ " -> " ++ show cap_def

106 _ <- case parse_result of

107− Left error -> verify test_name ( liftResult $ failed

107+ Left error -> verify test_name ( failed { reason = "prase error " ++ show error } )

108− $ result { reason = "prase error " ++ show error } )

109 Right !cap_expr -> verify test_name ( verify_eval_cap eval_buffer cap_expr )

108 Right !cap_expr -> verify test_name ( verify_eval_cap eval_buffer cap_expr )

110 return ()

109 return ()

111 Nothing -> do

110 Nothing -> do

@@ -124,11 +123,11 @@ verify_eval_cap eval_buffer expr !junk_int = do

124 end_ptr <- serialize_cap_expression expr input_values start_ptr

123 end_ptr <- serialize_cap_expression expr input_values start_ptr

125 case end_ptr `minusPtr` start_ptr of

124 case end_ptr `minusPtr` start_ptr of

126 count | count < 0 ->

125 count | count < 0 ->

127− return $ failed $ result { reason = "End pointer before start pointer." }

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

128 | toEnum count > byte_count ->

127 | toEnum count > byte_count ->

129− return $ failed $ result { reason = "End pointer past end of buffer by "

128+ return $ failed { reason = "End pointer past end of buffer by "

130− ++ show (toEnum count - byte_count)

129+ ++ show (toEnum count - byte_count)

131− }

130+ }

132 | otherwise ->

131 | otherwise ->

133 return succeeded

132 return succeeded

134

133

test/verify_span_ops.hs+2−2

@@ -11,7 +11,7 @@ import Graphics.Vty.Debug

12import Verify

14−import Data.Array

14+import qualified Data.Vector as Vector

16unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool

17unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) =

@@ -139,7 +139,7 @@ span_ops_actually_fill_columns (DefaultPic pic win _) =

139first_span_op_sets_attr :: DefaultPic -> Bool

140first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } =

141 let spans = spans_for_pic pic (region_for_window win)

142− in all ( is_attr_span_op . head ) ( elems $ row_ops spans )

142+ in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans )

143

144single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result

145single_attr_single_span_stack_op_coverage stack =

vty.cabal+2−2

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

1Name: vty

2−Version: 4.7.0.1

2+Version: 4.7.0.3

3License: BSD3

4License-file: LICENSE

5Author: Stefan O'Rear, Corey O'Connor

@@ -33,7 +33,7 @@ Build-Depends: terminfo >= 0.3 && < 0.4

33Build-Depends: utf8-string >= 0.3 && < 0.4

34Build-Depends: mtl >= 1.1.1.0 && < 2.1

35Build-Depends: ghc-prim, parallel >= 2.2 && < 3.2, deepseq >= 1.1 && < 1.2

36−Build-Depends: array

36+Build-Depends: vector >= 0.7

37Build-Depends: parsec >= 2 && < 4

38Build-Type: Simple

39Data-Files: README, TODO