c998873 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

more tests on cropping, plus some suspect fixes

c998873Corey O'Connor13 years ago

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

compare with master

unifiedsplit

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

13import qualified Data.Vector as Vector

15row_ops_effected_columns :: DisplayOps -> [Int]

16−row_ops_effected_columns spans

16+row_ops_effected_columns ops

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

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

19all_spans_have_width :: DisplayOps -> Int -> Bool

20−all_spans_have_width spans expected

20+all_spans_have_width ops expected

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

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

23span_ops_effected_rows :: DisplayOps -> Int

24−span_ops_effected_rows (DisplayOps _ the_row_ops)

24+span_ops_effected_rows ops

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

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

27type SpanConstructLog = [SpanConstructEvent]

28data SpanConstructEvent = SpanSetAttr Attr

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

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

276 go EmptyImage = EmptyImage

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

278 | output_height <= h = i

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

279+ | otherwise = CropBottom cropped_image output_width h

280 go i

281 | h >= image_height i = i

282 | otherwise = CropBottom i (image_width i) h

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

292 go EmptyImage = EmptyImage

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

294 | output_width <= w = i

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

295+ | otherwise = CropRight cropped_image w output_height

296 go i

297 | w >= image_width i = i

298 | otherwise = CropRight i w (image_height i)

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

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

310 | output_width <= w = i

311 | otherwise =

312− let left_skip' = left_skip + w - output_width

312+ let left_skip' = left_skip + output_width - w

313 in CropLeft cropped_image left_skip' w output_height

314 go i

315 | image_width i <= w = i

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

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

328 | output_height <= h = i

329 | otherwise =

330− let top_skip' = top_skip + h - output_height

330+ let top_skip' = top_skip + output_height - h

331 in CropTop cropped_image top_skip' output_width h

332 go i

333 | image_height i <= h = i

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

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

125 ++ " (" ++ show cropped_image ++ ")"

126 show ( EmptyImage ) = "EmptyImage"

127

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+

128instance NFData Image where

157instance NFData Image where

129 rnf EmptyImage = ()

158 rnf EmptyImage = ()

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

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

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

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

5{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE NamedFieldPuns #-}

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

9+ -}

8module Graphics.Vty.PictureToSpans where

10module Graphics.Vty.PictureToSpans where

10import Graphics.Vty.DisplayRegion

12import Graphics.Vty.DisplayRegion

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

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

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

63-- specified region.

65-- specified region.

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

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

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

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

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

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

68--

75--

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

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

70-- region.

77-- region.

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

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

72−combined_spans_for_layers pic r

79+combined_ops_for_layers pic r

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

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

74 | otherwise = do

81 | otherwise = do

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

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

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

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

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

170start_image_build :: Image -> BlitM s ()

177start_image_build :: Image -> BlitM s ()

171start_image_build image = do

178start_image_build image = do

172− out_of_bounds <- is_out_of_bounds <$> get

179+ out_of_bounds <- is_out_of_bounds image <$> get

173 when (not out_of_bounds) $ add_maybe_clipped image

180 when (not out_of_bounds) $ add_maybe_clipped image

174

181

175−is_out_of_bounds :: BlitState -> Bool

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

176−is_out_of_bounds s

183+is_out_of_bounds i s

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

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

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

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

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

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

179− | otherwise = False

188+ | otherwise = False

180

189

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

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

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

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

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

183add_maybe_clipped EmptyImage = return ()

198add_maybe_clipped EmptyImage = return ()

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

213 y <- use row_offset

228 y <- use row_offset

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

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

215add_maybe_clipped CropRight {cropped_image, output_width} = do

230add_maybe_clipped CropRight {cropped_image, output_width} = do

231+ s <- use skip_columns

216 r <- use remaining_columns

232 r <- use remaining_columns

233+ let x = output_width - s

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

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

218 add_maybe_clipped cropped_image

235 add_maybe_clipped cropped_image

219add_maybe_clipped CropLeft {cropped_image, left_skip} = do

