diff --git a/.golden/mixed_annotations.golden b/.golden/mixed_annotations.golden new file mode 100644 --- /dev/null +++ b/.golden/mixed_annotations.golden @@ -0,0 +1,3 @@ +Zapped 3 decision points +Annotations: + - annotated diff --git a/.golden/multiple_zaps.golden b/.golden/multiple_zaps.golden new file mode 100644 --- /dev/null +++ b/.golden/multiple_zaps.golden @@ -0,0 +1,5 @@ +Zapped 3 decision points +Annotations: + - user.name + - user.email + - address.street diff --git a/.golden/no_zaps.golden b/.golden/no_zaps.golden new file mode 100644 --- /dev/null +++ b/.golden/no_zaps.golden @@ -0,0 +1,1 @@ +Zapped 0 decision points diff --git a/.golden/single_zap_nested.golden b/.golden/single_zap_nested.golden new file mode 100644 --- /dev/null +++ b/.golden/single_zap_nested.golden @@ -0,0 +1,3 @@ +Zapped 1 decision points +Annotations: + - root.child.leaf diff --git a/.golden/single_zap_no_annotation.golden b/.golden/single_zap_no_annotation.golden new file mode 100644 --- /dev/null +++ b/.golden/single_zap_no_annotation.golden @@ -0,0 +1,1 @@ +Zapped 1 decision points diff --git a/.golden/single_zap_simple.golden b/.golden/single_zap_simple.golden new file mode 100644 --- /dev/null +++ b/.golden/single_zap_simple.golden @@ -0,0 +1,3 @@ +Zapped 1 decision points +Annotations: + - positive diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for antigen +## 0.4.0.0 + +* Add `antiSamePair` +* Add `faultyNumRange` +* Add hierarchical annotations with `withAnnotation` and `(#!)` +* Add `ZapResult` with annotation tracking +* Add `zapAntiGenResult` to get full zap metadata +* Add `prettyZapResult` for displaying zap results +* Add weighted decision points with `scaleWeight` and `reweigh` +* Add `replicateMNorm` for normalized list generation +* Remove `tryZapAntiGen` (use `zapAntiGenResult` instead) + ## 0.3.1.0 * Add `tryZapAntiGen` diff --git a/antigen.cabal b/antigen.cabal --- a/antigen.cabal +++ b/antigen.cabal @@ -1,11 +1,10 @@ cabal-version: 3.0 name: antigen -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Fault injection for QuickCheck description: AntiGen extends QuickCheck to allow injecting random faults into QuickCheck generators. - . It introduces the `AntiGen` monad, a drop-in replacement for `Gen` that allows developers to define negative generators alongside their standard positive generators. @@ -17,6 +16,7 @@ category: Testing build-type: Simple extra-doc-files: CHANGELOG.md, README.md +data-files: .golden/*.golden tested-with: GHC == 9.10.3 source-repository head @@ -24,19 +24,20 @@ location: https://github.com/input-output-hk/antigen common warnings - ghc-options: -Wall + ghc-options: -Wall -Wunused-packages library import: warnings exposed-modules: Test.AntiGen Test.AntiGen.Internal - build-depends: + build-depends: base >=4.18 && <5, - QuickCheck >= 2.15.0 && < 2.18, - free >= 5.2 && < 5.3, - mtl >= 2.3.1 && < 2.4, + containers >= 0.6 && < 0.9, + QuickCheck >= 2.14 && < 2.19, + free >= 5.1 && < 5.3, random >= 1.2 && < 1.4, + text >= 2.0 && < 2.2, quickcheck-transformer >= 0.3.1 && < 0.4, hs-source-dirs: src default-language: Haskell2010 @@ -47,12 +48,17 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + other-modules: Paths_antigen + autogen-modules: Paths_antigen build-depends: base, antigen, + filepath, hspec, + hspec-golden, QuickCheck, quickcheck-transformer, + text, benchmark bench import: warnings @@ -64,5 +70,7 @@ antigen, base, criterion, + deepseq, QuickCheck, quickcheck-transformer, + text, diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,9 +1,21 @@ {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where -import Criterion.Main (Benchmarkable, bench, defaultMain, nfIO) -import Test.AntiGen.Internal (AntiGen, evalPartial, evalToPartial, zapAt, (|!)) +import Control.DeepSeq (deepseq) +import Criterion.Main (Benchmarkable, bench, bgroup, defaultMain, nfIO) +import qualified Data.Text as T +import Test.AntiGen.Internal ( + AntiGen, + ZapResult (..), + evalPartial, + evalToPartial, + withAnnotation, + zapAt, + (|!), + ) import Test.QuickCheck (Arbitrary (..), generate) import Test.QuickCheck.GenT (MonadGen (..)) @@ -19,16 +31,73 @@ pure $ y : x : xs [] -> error "Got empty list" -bindListZap :: Int -> Int -> Benchmarkable -bindListZap len i = - nfIO . generate . variant (12345 :: Int) . fmap evalPartial $ - zapAt i =<< evalToPartial (bindList len) +-- Version with annotations on each decision point +bindListAnnotated :: Int -> AntiGen [Int] +bindListAnnotated 1 = (: []) <$> liftGen arbitrary +bindListAnnotated n + | n <= 0 = pure [] + | otherwise = do + rest <- bindListAnnotated (n - 1) + case rest of + x : xs -> do + y <- withAnnotation (T.pack (show n)) $ pure (succ x) |! pure (pred x) + pure $ y : x : xs + [] -> error "Got empty list" +-- Only force the value +bindListZapValue :: Int -> Int -> Benchmarkable +bindListZapValue len i = + nfIO . generate . variant (12345 :: Int) . fmap (evalPartial . zrValue) $ + zapAt (fromIntegral i) =<< evalToPartial (bindList len) + +-- Force value, annotation, and zapped count +bindListZapAll :: Int -> Int -> Benchmarkable +bindListZapAll len i = + nfIO . generate . variant (12345 :: Int) . fmap forceAll $ + zapAt (fromIntegral i) =<< evalToPartial (bindList len) + where + forceAll ZapResult {..} = + zrAnnotation `deepseq` (evalPartial zrValue, zrZapped) + +-- Annotated versions +annotatedZapValue :: Int -> Int -> Benchmarkable +annotatedZapValue len i = + nfIO . generate . variant (12345 :: Int) . fmap (evalPartial . zrValue) $ + zapAt (fromIntegral i) =<< evalToPartial (bindListAnnotated len) + +annotatedZapAll :: Int -> Int -> Benchmarkable +annotatedZapAll len i = + nfIO . generate . variant (12345 :: Int) . fmap forceAll $ + zapAt (fromIntegral i) =<< evalToPartial (bindListAnnotated len) + where + forceAll ZapResult {..} = + zrAnnotation `deepseq` (evalPartial zrValue, zrZapped) + main :: IO () main = defaultMain - [ bench "bindList 10_000 zap at 0" $ bindListZap 10_000 0 - , bench "bindList 10_000 zap at 9_000" $ bindListZap 10_000 9_000 - , bench "bindList 1_000_000 zap at 0" $ bindListZap 1_000_000 0 - , bench "bindList 1_000_000 zap at 900_000" $ bindListZap 1_000_000 900_000 + [ bgroup + "value only" + [ bench "10_000 zap at 0" $ bindListZapValue 10_000 0 + , bench "10_000 zap at 9_000" $ bindListZapValue 10_000 9_000 + , bench "1_000_000 zap at 0" $ bindListZapValue 1_000_000 0 + , bench "1_000_000 zap at 900_000" $ bindListZapValue 1_000_000 900_000 + ] + , bgroup + "force all" + [ bench "10_000 zap at 0" $ bindListZapAll 10_000 0 + , bench "10_000 zap at 9_000" $ bindListZapAll 10_000 9_000 + , bench "1_000_000 zap at 0" $ bindListZapAll 1_000_000 0 + , bench "1_000_000 zap at 900_000" $ bindListZapAll 1_000_000 900_000 + ] + , bgroup + "annotated value only" + [ bench "10_000 zap at 0" $ annotatedZapValue 10_000 0 + , bench "10_000 zap at 9_000" $ annotatedZapValue 10_000 9_000 + ] + , bgroup + "annotated force all" + [ bench "10_000 zap at 0" $ annotatedZapAll 10_000 0 + , bench "10_000 zap at 9_000" $ annotatedZapAll 10_000 9_000 + ] ] diff --git a/src/Test/AntiGen.hs b/src/Test/AntiGen.hs --- a/src/Test/AntiGen.hs +++ b/src/Test/AntiGen.hs @@ -11,14 +11,24 @@ module Test.AntiGen ( AntiGen, + ZapResult (..), (|!), + (#!), (||!), + withAnnotation, runAntiGen, zapAntiGen, - tryZapAntiGen, + zapAntiGenResult, + prettyZapResult, + scaleWeight, + reweigh, + -- * Normalized monad combinators + replicateMNorm, + -- * AntiGen combinators faultyNum, + faultyNumRange, faultyBool, faultyTry, faultyTryGen, @@ -30,12 +40,25 @@ antiNonNegative, antiJust, antiNonEmpty, + antiSamePair, antiDistinctPair, ) where -import Control.Monad (join) +import Control.Monad (join, replicateM) import System.Random (Random) -import Test.AntiGen.Internal +import Test.AntiGen.Internal ( + AntiGen, + ZapResult (..), + prettyZapResult, + reweigh, + runAntiGen, + scaleWeight, + withAnnotation, + zapAntiGen, + zapAntiGenResult, + (#!), + (|!), + ) import Test.QuickCheck ( Arbitrary (..), Negative (..), @@ -44,19 +67,25 @@ NonZero (..), Positive (..), ) -import Test.QuickCheck.GenT (MonadGen (..), elements, listOf1, oneof, suchThat) +import Test.QuickCheck.GenT (MonadGen (..), listOf1, oneof, suchThat) -- | Returns the provided number. +-- -- Negative: returns a value that is not equal to the provided number. faultyNum :: (Eq a, Num a, Arbitrary a) => a -> AntiGen a faultyNum n = pure n |! ((n +) . getNonZero <$> arbitrary) +faultyNumRange :: (Random a, Eq a) => a -> (a, a) -> AntiGen a +faultyNumRange n rng = pure n |! (choose rng `suchThat` (/= n)) + -- | Returns the provided `Bool`. +-- -- Negative: returns the negation of that `Bool`. faultyBool :: Bool -> AntiGen Bool faultyBool b = pure b |! pure (not b) -- | Generates a value from the first range. +-- -- Negative: Generates a value from the second range excluding the first range. antiChoose :: (Integral a, Random a) => (a, a) -> (a, a) -> AntiGen a antiChoose rng@(lo, hi) (boundLo, boundHi) @@ -70,12 +99,14 @@ rngHi = (succ hi, boundHi) -- | Generates a value from the range. +-- -- Negative: Returns a random value outside the range between `minBound` and -- `maxBound`. antiChooseBounded :: (Integral a, Random a, Bounded a) => (a, a) -> AntiGen a antiChooseBounded rng = antiChoose rng (minBound, maxBound) -- | Returns the provided value +-- -- Negative: Generates an arbitrary value that is different from the provided -- value. -- @@ -85,6 +116,7 @@ faultyTry a = faultyTryGen a $ liftGen arbitrary -- | Returns the provided value +-- -- Negative: Use the generator to generate a random value that is different -- from the provided value. -- @@ -94,46 +126,62 @@ faultyTryGen a gen = pure a ||! (gen `suchThat` (/= a)) -- | Returns a positive number +-- -- Negative: Returns a non-positive number antiPositive :: (Num a, Ord a, Arbitrary a) => AntiGen a antiPositive = (getPositive <$> arbitrary) |! (getNonPositive <$> arbitrary) -- | Returns a non-positive number +-- -- Negative: Returns a positive number antiNonPositive :: (Num a, Ord a, Arbitrary a) => AntiGen a antiNonPositive = (getNonPositive <$> arbitrary) |! (getPositive <$> arbitrary) -- | Returns a negative number +-- -- Negative: Returns a non-negative number antiNegative :: (Num a, Ord a, Arbitrary a) => AntiGen a antiNegative = (getNegative <$> arbitrary) |! (getNonNegative <$> arbitrary) -- | Returns a non-negative number +-- -- Negative: Returns a negative number antiNonNegative :: (Num a, Ord a, Arbitrary a) => AntiGen a antiNonNegative = (getNonNegative <$> arbitrary) |! (getNegative <$> arbitrary) -- | Returns `Just x` +-- -- Negative: Returns `Nothing` antiJust :: a -> AntiGen (Maybe a) antiJust x = pure (Just x) ||! pure Nothing -- | Returns a non-empty list +-- -- Negative: Generate an empty list antiNonEmpty :: AntiGen a -> AntiGen [a] antiNonEmpty x = listOf1 x ||! pure [] +-- | Generate a pair with equal values +-- +-- Negative: Generates a pair of distinct values +antiSamePair :: (Arbitrary a, Num a, Eq a) => AntiGen (a, a) +antiSamePair = + ((\x -> (x, x)) <$> arbitrary) + |! ( do + x <- arbitrary + NonZero s <- arbitrary + return (x, x + s) + ) + -- | Generates a pair (x, y) where x /= y. +-- -- Negative: Generates a pair (x, y) where x == y. antiDistinctPair :: (Num a, Arbitrary a, Eq a) => AntiGen (a, a) antiDistinctPair = ( do x <- arbitrary - -- Generate a non-zero offset to guarantee x /= y - s <- elements [-1, 1] - a <- arbitrary - let offset = if a == 0 then 1 else abs a - return (x, x + (s * offset)) + NonZero s <- arbitrary + return (x, x + s) ) |! ( do x <- arbitrary @@ -143,3 +191,13 @@ -- | Create an `AntiGen` from a positive and a negative `AntiGen` generator (||!) :: AntiGen a -> AntiGen a -> AntiGen a a ||! b = join $ pure a |! pure b + +-- | Like 'replicateM', but normalizes the weight of each element by @1\/n@. +-- +-- The total weight of the list becomes the average weight of its elements, +-- rather than the sum. This prevents longer lists from having a +-- disproportionately higher chance of being zapped. +replicateMNorm :: Int -> AntiGen a -> AntiGen [a] +replicateMNorm n = replicateM n . scaleWeight (/ fromIntegral n) + +infixl 6 ||! diff --git a/src/Test/AntiGen/Internal.hs b/src/Test/AntiGen/Internal.hs --- a/src/Test/AntiGen/Internal.hs +++ b/src/Test/AntiGen/Internal.hs @@ -1,71 +1,128 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Test.AntiGen.Internal ( AntiGen, + ZapResult (..), + prettyZapResult, (|!), + (#!), zapAntiGen, - tryZapAntiGen, + zapAntiGenResult, runAntiGen, evalToPartial, evalPartial, countDecisionPoints, zapAt, + withAnnotation, + scaleWeight, + reweigh, ) where import Control.Monad ((<=<)) import Control.Monad.Free.Church (F (..), MonadFree (..)) -import Control.Monad.Free.Class (wrapT) -import Control.Monad.State.Strict (MonadState (..), StateT (..), evalStateT, modify') -import Control.Monad.Trans (MonadTrans (..)) -import Test.QuickCheck (Gen, getSize) -import Test.QuickCheck.GenT (GenT (..), MonadGen (..), runGenT) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as T +#if MIN_VERSION_QuickCheck(2,18,0) +import System.Random (SplitGen (..)) +#else +import System.Random (RandomGen (split)) +#endif +import Test.QuickCheck (getSize) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.GenT (MonadGen (..)) +import Test.QuickCheck.Random (QCGen) +#if !MIN_VERSION_QuickCheck(2,18,0) +splitGen :: RandomGen g => g -> (g, g) +splitGen = split +#endif + data BiGen next where - BiGen :: Gen t -> Maybe (Gen t) -> (t -> next) -> BiGen next + BiGen :: Gen t -> Maybe (Gen t) -> Float -> (t -> next) -> BiGen next + Annotate :: Text -> AntiGen t -> (t -> next) -> BiGen next + Reweigh :: (Float -> Float) -> AntiGen t -> (t -> next) -> BiGen next instance Functor BiGen where - fmap f (BiGen p n c) = BiGen p n $ f . c + fmap f (BiGen p n w c) = BiGen p n w $ f . c + fmap f (Annotate ann inner c) = Annotate ann inner $ f . c + fmap f (Reweigh g inner c) = Reweigh g inner $ f . c newtype AntiGen a = AntiGen (F BiGen a) deriving (Functor, Applicative, Monad, MonadFree BiGen) mapGen :: (forall x. Gen x -> Gen x) -> AntiGen a -> AntiGen a -mapGen f (AntiGen (F m)) = m pure $ \(BiGen pos neg c) -> - wrap $ BiGen (f pos) (f <$> neg) c +mapGen f (AntiGen (F m)) = m pure $ \case + BiGen pos neg w c -> wrap $ BiGen (f pos) (f <$> neg) w c + Annotate ann inner c -> wrap $ Annotate ann (mapGen f inner) c + Reweigh g inner c -> wrap $ Reweigh g (mapGen f inner) c instance MonadGen AntiGen where - liftGen g = AntiGen $ F $ \p b -> b $ BiGen g Nothing p + liftGen g = AntiGen $ F $ \p b -> b $ BiGen g Nothing 1 p variant n = mapGen (variant n) - sized f = wrap $ BiGen (f <$> getSize) Nothing id + sized f = wrap $ BiGen (f <$> getSize) Nothing 1 id resize n m = mapGen (resize n) m choose = liftGen . choose +mkAntiGen :: Gen a -> Gen a -> AntiGen a +mkAntiGen active alt = + AntiGen $ F $ \p b -> b $ BiGen (p <$> active) (Just $ p <$> alt) 1 id + -- | Create a negatable generator by providing a positive and a negative -- generator (|!) :: Gen a -> Gen a -> AntiGen a -pos |! neg = AntiGen $ F $ \p b -> b $ BiGen pos (Just neg) p +(|!) = mkAntiGen +infixl 6 |! + +-- | Postfix annotation operator. Annotates an 'AntiGen' with a label that +-- will be included in 'ZapResult' when this generator is zapped. +-- +-- @ +-- myGen = positive |! negative #! "sign" +-- @ +(#!) :: AntiGen a -> Text -> AntiGen a +(#!) = flip withAnnotation + +infixl 5 #! + +-- | Wrap an AntiGen with an annotation +withAnnotation :: Text -> AntiGen a -> AntiGen a +withAnnotation ann inner = wrap $ Annotate ann inner pure + +scaleWeight :: (Float -> Float) -> AntiGen a -> AntiGen a +scaleWeight rw inner = wrap $ Reweigh rw inner pure + +reweigh :: Float -> AntiGen a -> AntiGen a +reweigh w = scaleWeight $ const w + data DecisionPoint next where DecisionPoint :: { dpValue :: t - , dpPositiveGen :: Gen t - , dpNegativeGen :: Maybe (Gen t) + , dpActiveGen :: Gen t + , dpAlternativeGen :: Maybe (Gen t) + , dpAnnotation :: Seq Text + , dpWeight :: Float , dpContinuation :: t -> next } -> DecisionPoint next instance Functor DecisionPoint where - fmap f (DecisionPoint v p n c) = DecisionPoint v p n $ f . c + fmap f (DecisionPoint v p n a w c) = DecisionPoint v p n a w $ f . c continue :: DecisionPoint next -> next continue DecisionPoint {..} = dpContinuation dpValue @@ -74,50 +131,140 @@ deriving (Functor, Applicative, Monad, MonadFree DecisionPoint) evalToPartial :: AntiGen a -> Gen (PartialGen a) -evalToPartial (AntiGen (F m)) = runGenT $ m pure $ \(BiGen pos mNeg c) -> do - value <- liftGen pos - wrapT $ DecisionPoint value pos mNeg c +evalToPartial (AntiGen (F m)) = MkGen $ \qcGen sz -> + m kp kf Seq.empty id qcGen sz + where + kp :: a -> Seq Text -> (Float -> Float) -> QCGen -> Int -> PartialGen a + kp x _ _ _ _ = pure x + kf :: + BiGen (Seq Text -> (Float -> Float) -> QCGen -> Int -> PartialGen a) -> + Seq Text -> + (Float -> Float) -> + QCGen -> + Int -> + PartialGen a + kf (BiGen activeGen altGen w cont) path rw qcGen sz = + let (qcGenValue, qcGenCont) = splitGen qcGen + value = unGen activeGen qcGenValue sz + in wrap $ + DecisionPoint + { dpValue = value + , dpActiveGen = activeGen + , dpAlternativeGen = altGen + , dpAnnotation = path + , dpWeight = rw w + , dpContinuation = \v -> cont v path rw qcGenCont sz + } + kf (Annotate ann (AntiGen (F inner)) cont) path rw qcGen sz = do + let (qcGenInner, qcGenCont) = splitGen qcGen + t <- inner kp kf (path :|> ann) rw qcGenInner sz + cont t path rw qcGenCont sz + kf (Reweigh g (AntiGen (F inner)) cont) path rw qcGen sz = do + let (qcGenInner, qcGenCont) = splitGen qcGen + t <- inner kp kf path (rw . g) qcGenInner sz + cont t path rw qcGenCont sz + countDecisionPoints :: PartialGen a -> Int countDecisionPoints (PartialGen (F m)) = m (const 0) $ \dp@DecisionPoint {..} -> - case dpNegativeGen of + case dpAlternativeGen of Just _ -> succ $ continue dp Nothing -> continue dp -zapAt :: Int -> PartialGen a -> Gen (PartialGen a) -zapAt cutoffDepth (PartialGen (F m)) = do - let - wrapGenState mm = StateT $ \s -> GenT $ \g sz -> - let eval (StateT x) = - let GenT f = x s - in f g sz - in wrap $ eval <$> mm - runGenT . (`evalStateT` cutoffDepth) . m pure $ \dp@DecisionPoint {..} -> - case dpNegativeGen of - Just neg -> do - d <- get - modify' pred - if d == 0 - then do - -- Negate the generator - value <- lift $ liftGen neg - wrapGenState $ DecisionPoint value neg Nothing dpContinuation - else wrapGenState dp - Nothing -> wrapGenState dp +totalWeight :: PartialGen a -> Float +totalWeight (PartialGen (F m)) = m (const 0) $ \dp@DecisionPoint {..} -> + case dpAlternativeGen of + Just _ -> continue dp + dpWeight + Nothing -> continue dp -zap :: PartialGen a -> Gen (PartialGen a) -zap p - | let maxDepth = countDecisionPoints p - , maxDepth > 0 = do - cutoffDepth <- choose (0, maxDepth - 1) - zapAt cutoffDepth p - | otherwise = pure p +data ZapResult a = ZapResult + { zrValue :: a + , zrAnnotation :: [NonEmpty Text] + , zrZapped :: Int + } + deriving (Functor) -zapNTimes :: Int -> PartialGen a -> Gen (PartialGen a) -zapNTimes n - | n <= 0 = pure - | otherwise = zapNTimes (n - 1) <=< zap +instance Semigroup (ZapResult a) where + ZapResult v a1 z1 <> ZapResult _ a2 z2 = + ZapResult v (a1 <> a2) (z1 + z2) +-- | Pretty print the annotation paths from a ZapResult +prettyZapResult :: ZapResult a -> Text +prettyZapResult ZapResult {..} = + T.unlines $ + [ "Zapped " <> T.pack (show zrZapped) <> " decision points" + ] + <> case zrAnnotation of + [] -> [] + anns -> "Annotations:" : map prettyPath anns + where + prettyPath :: NonEmpty Text -> Text + prettyPath path = " - " <> T.intercalate "." (NE.toList path) + +zapAt :: Float -> PartialGen a -> Gen (ZapResult (PartialGen a)) +zapAt cutoffWeight (PartialGen (F m)) = MkGen $ \qcGen sz -> + m kp (kf qcGen sz) $ Just cutoffWeight + where + kp :: a -> Maybe Float -> ZapResult (PartialGen a) + kp x _ = ZapResult (pure x) mempty 0 + + kf :: + QCGen -> + Int -> + DecisionPoint (Maybe Float -> ZapResult (PartialGen a)) -> + Maybe Float -> + ZapResult (PartialGen a) + kf qcGen sz DecisionPoint {..} mn = + case dpAlternativeGen of + Just altGen + | Just n <- mn + , n < dpWeight -> + ZapResult + { zrValue = + let newValue = unGen altGen qcGen sz + in wrap $ + DecisionPoint + { dpValue = newValue + , dpActiveGen = altGen + , dpAlternativeGen = Nothing + , dpContinuation = \v -> zrValue (dpContinuation v Nothing) + , .. + } + , zrAnnotation = toList (NE.nonEmpty (toList dpAnnotation)) + , zrZapped = 1 + } + _ -> + -- Preserve tree structure + let n' = case dpAlternativeGen of + Just _ -> (\x -> x - dpWeight) <$> mn + Nothing -> mn + restResult = dpContinuation dpValue n' + in ZapResult + { zrValue = + wrap $ + DecisionPoint + { dpContinuation = \v -> zrValue (dpContinuation v n') + , .. + } + , zrAnnotation = zrAnnotation restResult + , zrZapped = zrZapped restResult + } + +zap :: PartialGen a -> Gen (ZapResult (PartialGen a)) +zap p = + let w = totalWeight p + in if w == 0 + then pure $ ZapResult p [] 0 + else (`zapAt` p) =<< choose (0, w) + +zapNTimes :: Int -> PartialGen a -> Gen (ZapResult a) +zapNTimes n x + | n <= 0 = pure $ ZapResult (evalPartial x) [] 0 + | otherwise = do + zapResult <- zap x + rest <- zapNTimes (pred n) $ zrValue zapResult + pure $ rest <> fmap evalPartial zapResult + evalPartial :: PartialGen a -> a evalPartial (PartialGen (F m)) = m id continue @@ -127,16 +274,12 @@ -- the `AntiGen` is lower than `n`, then the number of negations will be less -- than `n`. zapAntiGen :: Int -> AntiGen a -> Gen a -zapAntiGen n = fmap evalPartial <$> zapNTimes n <=< evalToPartial +zapAntiGen n = fmap zrValue . zapAntiGenResult n -- | Create a negative generator from an `AntiGen` by introducing at most --- `n` mistakes. If there are no decision points, it will return `Nothing`. -tryZapAntiGen :: Int -> AntiGen a -> Gen (Maybe a) -tryZapAntiGen n ag = do - p <- evalToPartial ag - if countDecisionPoints p > 0 - then Just . evalPartial <$> zapNTimes n p - else pure Nothing +-- `n` mistakes. +zapAntiGenResult :: Int -> AntiGen a -> Gen (ZapResult a) +zapAntiGenResult n = zapNTimes n <=< evalToPartial -- | Create a positive generator from the provided `AntiGen`. runAntiGen :: AntiGen a -> Gen a diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -7,9 +8,15 @@ import Control.Monad (replicateM) import Data.Data (Proxy (..)) -import Data.Word (Word32, Word64) +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Text as T +import Data.Word (Word32, Word64, Word8) +import Paths_antigen (getDataDir) +import System.FilePath (()) import Test.AntiGen ( AntiGen, + antiChoose, antiChooseBounded, antiNegative, antiNonNegative, @@ -18,13 +25,23 @@ faultyBool, faultyNum, faultyTry, + replicateMNorm, runAntiGen, zapAntiGen, (|!), (||!), ) -import Test.AntiGen.Internal (countDecisionPoints, evalToPartial) -import Test.Hspec (Spec, describe, hspec, shouldBe, shouldSatisfy) +import Test.AntiGen.Internal ( + ZapResult (..), + countDecisionPoints, + evalToPartial, + prettyZapResult, + reweigh, + withAnnotation, + zapAntiGenResult, + ) +import Test.Hspec (Spec, describe, hspec, it, shouldBe, shouldSatisfy) +import Test.Hspec.Golden (Golden (..)) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ( Arbitrary (..), @@ -86,6 +103,70 @@ replicateM l $ pure True |! pure False ] +annotatedPositive :: AntiGen Int +annotatedPositive = + withAnnotation "must be positive" $ + (getPositive @Int <$> arbitrary) |! (getNonPositive <$> arbitrary) + +annotatedTuple :: AntiGen (Int, Int) +annotatedTuple = do + x <- + withAnnotation "first positive" $ (getPositive @Int <$> arbitrary) |! (getNonPositive <$> arbitrary) + y <- + withAnnotation "second positive" $ + (getPositive @Int <$> arbitrary) |! (getNonPositive <$> arbitrary) + pure (x, y) + +complexAnnotations :: AntiGen (Int, Int) +complexAnnotations = + withAnnotation "root" $ do + a <- withAnnotation "a" antiPositive + b <- withAnnotation "b" antiPositive + pure (a, b) + +-- | Annotated sum type - each branch has its own annotation +annotatedEither :: AntiGen (Either Int Int) +annotatedEither = + withAnnotation "either" $ + oneof + [ withAnnotation "left" $ Left <$> antiPositive + , withAnnotation "right" $ Right <$> antiNegative + ] + +-- | Three levels of nesting +deeplyNested :: AntiGen Int +deeplyNested = + withAnnotation "level1" $ + withAnnotation "level2" $ + withAnnotation "level3" $ + antiPositive + +-- | Mixed annotated and unannotated in sequence +mixedAnnotations :: AntiGen (Int, Int, Int) +mixedAnnotations = do + a <- withAnnotation "first" antiPositive + b <- antiPositive -- unannotated + c <- withAnnotation "third" antiPositive + pure (a, b, c) + +-- | Sibling scopes that don't inherit from each other +siblingScopes :: AntiGen (Int, Int) +siblingScopes = do + a <- withAnnotation "scopeA" antiPositive + b <- withAnnotation "scopeB" antiPositive + pure (a, b) + +-- | Annotation wrapping a pure value (no decision points inside) +annotatedPure :: AntiGen Int +annotatedPure = withAnnotation "pure" $ pure 42 + +-- | Annotation with decision point after the annotated section +annotationThenDecision :: AntiGen (Int, Int) +annotationThenDecision = do + a <- withAnnotation "annotated" antiPositive + b <- antiPositive -- should have empty annotation + pure (a, b) + noneOf :: [Bool] -> Property noneOf [] = property True noneOf (x : xs) = not x .&&. noneOf xs @@ -196,17 +277,17 @@ res <- zapAntiGen 1 $ faultyTry s pure $ res =/= s describe "antiPositive" $ do - prop "positive" . forAll (runAntiGen $ antiPositive @Int) $ (> 0) - prop "negative" . forAll (zapAntiGen 1 $ antiPositive @Int) $ (<= 0) + prop "positive" $ forAll (runAntiGen $ antiPositive @Int) (> 0) + prop "negative" $ forAll (zapAntiGen 1 $ antiPositive @Int) (<= 0) describe "antiNegative" $ do - prop "positive" . forAll (runAntiGen $ antiNegative @Int) $ (< 0) - prop "negative" . forAll (zapAntiGen 1 $ antiNegative @Int) $ (>= 0) + prop "positive" $ forAll (runAntiGen $ antiNegative @Int) (< 0) + prop "negative" $ forAll (zapAntiGen 1 $ antiNegative @Int) (>= 0) describe "antiNonPositive" $ do - prop "positive" . forAll (runAntiGen $ antiNonPositive @Int) $ (<= 0) - prop "negative" . forAll (zapAntiGen 1 $ antiNonPositive @Int) $ (> 0) + prop "positive" $ forAll (runAntiGen $ antiNonPositive @Int) (<= 0) + prop "negative" $ forAll (zapAntiGen 1 $ antiNonPositive @Int) (> 0) describe "antiNonNegative" $ do - prop "positive" . forAll (runAntiGen $ antiNonNegative @Int) $ (>= 0) - prop "negative" . forAll (zapAntiGen 1 $ antiNonNegative @Int) $ (< 0) + prop "positive" $ forAll (runAntiGen $ antiNonNegative @Int) (>= 0) + prop "negative" $ forAll (zapAntiGen 1 $ antiNonNegative @Int) (< 0) describe "(||!)" $ do prop "positive" $ do res <- runAntiGen $ listOf1 (antiPositive @Int) ||! pure [] @@ -220,11 +301,212 @@ [ ("null", null res) , ("nonpositive", length (filter (<= 0) res) == 1) ] + describe "antiChoose" $ do + prop "positive and negative" $ do + vals <- sort <$> replicateM 4 (arbitrary @Word8) + case vals of + [loB, lo, hi, hiB] -> do + let g = antiChoose @Word8 (lo, hi) (loB, hiB) + pos <- runAntiGen g + neg <- zapAntiGen 1 g + let + failMsg = + unlines + [ "loB = " <> show loB + , "hiB = " <> show hiB + , "lo = " <> show lo + , "hi = " <> show hi + , "pos = " <> show pos + , "neg = " <> show neg + ] + posGood = pos >= lo && pos <= hi + negGood = neg < lo || (neg >= hi && neg <= hiB) + trivial = lo == loB && hi == hiB + pure . counterexample failMsg $ + trivial .||. counterexample "pos failure" posGood .&&. counterexample "neg failure" negGood + _ -> error "Impossible happened" describe "chooseBoundedIntegral" $ do chooseBoundedIntegralTest @Word64 chooseBoundedIntegralTest @Word32 chooseBoundedIntegralTest @Int + describe "replicateMNorm" $ do + prop "behaves like replicateM when not zapped" . forAll (choose (0, 1000)) $ \n -> do + let gen = antiPositive @Int + fromNorm <- runAntiGen $ replicateMNorm n gen + fromReplicateM <- runAntiGen $ replicateM n gen + pure $ + counterexample ("replicateMNorm: " <> show fromNorm) $ + counterexample ("replicateM: " <> show fromReplicateM) $ + length fromNorm === length fromReplicateM + prop "produces correct length" . forAll (choose (0, 1000)) $ \n -> do + result <- runAntiGen $ replicateMNorm n (antiPositive @Int) + pure $ length result === n + prop "all elements satisfy the generator property when not zapped" $ do + n <- choose (0, 1000) + result <- runAntiGen $ replicateMNorm n (antiPositive @Int) + pure $ all (> 0) result + describe "reweigh" $ do + prop "zero weight generator is never zapped" $ do + let gen = do + x <- reweigh 0 $ pure "A" |! pure "a" + y <- pure "B" |! pure "b" + pure (x, y) + (x, y) <- zapAntiGen 1 gen + pure $ + counterexample ("x = " <> x <> ", y = " <> y) $ + x === "A" .&&. y === "b" +withAnnotationSpec :: Spec +withAnnotationSpec = + describe "withAnnotation" $ do + prop "behaves like (|!) for runAntiGen (active generator)" $ do + x <- runAntiGen annotatedPositive + pure $ x > 0 + prop "behaves like (|!) for zapAntiGen (alternative generator)" $ do + x <- zapAntiGen 1 annotatedPositive + pure $ x <= 0 + prop "annotation is captured in ZapResult when zapped" $ do + result <- zapAntiGenResult 1 annotatedPositive + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + zrAnnotation result === ["must be positive" :| []] + prop "no annotation in ZapResult when not zapped (n=0)" $ do + result <- zapAntiGenResult 0 annotatedPositive + pure $ zrAnnotation result === [] + prop "multiple annotations collected when zapping multiple points" $ do + result <- zapAntiGenResult 2 annotatedTuple + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + length (zrAnnotation result) === 2 + .&&. ("first positive" :| []) `elem` zrAnnotation result + .&&. ("second positive" :| []) `elem` zrAnnotation result + prop "single zap of composed annotated generator gets one annotation" $ do + result <- zapAntiGenResult 1 annotatedTuple + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + length (zrAnnotation result) === 1 + prop "non-annotated (|!) produces empty annotation list" $ do + result <- zapAntiGenResult 1 antiGenPositive + pure $ zrAnnotation result === [] + prop "nested withAnnotation produces hierarchical path" $ do + let nested = + withAnnotation "foo" $ + withAnnotation "bar" $ + (getPositive @Int <$> arbitrary) |! (getNonPositive <$> arbitrary) + result <- zapAntiGenResult 1 nested + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + zrAnnotation result === ["foo" :| ["bar"]] + prop "withAnnotation on unannotated produces single-element path" $ do + let annotated = withAnnotation "outer" $ (getPositive @Int <$> arbitrary) |! (getNonPositive <$> arbitrary) + result <- zapAntiGenResult 1 annotated + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + zrAnnotation result === ["outer" :| []] + prop "complexAnnotations: zapping both points shows hierarchical paths" $ do + result <- zapAntiGenResult 2 complexAnnotations + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + length (zrAnnotation result) === 2 + .&&. ("root" :| ["a"]) `elem` zrAnnotation result + .&&. ("root" :| ["b"]) `elem` zrAnnotation result + prop "annotatedEither: sum type branches have correct paths" $ do + result <- zapAntiGenResult 1 annotatedEither + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + (zrAnnotation result === ["either" :| ["left"]]) + .||. (zrAnnotation result === ["either" :| ["right"]]) + prop "deeplyNested: three-level path captured" $ do + result <- zapAntiGenResult 1 deeplyNested + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + zrAnnotation result === ["level1" :| ["level2", "level3"]] + prop "mixedAnnotations: only annotated points produce annotations" $ do + result <- zapAntiGenResult 3 mixedAnnotations + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + -- 3 decision points zapped, but only 2 have annotations + zrZapped result === 3 + .&&. length (zrAnnotation result) === 2 + .&&. ("first" :| []) `elem` zrAnnotation result + .&&. ("third" :| []) `elem` zrAnnotation result + prop "siblingScopes: siblings don't inherit from each other" $ do + result <- zapAntiGenResult 2 siblingScopes + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + length (zrAnnotation result) === 2 + .&&. ("scopeA" :| []) `elem` zrAnnotation result + .&&. ("scopeB" :| []) `elem` zrAnnotation result + prop "annotatedPure: no decision points means no annotations" $ do + result <- zapAntiGenResult 1 annotatedPure + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + zrAnnotation result === [] + .&&. zrZapped result === 0 + prop "annotationThenDecision: scope ends after annotated section" $ do + result <- zapAntiGenResult 2 annotationThenDecision + pure $ + counterexample ("annotations: " <> show (zrAnnotation result)) $ + -- 2 decision points zapped, but only 1 has an annotation + zrZapped result === 2 + .&&. length (zrAnnotation result) === 1 + .&&. ("annotated" :| []) `elem` zrAnnotation result + +-- | Golden test that doesn't create actual files +golden :: String -> String -> IO (Golden String) +golden name actual = do + dataDir <- getDataDir + pure $ + Golden + { output = actual + , encodePretty = id + , writeToFile = writeFile + , readFromFile = readFile + , goldenFile = dataDir ".golden" name ++ ".golden" + , actualFile = Nothing + , failFirstTime = False + } + +prettyZapResultSpec :: Spec +prettyZapResultSpec = + describe "prettyZapResult" $ do + it "no zaps" $ + golden "no_zaps" $ + T.unpack $ + prettyZapResult $ + ZapResult () [] 0 + it "single zap without annotation" $ + golden "single_zap_no_annotation" $ + T.unpack $ + prettyZapResult $ + ZapResult () [] 1 + it "single zap with simple annotation" $ + golden "single_zap_simple" $ + T.unpack $ + prettyZapResult $ + ZapResult () ["positive" :| []] 1 + it "single zap with nested annotation" $ + golden "single_zap_nested" $ + T.unpack $ + prettyZapResult $ + ZapResult () ["root" :| ["child", "leaf"]] 1 + it "multiple zaps with annotations" $ + golden "multiple_zaps" $ + T.unpack $ + prettyZapResult $ + ZapResult + () + [ "user" :| ["name"] + , "user" :| ["email"] + , "address" :| ["street"] + ] + 3 + it "zaps with mixed annotated and unannotated" $ + golden "mixed_annotations" $ + T.unpack $ + prettyZapResult $ + ZapResult () ["annotated" :| []] 3 + main :: IO () main = hspec $ do describe "AntiGen" $ do @@ -266,3 +548,5 @@ pure $ a : b pure $ x === [30, 31, 32] utilsSpec + withAnnotationSpec + prettyZapResultSpec