diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for falsify +## 0.1.1 -- 2023-04-07 + +* Better verbose mode for test failures +* New predicates: `split` and `pairwise`. +* Shrink towards the _second_ half of the range in `withOrigin` + ## 0.1.0 -- 2023-04-05 * First release diff --git a/falsify.cabal b/falsify.cabal --- a/falsify.cabal +++ b/falsify.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: falsify -version: 0.1.0 +version: 0.1.1 synopsis: Property-based testing with internal integrated shrinking description: This library provides property based testing with support for internal integrated shrinking: integrated in the sense @@ -15,7 +15,7 @@ @@, and use "Test.Tasty.Falsify" as their main entrypoint into the library. The "Test.Falsify.Interactive" module - can be used to experiment with the libary in @ghci@. + can be used to experiment with the library in @ghci@. license: BSD-3-Clause license-file: LICENSE diff --git a/src/Test/Falsify/Internal/Driver.hs b/src/Test/Falsify/Internal/Driver.hs --- a/src/Test/Falsify/Internal/Driver.hs +++ b/src/Test/Falsify/Internal/Driver.hs @@ -373,13 +373,34 @@ where history = shrinkHistory (failureRun e) - (_, DontExpectFailure, Just e) -> RenderedTestResult { + (NotVerbose, DontExpectFailure, Just e) -> RenderedTestResult { testPassed = False , testOutput = unlines [ "failed after " ++ countHistory history , fst $ NE.last history , "Logs for failed test run:" , renderLog . runLog . snd $ NE.last history + , showSeed $ failureSeed e + ] + } + where + history = shrinkHistory (failureRun e) + + (Verbose, DontExpectFailure, Just e) -> RenderedTestResult { + testPassed = False + , testOutput = unlines [ + "failed after " ++ countHistory history + , fst $ NE.last history + , "" + , "Logs for complete shrink history:" + , "" + , intercalate "\n" $ [ + intercalate "\n" [ + "Step " ++ show (step :: Word) + , renderLog (runLog run) + ] + | (step, (_result, run)) <- zip [1..] (NE.toList history) + ] , showSeed $ failureSeed e ] } diff --git a/src/Test/Falsify/Predicate.hs b/src/Test/Falsify/Predicate.hs --- a/src/Test/Falsify/Predicate.hs +++ b/src/Test/Falsify/Predicate.hs @@ -24,6 +24,7 @@ , relatedBy -- * Combinators , dot + , split , on , flip , matchEither @@ -45,6 +46,7 @@ , even , odd , elem + , pairwise ) where import Prelude hiding (all, flip, even, odd, pred, elem) @@ -230,16 +232,16 @@ Both :: Predicate xs -> Predicate xs -> Predicate xs -- | Abstraction - Lam :: (x -> Predicate xs) -> Predicate (x ': xs) + Lam :: (Input x -> Predicate xs) -> Predicate (x ': xs) -- | Partial application At :: Predicate (x : xs) -> Input x -> Predicate xs -- | Function compostion - Dot :: Predicate (x : xs) -> Fn y x -> Predicate (y : xs) + Dot :: Predicate (x' : xs) -> Fn x x' -> Predicate (x : xs) - -- | Analogue of 'Prelude.on' - On :: Predicate (x : x : xs) -> Fn y x -> Predicate (y : y : xs) + -- | Analogue of 'Control.Arrow.(***)' + Split :: Predicate (x' : y' : xs) -> (Fn x x', Fn y y') -> Predicate (x : y : xs) -- | Analogue of 'Prelude.flip' Flip :: Predicate (x : y : zs) -> Predicate (y : x : zs) @@ -329,9 +331,16 @@ dot :: Predicate (x : xs) -> Fn y x -> Predicate (y : xs) dot = Dot +-- | Analogue of 'Control.Arrow.(***)' +split :: + Predicate (x' : y' : xs) + -> (Fn x x', Fn y y') + -> Predicate (x : y : xs) +split = Split + -- | Analogue of 'Prelude.on' on :: Predicate (x : x : xs) -> Fn y x -> Predicate (y : y : xs) -on = On +on p f = p `split` (f, f) -- | Analogue of 'Prelude.flip' flip :: Predicate (x : y : zs) -> Predicate (y : x : zs) @@ -411,12 +420,12 @@ evalLam :: SListI xs - => (x -> Predicate xs) + => (Input x -> Predicate xs) -> NP Input (x : xs) -> Either Failure () evalLam f (x :* xs) = first (addInputs [renderInput x]) $ - evalAt (f $ inputValue x) xs + evalAt (f x) xs evalDot :: SListI xs @@ -430,18 +439,18 @@ where (y, x') = applyFn f x -evalOn :: +evalSplit :: SListI xs - => Predicate (x : x : xs) - -> Fn y x - -> NP Input (y : y : xs) + => Predicate (x' : y' : xs) + -> (Fn x x', Fn y y') + -> NP Input (x : y : xs) -> Either Failure () -evalOn p f (x0 :* x1 :* xs) = - first (addInputs $ catMaybes [x0', x1']) $ - evalAt p (y0 :* y1 :* xs) +evalSplit p (f, g) (x :* y :* xs) = + first (addInputs $ catMaybes [inp_x, inp_y]) $ + evalAt p (x' :* y' :* xs) where - (y0, x0') = applyFn f x0 - (y1, x1') = applyFn f x1 + (x', inp_x) = applyFn f x + (y', inp_y) = applyFn g y evalChoice :: SListI xs @@ -456,17 +465,18 @@ Right b -> evalAt f (x{inputValue = b} :* xs) evalAt :: SListI xs => Predicate xs -> NP Input xs -> Either Failure () -evalAt (Prim p err) xs = evalPrim p err xs -evalAt Pass _ = return () -evalAt Fail xs = Left $ Failure "Fail" (renderInputs xs) -evalAt (Both p1 p2) xs = evalAt p1 xs >> evalAt p2 xs -evalAt (Lam f) xs = evalLam f xs -evalAt (p `At` x) xs = evalAt p (x :* xs) -evalAt (p `Dot` f) xs = evalDot p f xs -evalAt (p `On` f) xs = evalOn p f xs -evalAt (Flip p) xs = let (x :* y :* zs) = xs in evalAt p (y :* x :* zs) -evalAt (Choose l r) xs = evalChoice l r xs -evalAt (Const p) xs = evalAt p (SOP.tl xs) +evalAt (Prim p err) xs = evalPrim p err xs +evalAt Pass _ = return () +evalAt Fail xs = Left $ Failure "Fail" (renderInputs xs) +evalAt (Both p1 p2) xs = evalAt p1 xs >> evalAt p2 xs +evalAt (Lam f) xs = evalLam f xs +evalAt (p `At` x) xs = evalAt p (x :* xs) +evalAt (p `Dot` f) xs = evalDot p f xs +evalAt (p `Split` (f, g)) xs = evalSplit p (f, g) xs +evalAt (Flip p) xs = let (x :* y :* zs) = xs in + evalAt p (y :* x :* zs) +evalAt (Choose l r) xs = evalChoice l r xs +evalAt (Const p) xs = evalAt p (SOP.tl xs) {------------------------------------------------------------------------------- Evaluation and partial evaluation @@ -485,14 +495,14 @@ -- > .$ ("x", x) -- > .$ ("y", y) (.$) :: Show x => Predicate (x : xs) -> (Var, x) -> Predicate xs -p .$ (n, x) = p `at` (n, show x, x) +p .$ (n, x) = p `at` (Var n, show x, x) -- | Generation of '(.$)' that does not require a 'Show' instance at :: Predicate (x : xs) - -> (Var, String, x) -- ^ Renderded name, name for the input, and input proper + -> (Expr, String, x) -- ^ Renderded name, expression, and input proper -> Predicate xs -p `at` (n, r, x) = p `At` (Input (Var n) r x) +p `at` (e, r, x) = p `At` (Input e r x) {------------------------------------------------------------------------------- Specific predicates @@ -535,7 +545,8 @@ towards = \target -> pred .$ ("target", target) where pred :: Predicate [a, a, a] - pred = Lam (\target -> ge `on` fn ("distanceToTarget", distanceTo target)) + pred = Lam $ \target -> + ge `on` fn ("distanceToTarget", distanceTo (inputValue target)) distanceTo :: a -> a -> a distanceTo target x @@ -562,5 +573,24 @@ odd = satisfies ("odd ", Prelude.odd) -- | Membership check -elem :: Eq a => Predicate '[[a], a] +elem :: Eq a => Predicate [[a], a] elem = flip $ binaryInfix ("`notElem`") Prelude.elem + +-- | Apply predicate to every pair of consecutive elements in the list +pairwise :: forall a. Show a => Predicate [a, a] -> Predicate '[[a]] +pairwise p = Lam $ \xs -> + foldMap + (uncurry $ pred (inputExpr xs)) + (pairs $ zip [0..] (inputValue xs)) + where + pairs :: forall x. [x] -> [(x, x)] + pairs [] = [] + pairs [_] = [] + pairs (x : y : zs) = (x, y) : pairs (y : zs) + + pred :: Expr -> (Word, a) -> (Word, a) -> Predicate '[] + pred xs (i, x) (j, y) = + p + `at` (Infix "!!" xs (Var $ show i), show x, x) + `at` (Infix "!!" xs (Var $ show j), show y, y) + diff --git a/src/Test/Falsify/Range.hs b/src/Test/Falsify/Range.hs --- a/src/Test/Falsify/Range.hs +++ b/src/Test/Falsify/Range.hs @@ -58,6 +58,10 @@ between = skewedBy 0 -- | Selection within the given bounds, shrinking towards the specified origin +-- +-- All else being equal, prefers values in the /second/ half of the range +-- (in the common case of say @withOrigin (-100, 100) 0@, this means we prefer +-- positive values). withOrigin :: (Integral a, FiniteBits a) => (a, a) -> a -> Range a withOrigin (x, y) o | not originInBounds @@ -79,8 +83,8 @@ -- would be at the origin, we would only ever produce that one value. | otherwise = towards o [ - between (o, x) - , between (o, y) + between (o, y) + , between (o, x) ] where originInBounds :: Bool diff --git a/test/TestSuite/Prop/Generator/Compound.hs b/test/TestSuite/Prop/Generator/Compound.hs --- a/test/TestSuite/Prop/Generator/Compound.hs +++ b/test/TestSuite/Prop/Generator/Compound.hs @@ -105,7 +105,7 @@ -- due to binary search prop_list_towardsShorterEven_minimum :: Property () prop_list_towardsShorterEven_minimum = - testMinimum (P.elem .$ ("expected", [[6,4],[4,2]])) $ do + testMinimum (P.elem .$ ("expected", [[6,4],[8,6]])) $ do xs <- gen $ fmap (filter even) $ Gen.list (Range.between (10, 20)) $ Gen.int $ Range.withOrigin (0, 10) 5 @@ -177,14 +177,17 @@ prop_tree_towardsSmaller1 :: Property () prop_tree_towardsSmaller1 = - testMinimum (P.expect expected) $ do + testMinimum (P.satisfies ("expected", expected)) $ do t <- gen $ Gen.tree (Range.between (0, 100)) $ Gen.int $ Range.between (0, 1) -- "Every tree is height balanced" unless (Tree.isHeightBalanced t) $ testFailed t where - expected :: Tree Int - expected = Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf)) + expected :: Tree Int -> Bool + expected t = or [ + t == Branch 0 (Branch 0 Leaf (Branch 0 Leaf Leaf)) Leaf + , t == Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf)) + ] prop_tree_towardsSmaller2 :: Property () prop_tree_towardsSmaller2 =