236add_maybe_clipped CropLeft {cropped_image, left_skip} = do

220 skip_columns += left_skip

237 skip_columns += left_skip

221 add_maybe_clipped cropped_image

238 add_maybe_clipped cropped_image

222add_maybe_clipped CropBottom {cropped_image, output_height} = do

239add_maybe_clipped CropBottom {cropped_image, output_height} = do

240+ s <- use skip_rows

223 r <- use remaining_rows

241 r <- use remaining_rows

242+ let x = output_height - s

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

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

225 add_maybe_clipped cropped_image

244 add_maybe_clipped cropped_image

226add_maybe_clipped CropTop {cropped_image, top_skip} = do

245add_maybe_clipped CropTop {cropped_image, top_skip} = do

227 skip_rows += top_skip

246 skip_rows += top_skip

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

238 -> BlitM s ()

257 -> BlitM s ()

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

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

240 state <- get

259 state <- get

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

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

242 case state^.skip of

261 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

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

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

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

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

246− r | r > i0_dim -> do

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

247 add_maybe_clipped i0

275 add_maybe_clipped i0

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

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

249 add_maybe_clipped i1

277 add_maybe_clipped i1

250− | otherwise -> add_maybe_clipped i0

251 | s >= i0_dim -> do

278 | s >= i0_dim -> do

252 put $ state & skip -~ i0_dim

279 put $ state & skip -~ i0_dim

253 add_maybe_clipped i1

280 add_maybe_clipped i1

254− | otherwise -> case i0_dim - s of

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

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

260

282

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

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

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

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

263-- display string value?

285-- display string value?

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

265clip_text :: DisplayText -> Int -> Int -> DisplayText

286clip_text :: DisplayText -> Int -> Int -> DisplayText

266clip_text txt left_skip right_clip =

287clip_text txt left_skip right_clip =

267 -- CPS would clarify this I think

288 -- CPS would clarify this I think

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

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

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

272 clip_for_char_width 0 _ n = (n, False)

293 clip_for_char_width 0 _ n = (n, False)

273 clip_for_char_width w t n

294 clip_for_char_width w t n

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

274 | w < cw = (n, True)

296 | w < cw = (n, True)

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

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

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

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

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

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

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

300snoc_op !op !row = do

322snoc_op !op !row = do

301 the_mrow_ops <- view mrow_ops

323 the_mrow_ops <- view mrow_ops

324+ the_region <- view region

302 lift $ lift $ do

325 lift $ lift $ do

303 ops <- MVector.read the_mrow_ops row

326 ops <- MVector.read the_mrow_ops row

304 let ops' = Vector.snoc ops op

327 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"

305 MVector.write the_mrow_ops row ops'

330 MVector.write the_mrow_ops row ops'

306

331

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

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

21import Graphics.Vty.Image

23import Data.Vector (Vector)

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

24+import qualified Data.Vector as Vector

26import qualified Data.ByteString as BS

27import qualified Data.Text as T

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

52-- color is changed.

53type SpanOps = Vector SpanOp

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.

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

61−type RowOps = Vector SpanOps

56+type DisplayOps = Vector SpanOps

62−

63−instance Show DisplayOps where

64− show (DisplayOps _ the_row_ops)

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

67instance Show SpanOp where

58instance Show SpanOp where

68 show (AttributeChange attr) = show attr

59 show (AttributeChange attr) = show attr

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

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

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

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

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

65+--

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

74−span_ops_columns :: DisplayOps -> Int

67+display_ops_columns :: DisplayOps -> Int

75−span_ops_columns ops = region_width $ effected_region ops

68+display_ops_columns ops

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

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

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

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

78−span_ops_rows :: DisplayOps -> Int

73+display_ops_rows :: DisplayOps -> Int

79−span_ops_rows ops = region_height $ effected_region ops

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)

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

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

82span_ops_effected_columns :: SpanOps -> Int

80span_ops_effected_columns :: SpanOps -> Int

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

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

140 as <- readIORef (assumed_state_ref $ context_device dc)

