c998873 · vty · git.iko.soy

git.iko.soy/vty

more tests on cropping, plus some suspect fixes

commitc998873eaa59c7e27a611b21b592e26241c1d9ed authorCorey O'Connor <corey@ooyala.com> dateTue 13 Aug 2013, 00:16 (13 years ago) parent211ad02

12 files changed+257−137

compare with master

unifiedsplit

src/Graphics/Vty/Debug.hs+6−6 src/Graphics/Vty/Image.hs+4−4 src/Graphics/Vty/Image/Internal.hs+29 src/Graphics/Vty/PictureToSpans.hs+51−26 src/Graphics/Vty/Span.hs+14−16 src/Graphics/Vty/Terminal/Interface.hs+9−9 src/Graphics/Vty/Terminal/XTermColor.hs+1−1 test/Verify.hs+6−3 test/Verify/Graphics/Vty/Image.hs+39−18 test/Verify/Graphics/Vty/Span.hs+9−9 test/VerifySpanOps.hs+88−44 vty.cabal+1−1

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

@@ -13,16 +13,16 @@ import Graphics.Vty.DisplayRegion

1313import qualified Data.Vector as Vector

1414

1515row_ops_effected_columns :: DisplayOps -> [Int]

16−row_ops_effected_columns spans

17− = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans

16+row_ops_effected_columns ops

17+ = Vector.toList $ Vector.map span_ops_effected_columns ops

1818

1919all_spans_have_width :: DisplayOps -> Int -> Bool

20−all_spans_have_width spans expected

21− = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans

20+all_spans_have_width ops expected

21+ = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns ops

2222

2323span_ops_effected_rows :: DisplayOps -> Int

24−span_ops_effected_rows (DisplayOps _ the_row_ops)

25− = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops))

24+span_ops_effected_rows ops

25+ = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))

2626

2727type SpanConstructLog = [SpanConstructEvent]

2828data SpanConstructEvent = SpanSetAttr Attr

src/Graphics/Vty/Image.hs+4−4

@@ -276,7 +276,7 @@ crop_bottom h in_i

276276 go EmptyImage = EmptyImage

277277 go i@(CropBottom {cropped_image, output_width, output_height})

278278 | output_height <= h = i

279− | otherwise = CropBottom cropped_image output_width (min h output_height)

279+ | otherwise = CropBottom cropped_image output_width h

280280 go i

281281 | h >= image_height i = i

282282 | otherwise = CropBottom i (image_width i) h

@@ -292,7 +292,7 @@ crop_right w in_i

292292 go EmptyImage = EmptyImage

293293 go i@(CropRight {cropped_image, output_width, output_height})

294294 | output_width <= w = i

295− | otherwise = CropRight cropped_image (min w output_width) output_height

295+ | otherwise = CropRight cropped_image w output_height

296296 go i

297297 | w >= image_width i = i

298298 | otherwise = CropRight i w (image_height i)

@@ -309,7 +309,7 @@ crop_left w in_i

309309 go i@(CropLeft {cropped_image, left_skip, output_width, output_height})

310310 | output_width <= w = i

311311 | otherwise =

312− let left_skip' = left_skip + w - output_width

312+ let left_skip' = left_skip + output_width - w

313313 in CropLeft cropped_image left_skip' w output_height

314314 go i

315315 | image_width i <= w = i

@@ -327,7 +327,7 @@ crop_top h in_i

327327 go i@(CropTop {cropped_image, top_skip, output_width, output_height})

328328 | output_height <= h = i

329329 | otherwise =

330− let top_skip' = top_skip + h - output_height

330+ let top_skip' = top_skip + output_height - h

331331 in CropTop cropped_image top_skip' output_width h

332332 go i

333333 | image_height i <= h = i

src/Graphics/Vty/Image/Internal.hs+29

@@ -125,6 +125,35 @@ instance Show Image where

125125 ++ " (" ++ show cropped_image ++ ")"

126126 show ( EmptyImage ) = "EmptyImage"

127127

128+-- | Attempts to pretty print just the structure of an image.

129+pp_image_structure :: Image -> String

130+pp_image_structure in_img = go 0 in_img

131+ where

132+ go indent img = tab indent ++ pp indent img

133+ tab indent = concat $ replicate indent " "

134+ pp _ (HorizText {output_width}) = "HorizText(" ++ show output_width ++ ")"

135+ pp _ (BGFill {output_width, output_height})

136+ = "BGFill(" ++ show output_width ++ "," ++ show output_height ++ ")"

137+ pp i (HorizJoin {part_left = l, part_right = r, output_width = c})

138+ = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r

139+ pp i (VertJoin {part_top = t, part_bottom = b, output_width = c, output_height = r})

140+ = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"

