1{-# LANGUAGE DisambiguateRecordFields #-} 2{-# LANGUAGE NamedFieldPuns #-} 3module VerifyCropSpanGeneration where 4 5import Verify.Graphics.Vty.Prelude 6 7import Verify.Graphics.Vty.Image 8import Verify.Graphics.Vty.Picture 9import Verify.Graphics.Vty.Span 10 11import Graphics.Vty.Debug 12import Graphics.Vty.PictureToSpans 13 14import Verify 15 16import qualified Data.Vector as Vector 17 18cropOpDisplayOps :: (Int -> Image -> Image) -> 19 Int -> Image -> (DisplayOps, Image) 20cropOpDisplayOps cropOp v i = 21 let iOut = cropOp v i 22 p = picForImage iOut 23 w = MockWindow (imageWidth iOut) (imageHeight iOut) 24 in (displayOpsForPic p (regionForWindow w), iOut) 25 26widthCropOutputColumns :: (Int -> Image -> Image) -> 27 SingleAttrSingleSpanStack -> 28 NonNegative Int -> 29 Property 30widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==> 31 let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s) 32 in verifyAllSpansHaveWidth iOut ops w 33 34heightCropOutputColumns :: (Int -> Image -> Image) -> 35 SingleAttrSingleSpanStack -> 36 NonNegative Int -> 37 Property 38heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==> 39 let (ops, _) = cropOpDisplayOps cropOp h (stackImage s) 40 in displayOpsRows ops == h 41 42cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property 43cropRightOutputColumns = widthCropOutputColumns cropRight 44 45cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property 46cropLeftOutputColumns = widthCropOutputColumns cropLeft 47 48cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property 49cropTopOutputRows = heightCropOutputColumns cropTop 50 51cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property 52cropBottomOutputRows = heightCropOutputColumns cropBottom 53 54-- TODO: known benign failure. 55cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property 56cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==> 57 let i = stackImage stack 58 -- the right part is made by cropping the image from the left. 59 iR = cropLeft (imageWidth i `div` 2) i 60 -- the left part is made by cropping the image from the right 61 iL = cropRight (imageWidth i `div` 2) i 62 iAlt = iL <|> iR 63 iOps = displayOpsForImage i 64 iAltOps = displayOpsForImage iAlt 65 in verifyOpsEquality iOps iAltOps 66 67cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property 68cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==> 69 let i = stackImage stack 70 -- the top part is made by cropping the image from the bottom. 71 iT = cropBottom (imageHeight i `div` 2) i 72 -- the bottom part is made by cropping the image from the top. 73 iB = cropTop (imageHeight i `div` 2) i 74 iAlt = iT <-> iB 75 in displayOpsForImage i == displayOpsForImage iAlt 76 77tests :: IO [Test] 78tests = return 79 [ verify "cropping from the bottom produces display operations covering the expected rows" 80 cropBottomOutputRows 81 , verify "cropping from the top produces display operations covering the expected rows" 82 cropTopOutputRows 83 , verify "cropping from the left produces display operations covering the expected columns" 84 cropLeftOutputColumns 85 , verify "cropping from the right produces display operations covering the expected columns" 86 cropRightOutputColumns 87 -- TODO: known benign failure. 88 -- , verify "the output of a stack is the same as that stack cropped left & right and joined together" 89 -- cropRightAndLeftRejoinedEquivalence 90 , verify "the output of a stack is the same as that stack cropped top & bottom and joined together" 91 cropTopAndBottomRejoinedEquivalence 92 ] 93