141 let manip_cursor = supports_cursor_visibility (context_device dc)

142 let !r = context_region dc

143− !ops = spans_for_pic pic r

143+ !ops = display_ops_for_pic pic r

144 !initial_attr = FixedAttr default_style_mask Nothing Nothing

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

146 -- basis.

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

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

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

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

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

151+ then replicate (display_ops_rows ops) True

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

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

153− (Vector.toList $ display_ops ops)

153+ (Vector.toList ops)

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

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

156 + default_attr_required_bytes dc

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

187

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

189required_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

191 in n

192 where

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

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

199 = error "shouldn't be possible"

200

201span_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 =

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

204 let header_required_bytes = move_cursor_required_bytes dc 0 y

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

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

229serialize_output_ops dc start_ptr in_fattr diffs ops = do

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

231 ( 0, start_ptr, in_fattr, diffs )

232− ( display_ops ops )

232+ ops

233 return end_ptr

234 where

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

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

295 }

296

297cursor_column_offset :: DisplayOps -> Int -> Int -> Int

298−cursor_column_offset span_ops cx cy =

298+cursor_column_offset ops cx cy =

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

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

300 (out_offset, _, _)

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

302 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

35 liftIO $ flushed_put set_default_char_set

36 release_terminal t

37 , 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

39 return $ dc { inline_hack = xterm_inline_hack t' }

40 }

41 return t'

test/Verify.hs+6−3

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

58 , run = do

59 qc_result <- quickCheckResult p

60 case qc_result of

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

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

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

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

63+ $ TS.Fail $ "After "

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

65+ ++ show reason

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

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

64 , tags = []

67 , tags = []

65 , options = []

68 , options = []

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

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

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

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

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE DisambiguateRecordFields #-}

3{-# LANGUAGE DisambiguateRecordFields #-}

3module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image

4module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image

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

49instance Arbitrary WidthResize where

50instance Arbitrary WidthResize where

50 arbitrary = do

51 arbitrary = do

51 WidthResize f <- arbitrary

52 WidthResize f <- arbitrary

52− w <- choose (1,1024)

53+ w <- choose (1,64)

53 oneof $ map (return . WidthResize)

54 oneof $ map (return . WidthResize)

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

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

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

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

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

62instance Arbitrary HeightResize where

63instance Arbitrary HeightResize where

63 arbitrary = do

64 arbitrary = do

64 HeightResize f <- arbitrary

65 HeightResize f <- arbitrary

65− h <- choose (1,1024)

66+ h <- choose (1,64)

66 oneof $ map (return . HeightResize)

67 oneof $ map (return . HeightResize)

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

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

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

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

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

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

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

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

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

104 -- must be 1

105 -- must be 1

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

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

106 a <- arbitrary

107 a <- arbitrary

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

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

108 out_width = length single_column_row_text

109 out_width = length single_column_row_text

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

131

132

132instance Arbitrary SingleAttrSingleSpanStack where

133instance Arbitrary SingleAttrSingleSpanStack where

133 arbitrary = do

134 arbitrary = do

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

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

135 return $ mk_single_attr_single_span_stack image_list

136 return $ mk_single_attr_single_span_stack image_list

136 shrink s = do

137 shrink s = do

137 image_list <- shrink $ stack_source_images s

138 image_list <- shrink $ stack_source_images s

139+ if null image_list

140+ then []

138− return $ mk_single_attr_single_span_stack image_list

141+ else return $ mk_single_attr_single_span_stack image_list

139

142

140mk_single_attr_single_span_stack image_list =

143mk_single_attr_single_span_stack image_list =

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

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

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

146 arbitrary = oneof

149 arbitrary = oneof

147 [ return EmptyImage

150 [ return EmptyImage

148 , do

151 , do

149− SingleAttrSingleSpanStack {stack_image} <- arbitrary

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

150− ImageResize f <- arbitrary

153+ ImageResize f <- Verify.resize 2 arbitrary

151 return $! fst $! f stack_image

154 return $! fst $! f stack_image

152 , do

155 , do

153− SingleAttrSingleSpanStack {stack_image} <- arbitrary

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

154− ImageResize f <- arbitrary

157+ ImageResize f <- Verify.resize 2 arbitrary

155 return $! fst $! f stack_image

158 return $! fst $! f stack_image

156 , do

159 , do

157 i_0 <- arbitrary

160 i_0 <- arbitrary

158 i_1 <- arbitrary

161 i_1 <- arbitrary

159 let i = i_0 <|> i_1

162 let i = i_0 <|> i_1

160− ImageResize f <- arbitrary

163+ ImageResize f <- Verify.resize 2 arbitrary

161 return $! fst $! f i

164 return $! fst $! f i

162 , do

165 , do

163 i_0 <- arbitrary

166 i_0 <- arbitrary

164 i_1 <- arbitrary

167 i_1 <- arbitrary

165 let i = i_0 <-> i_1

168 let i = i_0 <-> i_1

166− ImageResize f <- arbitrary

169+ ImageResize f <- Verify.resize 2 arbitrary

167 return $! fst $! f i

170 return $! fst $! f i

168 ]

171 ]

172+ {-

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

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

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

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

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

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]

172− shrink (CropLeft {cropped_image}) = shrink =<< [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]

173− shrink (CropBottom {cropped_image}) = shrink =<< [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]

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

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

175− shrink _ = []

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

176

197

177data CropOperation

198data CropOperation

178 = CropFromLeft

199 = CropFromLeft

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

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

10import Verify.Graphics.Vty.Picture

12+import qualified Data.Vector as Vector

12import Data.Word

13import Data.Word

14import Verify

15import Verify

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

18is_attr_span_op _ = False

19is_attr_span_op _ = False

20verify_all_spans_have_width i spans w

21verify_all_spans_have_width i spans w

21− = case all_spans_have_width spans w of

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

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

22− True -> succeeded

24+ False -> succeeded

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

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

24− ++ show w

26+ ++ show w

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

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

26− ++ show i

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

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

28− ++ show spans

29− }