141+ ++ go (i+1) t ++ "\n"

142+ ++ go (i+1) b

143+ pp i (CropRight {cropped_image, output_width, output_height})

144+ = "CropRight(" ++ show output_width ++ "," ++ show output_height ++ ")\n"

145+ ++ go (i+1) cropped_image

146+ pp i (CropLeft {cropped_image, left_skip, output_width, output_height})

147+ = "CropLeft(" ++ show left_skip ++ "->" ++ show output_width ++ "," ++ show output_height ++ ")\n"

148+ ++ go (i+1) cropped_image

149+ pp i (CropBottom {cropped_image, output_width, output_height})

150+ = "CropBottom(" ++ show output_width ++ "," ++ show output_height ++ ")\n"

151+ ++ go (i+1) cropped_image

152+ pp i (CropTop {cropped_image, top_skip, output_width, output_height})

153+ = "CropTop("++ show output_width ++ "," ++ show top_skip ++ "->" ++ show output_height ++ ")\n"

154+ ++ go (i+1) cropped_image

155+ pp _ EmptyImage = "EmptyImage"

156+

128157instance NFData Image where

129158 rnf EmptyImage = ()

130159 rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()

src/Graphics/Vty/PictureToSpans.hs+51−26

@@ -5,6 +5,8 @@

55{-# LANGUAGE ExistentialQuantification #-}

66{-# LANGUAGE ScopedTypeVariables #-}

77{-# LANGUAGE NamedFieldPuns #-}

8+{- | Transforms an image into rows of operations.

9+ -}

810module Graphics.Vty.PictureToSpans where

911

1012import Graphics.Vty.DisplayRegion

@@ -61,15 +63,20 @@ type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a

6163

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

6365-- specified region.

64−spans_for_pic :: Picture -> DisplayRegion -> DisplayOps

65−spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pic r)

66+display_ops_for_pic :: Picture -> DisplayRegion -> DisplayOps

67+display_ops_for_pic pic r = Vector.create (combined_ops_for_layers pic r)

68+

69+-- | Returns the DisplayOps for an image rendered to a window the size of the image. Used only for debugging.

70+display_ops_for_image :: Image -> DisplayOps

71+display_ops_for_image i = display_ops_for_pic (pic_for_image i)

72+ (DisplayRegion (image_width i) (image_height i))

6673

6774-- | Produces the span ops for each layer then combines them.

6875--

6976-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire

7077-- region.

71−combined_spans_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)

72−combined_spans_for_layers pic r

78+combined_ops_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)

79+combined_ops_for_layers pic r

7380 | region_width r == 0 || region_height r == 0 = MVector.new 0

7481 | otherwise = do

7582 layer_ops <- mapM (\layer -> build_spans layer r) (pic_layers pic)

@@ -169,15 +176,23 @@ build_spans image out_region = do

169176-- returns the number of columns and rows contributed to the output.

170177start_image_build :: Image -> BlitM s ()

171178start_image_build image = do

172− out_of_bounds <- is_out_of_bounds <$> get

179+ out_of_bounds <- is_out_of_bounds image <$> get

173180 when (not out_of_bounds) $ add_maybe_clipped image

174181

175−is_out_of_bounds :: BlitState -> Bool

176−is_out_of_bounds s

177− | s ^. remaining_columns <= 0 = True

178− | s ^. remaining_rows <= 0 = True

179− | otherwise = False

182+is_out_of_bounds :: Image -> BlitState -> Bool

183+is_out_of_bounds i s

184+ | s ^. remaining_columns <= 0 = True

185+ | s ^. remaining_rows <= 0 = True

186+ | s ^. skip_columns >= image_width i = True

187+ | s ^. skip_rows >= image_height i = True

188+ | otherwise = False

180189

190+-- | This adds an image that might be partially clipped to the output ops.

191+--

192+-- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom

193+-- implementations are odd. They pass the current tests but something seems terribly wrong about all

194+-- this.

195+--

181196-- TODO: prove this cannot be called in an out of bounds case.

182197add_maybe_clipped :: forall s . Image -> BlitM s ()

183198add_maybe_clipped EmptyImage = return ()

@@ -213,15 +228,19 @@ add_maybe_clipped BGFill {output_width, output_height} = do

213228 y <- use row_offset

214229 forM_ [y..y+output_height'-1] $ snoc_op (Skip output_width')

215230add_maybe_clipped CropRight {cropped_image, output_width} = do

231+ s <- use skip_columns

216232 r <- use remaining_columns

217− when (r > output_width) $ remaining_columns .= output_width

233+ let x = output_width - s

234+ when (x < r) $ remaining_columns .= x

218235 add_maybe_clipped cropped_image

219236add_maybe_clipped CropLeft {cropped_image, left_skip} = do

220237 skip_columns += left_skip

221238 add_maybe_clipped cropped_image

222239add_maybe_clipped CropBottom {cropped_image, output_height} = do

240+ s <- use skip_rows

223241 r <- use remaining_rows

224− when (r > output_height) $ remaining_rows .= output_height

242+ let x = output_height - s

243+ when (x < r) $ remaining_rows .= x

225244 add_maybe_clipped cropped_image

226245add_maybe_clipped CropTop {cropped_image, top_skip} = do

227246 skip_rows += top_skip

@@ -238,30 +257,32 @@ add_maybe_clipped_join :: forall s . String

238257 -> BlitM s ()

239258add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do

240259 state <- get

241− when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"

260+ when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"

242261 case state^.skip of

243− s | s >= size -> fail $ name ++ " on fully clipped"

244− -- TODO: check if clipped in other dim. if not use add_unclipped

245− | s == 0 -> case state^.remaining of

246− r | r > i0_dim -> do

262+ s -- TODO: check if clipped in other dim. if not use add_unclipped

263+ | s >= size -> fail $ name ++ " on fully clipped"

264+ | s == 0 -> if state^.remaining > i0_dim

265+ then do

266+ add_maybe_clipped i0

267+ put $ state & offset +~ i0_dim & remaining -~ i0_dim

268+ add_maybe_clipped i1

269+ else add_maybe_clipped i0

270+ | s < i0_dim ->

271+ let i0_dim' = i0_dim - s

272+ in if state^.remaining <= i0_dim'

273+ then add_maybe_clipped i0

274+ else do

247275 add_maybe_clipped i0

248− put $ state & offset +~ i0_dim & remaining -~ i0_dim

276+ put $ state & offset +~ i0_dim' & remaining -~ i0_dim' & skip .~ 0

249277 add_maybe_clipped i1

250− | otherwise -> add_maybe_clipped i0

251278 | s >= i0_dim -> do

252279 put $ state & skip -~ i0_dim

253280 add_maybe_clipped i1

254− | otherwise -> case i0_dim - s of

255− i0_dim' | state^.remaining <= i0_dim' -> add_maybe_clipped i0

256− | otherwise -> do

257− add_maybe_clipped i0

258− put $ state & offset +~ i0_dim' & remaining -~ i0_dim'

259− add_maybe_clipped i1

281+ _ -> fail $ name ++ " has unhandled skip class"

260282

261283-- TODO: store a skip list in HorizText(?)

262284-- TODO: represent display strings containing chars that are not 1 column chars as a separate

263285-- display string value?

264−-- TODO: assumes max column width is 2

265286clip_text :: DisplayText -> Int -> Int -> DisplayText

266287clip_text txt left_skip right_clip =

267288 -- CPS would clarify this I think

@@ -271,6 +292,7 @@ clip_text txt left_skip right_clip =

271292 txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)

272293 clip_for_char_width 0 _ n = (n, False)

273294 clip_for_char_width w t n

295+ | TL.null t = (n, False)

274296 | w < cw = (n, True)

275297 | w == cw = (n+1, False)

276298 | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)

@@ -299,8 +321,11 @@ add_row_completion display_region row = do

299321snoc_op :: SpanOp -> Int -> BlitM s ()

300322snoc_op !op !row = do

301323 the_mrow_ops <- view mrow_ops

324+ the_region <- view region

302325 lift $ lift $ do

303326 ops <- MVector.read the_mrow_ops row

304327 let ops' = Vector.snoc ops op