29+ }

test/VerifySpanOps.hs+88−44

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

17unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool

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

19 let p = pic_for_image i

20− spans = spans_for_pic p (region_for_window w)

20+ ops = display_ops_for_pic p (region_for_window w)

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

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

23unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool

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

25 let p = pic_for_image i

26− spans = spans_for_pic p (region_for_window w)

26+ ops = display_ops_for_pic p (region_for_window w)

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

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

29horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

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

31 let p = pic_for_image i

32− spans = spans_for_pic p (region_for_window w)

32+ ops = display_ops_for_pic p (region_for_window w)

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

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

35horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

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

37 let p = pic_for_image i

38− spans = spans_for_pic p (region_for_window w)

38+ ops = display_ops_for_pic p (region_for_window w)

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

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

41horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result

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

43 let p = pic_for_image i

44 w = MockWindow c 1

45− spans = spans_for_pic p (region_for_window w)

45+ ops = display_ops_for_pic p (region_for_window w)

46− in verify_all_spans_have_width i spans c

46+ in verify_all_spans_have_width i ops c

48horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool

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

50 let p = pic_for_image i

51 w = MockWindow c 1

52− spans = spans_for_pic p (region_for_window w)

52+ ops = display_ops_for_pic p (region_for_window w)

53− in span_ops_effected_rows spans == 1

53+ in span_ops_effected_rows ops == 1

55horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result

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

57 let p = pic_for_image i

58 lesser_width = c `div` 2

59 w = MockWindow lesser_width 1

60− spans = spans_for_pic p (region_for_window w)

60+ ops = display_ops_for_pic p (region_for_window w)

61− in verify_all_spans_have_width i spans lesser_width

61+ in verify_all_spans_have_width i ops lesser_width

63single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result

64single_attr_single_span_stack_cropped_0 stack =

65 let p = pic_for_image (stack_image stack)

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

67− spans = spans_for_pic p (region_for_window w)