328+ when (span_ops_effected_columns ops' > region_width the_region)

329+ $ fail $ "row " ++ show row ++ " now exceeds region width"

305330 MVector.write the_mrow_ops row ops'

306331

src/Graphics/Vty/Span.hs+14−16

@@ -21,7 +21,7 @@ import Graphics.Vty.DisplayRegion

2121import Graphics.Vty.Image

2222

2323import Data.Vector (Vector)

24−import qualified Data.Vector as Vector hiding ( take, replicate )

24+import qualified Data.Vector as Vector

2525

2626import qualified Data.ByteString as BS

2727import qualified Data.Text as T

@@ -52,17 +52,8 @@ data SpanOp =

5252-- color is changed.

5353type SpanOps = Vector SpanOp

5454

55−data DisplayOps = DisplayOps

56− { effected_region :: DisplayRegion

57− , display_ops :: RowOps

58− }

59−

60−-- | vector of span operation vectors. One per row of the screen.

61−type RowOps = Vector SpanOps

62−

63−instance Show DisplayOps where

64− show (DisplayOps _ the_row_ops)

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

55+-- | vector of span operation vectors for display. One per row of the output region.

56+type DisplayOps = Vector SpanOps

6657

6758instance Show SpanOp where

6859 show (AttributeChange attr) = show attr

@@ -71,12 +62,19 @@ instance Show SpanOp where

7162 show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"

7263

7364-- | Number of columns the DisplayOps are defined for

74−span_ops_columns :: DisplayOps -> Int

75−span_ops_columns ops = region_width $ effected_region ops

65+--

66+-- All spans are verified to define same number of columns. See: VerifySpanOps

67+display_ops_columns :: DisplayOps -> Int

68+display_ops_columns ops

69+ | Vector.length ops == 0 = 0

70+ | otherwise = Vector.length $ Vector.head ops

7671

7772-- | Number of rows the DisplayOps are defined for

78−span_ops_rows :: DisplayOps -> Int

79−span_ops_rows ops = region_height $ effected_region ops

73+display_ops_rows :: DisplayOps -> Int

74+display_ops_rows ops = Vector.length ops

75+

76+effected_region :: DisplayOps -> DisplayRegion

77+effected_region ops = DisplayRegion (display_ops_columns ops) (display_ops_rows ops)

8078

8179-- | The number of columns a SpanOps effects.

8280span_ops_effected_columns :: SpanOps -> Int

src/Graphics/Vty/Terminal/Interface.hs+9−9

@@ -140,7 +140,7 @@ output_picture dc pic = liftIO $ do

140140 as <- readIORef (assumed_state_ref $ context_device dc)

141141 let manip_cursor = supports_cursor_visibility (context_device dc)

142142 let !r = context_region dc

143− !ops = spans_for_pic pic r

143+ !ops = display_ops_for_pic pic r

144144 !initial_attr = FixedAttr default_style_mask Nothing Nothing

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

146146 -- basis.

@@ -148,9 +148,9 @@ output_picture dc pic = liftIO $ do

148148 diffs :: [Bool] = case prev_output_ops as of

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

150150 Just previous_ops -> if effected_region previous_ops /= effected_region ops

151− then replicate (fromEnum $ region_height $ effected_region ops) True

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

153− (Vector.toList $ display_ops ops)

151+ then replicate (display_ops_rows ops) True

152+ else zipWith (/=) (Vector.toList previous_ops)

153+ (Vector.toList ops)

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

155155 total = (if manip_cursor then hide_cursor_required_bytes dc else 0)

156156 + default_attr_required_bytes dc

@@ -187,7 +187,7 @@ output_picture dc pic = liftIO $ do

187187

188188required_bytes :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Int

189189required_bytes dc in_fattr diffs ops =

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

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

191191 in n

192192 where

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

@@ -199,7 +199,7 @@ required_bytes dc in_fattr diffs ops =

199199 = error "shouldn't be possible"

200200

201201span_ops_required_bytes :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)

202−span_ops_required_bytes dc y in_fattr span_ops =

202+span_ops_required_bytes dc y in_fattr span_ops =

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

204204 let header_required_bytes = move_cursor_required_bytes dc 0 y

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

@@ -229,7 +229,7 @@ serialize_output_ops :: DisplayContext

229229serialize_output_ops dc start_ptr in_fattr diffs ops = do

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

231231 ( 0, start_ptr, in_fattr, diffs )

232− ( display_ops ops )

232+ ops

233233 return end_ptr

234234 where

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

@@ -295,8 +295,8 @@ cursor_output_map span_ops _cursor = CursorOutputMap

295295 }

296296

297297cursor_column_offset :: DisplayOps -> Int -> Int -> Int

298−cursor_column_offset span_ops cx cy =

299− let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy)

298+cursor_column_offset ops cx cy =

299+ let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)

300300 (out_offset, _, _)

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

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

src/Graphics/Vty/Terminal/XTermColor.hs+1−1

@@ -35,7 +35,7 @@ reserve_terminal variant out_handle = liftIO $ do

3535 liftIO $ flushed_put set_default_char_set

3636 release_terminal t

3737 , mk_display_context = \t_actual r -> do

38− dc <- mk_display_context t_actual t_actual r

38+ dc <- mk_display_context t t_actual r

3939 return $ dc { inline_hack = xterm_inline_hack t' }

4040 }

4141 return t'

test/Verify.hs+6−3

@@ -58,9 +58,12 @@ verify test_name p = Test $ TestInstance

5858 , run = do

5959 qc_result <- quickCheckResult p

6060 case qc_result of

61− QC.Success {..} -> return $ Finished TS.Pass

62− QC.Failure {output} -> return $ Finished $ TS.Fail output

63− _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"

61+ QC.Success {..} -> return $ Finished TS.Pass

62+ QC.Failure {numShrinks,reason} -> return $ Finished

63+ $ TS.Fail $ "After "

64+ ++ show numShrinks ++ " shrinks determined failure to be: "