67+ ops = display_ops_for_pic p (region_for_window w)

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

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

70single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool

71single_attr_single_span_stack_cropped_1 stack =

72 let p = pic_for_image (stack_image stack)

73 expected_row_count = stack_height stack `div` 2

74 w = MockWindow (stack_width stack) expected_row_count

75− spans = spans_for_pic p (region_for_window w)

75+ ops = display_ops_for_pic p (region_for_window w)

76− actual_row_count = span_ops_effected_rows spans

76+ actual_row_count = span_ops_effected_rows ops

77 in expected_row_count == actual_row_count

79single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

80single_attr_single_span_stack_cropped_2 stack_0 stack_1 =

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

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

83− spans = spans_for_pic p (region_for_window w)

83+ ops = display_ops_for_pic p (region_for_window w)

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

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

86single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

87single_attr_single_span_stack_cropped_3 stack_0 stack_1 =

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

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

91 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

93 in expected_row_count == actual_row_count

95single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

96single_attr_single_span_stack_cropped_4 stack_0 stack_1 =

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

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

100 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

102

103single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

104single_attr_single_span_stack_cropped_5 stack_0 stack_1 =

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

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

108 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

110 in expected_row_count == actual_row_count

111

112horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result

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

115 -- SingleRowSingleAttrImage always has width >= 1

116 greater_width = c * 2

117 w = MockWindow greater_width 1

118− spans = spans_for_pic p (region_for_window w)

118+ ops = display_ops_for_pic p (region_for_window w)

119− in verify_all_spans_have_width i spans greater_width

119+ in verify_all_spans_have_width i ops greater_width

120

121arb_image_is_cropped :: DefaultImage -> MockWindow -> Bool

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

123 let pic = pic_for_image image

124− spans = spans_for_pic pic (region_for_window win)

124+ ops = display_ops_for_pic pic (region_for_window win)

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

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

126

127span_ops_actually_fill_rows :: DefaultPic -> Bool

128span_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)

130 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

132 in expected_row_count == actual_row_count

133

134span_ops_actually_fill_columns :: DefaultPic -> Bool

135span_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)

137 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

139

140first_span_op_sets_attr :: DefaultPic -> Bool

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

142− let spans = spans_for_pic pic (region_for_window win)

142+ let ops = display_ops_for_pic pic (region_for_window win)

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

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

144

145single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result

146single_attr_single_span_stack_op_coverage stack =

147 let p = pic_for_image (stack_image stack)

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

149− spans = spans_for_pic p (region_for_window w)

149+ ops = display_ops_for_pic p (region_for_window w)

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

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

151

187

152image_coverage_matches_bounds :: Image -> Result

188image_coverage_matches_bounds :: Image -> Result

153image_coverage_matches_bounds i =

189image_coverage_matches_bounds i =

154 let p = pic_for_image i

190 let p = pic_for_image i

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

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

156− spans = spans_for_pic p r

192+ ops = display_ops_for_pic p r

157− in verify_all_spans_have_width i spans (image_width i)

193+ in verify_all_spans_have_width i ops (image_width i)

158

194

159tests :: IO [Test]

195tests :: IO [Test]

160tests = return

196tests = return

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

176 single_attr_single_span_stack_cropped_0

212 single_attr_single_span_stack_cropped_0

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

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

178 single_attr_single_span_stack_cropped_1

214 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]"

180 single_attr_single_span_stack_cropped_2

216 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]"

182 single_attr_single_span_stack_cropped_3

218 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]"

184 single_attr_single_span_stack_cropped_4

220 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]"

186 single_attr_single_span_stack_cropped_5

222 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

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

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

188 image_coverage_matches_bounds

232 image_coverage_matches_bounds

189 ]

233 ]

vty.cabal+1−1

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

102 test-module: VerifyAttributeOps

103 build-depends: vty,

104 Cabal == 1.17.*,

105− QuickCheck >= 2.4,

105+ QuickCheck >= 2.6,

106 random == 1.0.*,

107 base >= 4 && < 5,

108 bytestring,