65+ ++ show reason

66+ _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"

6467 , tags = []

6568 , options = []

6669 , setOption = \_ _ -> Left "no options supported"

test/Verify/Graphics/Vty/Image.hs+39−18

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE NamedFieldPuns #-}

23{-# LANGUAGE DisambiguateRecordFields #-}

34module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image

@@ -49,7 +50,7 @@ newtype WidthResize = WidthResize (Image -> (Image, Int))

4950instance Arbitrary WidthResize where

5051 arbitrary = do

5152 WidthResize f <- arbitrary

52− w <- choose (1,1024)

53+ w <- choose (1,64)

5354 oneof $ map (return . WidthResize)

5455 [ \i -> (i, image_width i)

5556 , \i -> (resize_width w $ fst $ f i, w)

@@ -62,7 +63,7 @@ newtype HeightResize = HeightResize (Image -> (Image, Int))

6263instance Arbitrary HeightResize where

6364 arbitrary = do

6465 HeightResize f <- arbitrary

65− h <- choose (1,1024)

66+ h <- choose (1,64)

6667 oneof $ map (return . HeightResize)

6768 [ \i -> (i, image_height i)

6869 , \i -> (resize_height h $ fst $ f i, h)

@@ -102,7 +103,7 @@ instance Arbitrary SingleRowSingleAttrImage where

102103 -- The text must contain at least one character. Otherwise the image simplifies to the

103104 -- IdImage which has a height of 0. If this is to represent a single row then the height

104105 -- must be 1

105− single_column_row_text <- Verify.resize 128 (listOf1 arbitrary)

106+ single_column_row_text <- Verify.resize 16 (listOf1 arbitrary)

106107 a <- arbitrary

107108 let out_image = horiz_cat $ [char a c | SingleColumnChar c <- single_column_row_text]

108109 out_width = length single_column_row_text

@@ -131,11 +132,13 @@ data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack

131132

132133instance Arbitrary SingleAttrSingleSpanStack where

133134 arbitrary = do

134− image_list <- Verify.resize 128 (listOf1 arbitrary)

135+ image_list <- Verify.resize 16 (listOf1 arbitrary)

135136 return $ mk_single_attr_single_span_stack image_list

136137 shrink s = do

137138 image_list <- shrink $ stack_source_images s

138− return $ mk_single_attr_single_span_stack image_list

139+ if null image_list

140+ then []

141+ else return $ mk_single_attr_single_span_stack image_list

139142

140143mk_single_attr_single_span_stack image_list =

141144 let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]

@@ -146,33 +149,51 @@ instance Arbitrary Image where

146149 arbitrary = oneof

147150 [ return EmptyImage

148151 , do

149− SingleAttrSingleSpanStack {stack_image} <- arbitrary

150− ImageResize f <- arbitrary

152+ SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary

153+ ImageResize f <- Verify.resize 2 arbitrary

151154 return $! fst $! f stack_image

152155 , do

153− SingleAttrSingleSpanStack {stack_image} <- arbitrary

154− ImageResize f <- arbitrary

156+ SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary

157+ ImageResize f <- Verify.resize 2 arbitrary

155158 return $! fst $! f stack_image

156159 , do

157160 i_0 <- arbitrary

158161 i_1 <- arbitrary

159162 let i = i_0 <|> i_1

160− ImageResize f <- arbitrary

163+ ImageResize f <- Verify.resize 2 arbitrary

161164 return $! fst $! f i

162165 , do

163166 i_0 <- arbitrary

164167 i_1 <- arbitrary

165168 let i = i_0 <-> i_1

166− ImageResize f <- arbitrary

169+ ImageResize f <- Verify.resize 2 arbitrary

167170 return $! fst $! f i

168171 ]

169− shrink (HorizJoin {part_left, part_right}) = shrink =<< [part_left, part_right]

170− shrink (VertJoin {part_top, part_bottom}) = shrink =<< [part_top, part_bottom]

171− shrink (CropRight {cropped_image}) = shrink =<< [cropped_image]

172− shrink (CropLeft {cropped_image}) = shrink =<< [cropped_image]

173− shrink (CropBottom {cropped_image}) = shrink =<< [cropped_image]

174− shrink (CropTop {cropped_image}) = shrink =<< [cropped_image]

175− shrink _ = []

172+ {-

173+ shrink i@(HorizJoin {part_left, part_right}) = do

174+ let !i_alt = background_fill (image_width i) (image_height i)

175+ !part_left' <- shrink part_left

176+ !part_right' <- shrink part_right

177+ [i_alt, part_left' <|> part_right']

178+ shrink i@(VertJoin {part_top, part_bottom}) = do

179+ let !i_alt = background_fill (image_width i) (image_height i)

180+ !part_top' <- shrink part_top

181+ !part_bottom' <- shrink part_bottom

182+ [i_alt, part_top' <-> part_bottom']

183+ shrink i@(CropRight {cropped_image, output_width}) = do

184+ let !i_alt = background_fill (image_width i) (image_height i)

185+ [i_alt, cropped_image]

186+ shrink i@(CropLeft {cropped_image, left_skip, output_width}) = do

187+ let !i_alt = background_fill (image_width i) (image_height i)

188+ [i_alt, cropped_image]

189+ shrink i@(CropBottom {cropped_image, output_height}) = do

190+ let !i_alt = background_fill (image_width i) (image_height i)

191+ [i_alt, cropped_image]

192+ shrink i@(CropTop {cropped_image, top_skip, output_height}) = do

193+ let !i_alt = background_fill (image_width i) (image_height i)

194+ [i_alt, cropped_image]

195+ shrink i = [empty_image, background_fill (image_width i) (image_height i)]

196+ -}

176197

177198data CropOperation

178199 = CropFromLeft

test/Verify/Graphics/Vty/Span.hs+9−9

@@ -9,6 +9,7 @@ import Graphics.Vty.Span

1010import Verify.Graphics.Vty.Picture

1111

12+import qualified Data.Vector as Vector

1213import Data.Word

1314

1415import Verify

@@ -18,13 +19,12 @@ is_attr_span_op AttributeChange {} = True

1819is_attr_span_op _ = False

1920

2021verify_all_spans_have_width i spans w

21− = case all_spans_have_width spans w of

22− True -> succeeded

23− False -> failed { reason = "Not all spans contained operations defining exactly "

24− ++ show w

25− ++ " columns of output -\n"

26− ++ show i

27− ++ "\n->\n"

28− ++ show spans

29− }

22+ = let v = map (\s -> (span_ops_effected_columns s /= w, s)) (Vector.toList spans)

23+ in case any ((== True) . fst) v of

24+ False -> succeeded

25+ True -> failed { reason = "Not all spans contained operations defining exactly "

26+ ++ show w

27+ ++ " columns of output - \n"

28+ ++ (concatMap ((++ "\n") . show)) v

29+ }

3030

test/VerifySpanOps.hs+88−44

@@ -17,96 +17,96 @@ import qualified Data.Vector as Vector

1717unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool

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

1919 let p = pic_for_image i

20− spans = spans_for_pic p (region_for_window w)

21− in span_ops_columns spans == 0 && span_ops_rows spans == 0

20+ ops = display_ops_for_pic p (region_for_window w)

21+ in display_ops_columns ops == 0 && display_ops_rows ops == 0

2222

2323unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool

2424unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) =

2525 let p = pic_for_image i

26− spans = spans_for_pic p (region_for_window w)

27− in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )

26+ ops = display_ops_for_pic p (region_for_window w)

27+ in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )

2828

2929horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

3030horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =

3131 let p = pic_for_image i

32− spans = spans_for_pic p (region_for_window w)

33− in span_ops_columns spans == 0 && span_ops_rows spans == 0

32+ ops = display_ops_for_pic p (region_for_window w)

33+ in display_ops_columns ops == 0 && display_ops_rows ops == 0

3434

3535horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

3636horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =

3737 let p = pic_for_image i

38− spans = spans_for_pic p (region_for_window w)

39− in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )

38+ ops = display_ops_for_pic p (region_for_window w)

39+ in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )

4040

4141horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result

4242horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

4343 let p = pic_for_image i

4444 w = MockWindow c 1

45− spans = spans_for_pic p (region_for_window w)

46− in verify_all_spans_have_width i spans c

45+ ops = display_ops_for_pic p (region_for_window w)

46+ in verify_all_spans_have_width i ops c

4747

4848horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool

4949horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

5050 let p = pic_for_image i

5151 w = MockWindow c 1

52− spans = spans_for_pic p (region_for_window w)

53− in span_ops_effected_rows spans == 1

52+ ops = display_ops_for_pic p (region_for_window w)

53+ in span_ops_effected_rows ops == 1

5454

5555horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result

5656horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

5757 let p = pic_for_image i

5858 lesser_width = c `div` 2

5959 w = MockWindow lesser_width 1

60− spans = spans_for_pic p (region_for_window w)

61− in verify_all_spans_have_width i spans lesser_width

60+ ops = display_ops_for_pic p (region_for_window w)

61+ in verify_all_spans_have_width i ops lesser_width

6262

6363single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result

6464single_attr_single_span_stack_cropped_0 stack =

6565 let p = pic_for_image (stack_image stack)

6666 w = MockWindow (stack_width stack `div` 2) (stack_height stack)

67− spans = spans_for_pic p (region_for_window w)

68− in verify_all_spans_have_width (stack_image stack) spans (stack_width stack `div` 2)

67+ ops = display_ops_for_pic p (region_for_window w)

68+ in verify_all_spans_have_width (stack_image stack) ops (stack_width stack `div` 2)

6969

7070single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool

7171single_attr_single_span_stack_cropped_1 stack =

7272 let p = pic_for_image (stack_image stack)

7373 expected_row_count = stack_height stack `div` 2

7474 w = MockWindow (stack_width stack) expected_row_count

75− spans = spans_for_pic p (region_for_window w)

76− actual_row_count = span_ops_effected_rows spans

75+ ops = display_ops_for_pic p (region_for_window w)

76+ actual_row_count = span_ops_effected_rows ops

7777 in expected_row_count == actual_row_count

7878

7979single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

8080single_attr_single_span_stack_cropped_2 stack_0 stack_1 =

8181 let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)

8282 w = MockWindow (stack_width stack_0) (image_height (pic_image p))

83− spans = spans_for_pic p (region_for_window w)

84− in verify_all_spans_have_width (pic_image p) spans (stack_width stack_0)

83+ ops = display_ops_for_pic p (region_for_window w)

84+ in verify_all_spans_have_width (pic_image p) ops (stack_width stack_0)

8585

8686single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

8787single_attr_single_span_stack_cropped_3 stack_0 stack_1 =

8888 let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)

8989 w = MockWindow (image_width (pic_image p)) expected_row_count

90− spans = spans_for_pic p (region_for_window w)

90+ ops = display_ops_for_pic p (region_for_window w)

9191 expected_row_count = image_height (pic_image p) `div` 2

92− actual_row_count = span_ops_effected_rows spans

92+ actual_row_count = span_ops_effected_rows ops

9393 in expected_row_count == actual_row_count

9494

9595single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

9696single_attr_single_span_stack_cropped_4 stack_0 stack_1 =

9797 let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)

9898 w = MockWindow expected_width (image_height (pic_image p))

99− spans = spans_for_pic p (region_for_window w)

99+ ops = display_ops_for_pic p (region_for_window w)

100100 expected_width = image_width (pic_image p) `div` 2

101− in verify_all_spans_have_width (pic_image p) spans expected_width

101+ in verify_all_spans_have_width (pic_image p) ops expected_width

102102

103103single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

104104single_attr_single_span_stack_cropped_5 stack_0 stack_1 =

105105 let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)

106106 w = MockWindow (image_width (pic_image p)) (stack_height stack_0)

107− spans = spans_for_pic p (region_for_window w)

107+ ops = display_ops_for_pic p (region_for_window w)

108108 expected_row_count = stack_height stack_0

109− actual_row_count = span_ops_effected_rows spans

109+ actual_row_count = span_ops_effected_rows ops

110110 in expected_row_count == actual_row_count

111111

112112horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result

@@ -115,46 +115,82 @@ horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i,

115115 -- SingleRowSingleAttrImage always has width >= 1

116116 greater_width = c * 2

117117 w = MockWindow greater_width 1

118− spans = spans_for_pic p (region_for_window w)

119− in verify_all_spans_have_width i spans greater_width

118+ ops = display_ops_for_pic p (region_for_window w)

119+ in verify_all_spans_have_width i ops greater_width

120120

121121arb_image_is_cropped :: DefaultImage -> MockWindow -> Bool

122122arb_image_is_cropped (DefaultImage image) win@(MockWindow w h) =

123123 let pic = pic_for_image image

124− spans = spans_for_pic pic (region_for_window win)

125− in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w )

124+ ops = display_ops_for_pic pic (region_for_window win)

125+ in ( span_ops_effected_rows ops == h ) && ( all_spans_have_width ops w )

126126

127127span_ops_actually_fill_rows :: DefaultPic -> Bool

128128span_ops_actually_fill_rows (DefaultPic pic win) =

129− let spans = spans_for_pic pic (region_for_window win)

129+ let ops = display_ops_for_pic pic (region_for_window win)

130130 expected_row_count = region_height (region_for_window win)

131− actual_row_count = span_ops_effected_rows spans

131+ actual_row_count = span_ops_effected_rows ops

132132 in expected_row_count == actual_row_count

133133

134134span_ops_actually_fill_columns :: DefaultPic -> Bool

135135span_ops_actually_fill_columns (DefaultPic pic win) =

136− let spans = spans_for_pic pic (region_for_window win)

136+ let ops = display_ops_for_pic pic (region_for_window win)

137137 expected_column_count = region_width (region_for_window win)

138− in all_spans_have_width spans expected_column_count

138+ in all_spans_have_width ops expected_column_count

139139

140140first_span_op_sets_attr :: DefaultPic -> Bool

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

142− let spans = spans_for_pic pic (region_for_window win)

143− in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans )

142+ let ops = display_ops_for_pic pic (region_for_window win)

143+ in all ( is_attr_span_op . Vector.head ) ( Vector.toList ops )

144144

145145single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result

146146single_attr_single_span_stack_op_coverage stack =

147147 let p = pic_for_image (stack_image stack)

148148 w = MockWindow (stack_width stack) (stack_height stack)

149− spans = spans_for_pic p (region_for_window w)

150− in verify_all_spans_have_width (stack_image stack) spans (stack_width stack)

149+ ops = display_ops_for_pic p (region_for_window w)

150+ in verify_all_spans_have_width (stack_image stack) ops (stack_width stack)

151+

152+crop_op_display_ops :: (Int -> Image -> Image) ->

153+ Int -> Image -> (DisplayOps, Image)

154+crop_op_display_ops crop_op v i =

155+ let i_out = crop_op v i

156+ p = pic_for_image i_out

157+ w = MockWindow (image_width i_out) (image_height i_out)

158+ in (display_ops_for_pic p (region_for_window w), i_out)

159+

160+width_crop_output_columns :: (Int -> Image -> Image) ->

161+ SingleAttrSingleSpanStack ->

162+ NonNegative Int ->

163+ Property

164+width_crop_output_columns crop_op s (NonNegative w) = stack_width s > w ==>

165+ let (ops, i_out) = crop_op_display_ops crop_op w (stack_image s)

166+ in verify_all_spans_have_width i_out ops w

167+

168+height_crop_output_columns :: (Int -> Image -> Image) ->

169+ SingleAttrSingleSpanStack ->

170+ NonNegative Int ->

171+ Property

172+height_crop_output_columns crop_op s (NonNegative h) = stack_height s > h ==>

173+ let (ops, _) = crop_op_display_ops crop_op h (stack_image s)

174+ in display_ops_rows ops == h

175+

176+crop_right_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

177+crop_right_output_columns = width_crop_output_columns crop_right

178+

179+crop_left_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

180+crop_left_output_columns = width_crop_output_columns crop_left

181+

182+crop_top_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

183+crop_top_output_rows = height_crop_output_columns crop_top

184+

185+crop_bottom_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

186+crop_bottom_output_rows = height_crop_output_columns crop_bottom

151187

152188image_coverage_matches_bounds :: Image -> Result

153189image_coverage_matches_bounds i =

154190 let p = pic_for_image i

155191 r = DisplayRegion (image_width i) (image_height i)

156− spans = spans_for_pic p r

157− in verify_all_spans_have_width i spans (image_width i)

192+ ops = display_ops_for_pic p r

193+ in verify_all_spans_have_width i ops (image_width i)

158194

159195tests :: IO [Test]

160196tests = return

@@ -176,14 +212,22 @@ tests = return

176212 single_attr_single_span_stack_cropped_0

177213 , verify "a single attr text span is cropped when window size < size of stack image [height]"

178214 single_attr_single_span_stack_cropped_1

179− , verify "single attr text span <|> single attr text span cropped. [width]"

215+ , verify "single attr text span <|> single attr text span display cropped. [width]"

180216 single_attr_single_span_stack_cropped_2

181− , verify "single attr text span <|> single attr text span cropped. [height]"

217+ , verify "single attr text span <|> single attr text span display cropped. [height]"

182218 single_attr_single_span_stack_cropped_3

183− , verify "single attr text span <-> single attr text span cropped. [width]"

219+ , verify "single attr text span <-> single attr text span display cropped. [width]"

184220 single_attr_single_span_stack_cropped_4

185− , verify "single attr text span <-> single attr text span cropped. [height]"

221+ , verify "single attr text span <-> single attr text span display cropped. [height]"

186222 single_attr_single_span_stack_cropped_5

223+ , verify "cropping from the bottom produces display operations covering the expected rows"

224+ crop_bottom_output_rows

225+ , verify "cropping from the top produces display operations covering the expected rows"

226+ crop_top_output_rows

227+ , verify "cropping from the left produces display operations covering the expected columns"

228+ crop_left_output_columns

229+ , verify "cropping from the right produces display operations covering the expected columns"

230+ crop_right_output_columns

187231 , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"

188232 image_coverage_matches_bounds

189233 ]

vty.cabal+1−1

@@ -102,7 +102,7 @@ test-suite verify-attribute-ops

102102 test-module: VerifyAttributeOps

103103 build-depends: vty,

104104 Cabal == 1.17.*,

105− QuickCheck >= 2.4,

105+ QuickCheck >= 2.6,

106106 random == 1.0.*,

107107 base >= 4 && < 5,

108108 bytestring,