antigen 0.3.1.0 → 0.4.0.0

raw patch · 12 files changed

+688/−98 lines, 12 filesdep +containersdep +deepseqdep +filepathdep −mtldep ~QuickCheckdep ~freePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, deepseq, filepath, hspec-golden, text

Dependencies removed: mtl

Dependency ranges changed: QuickCheck, free

API changes (from Hackage documentation)

Files

• .golden/mixed_annotations.golden +3/−0
• .golden/multiple_zaps.golden +5/−0
• .golden/no_zaps.golden +1/−0
• .golden/single_zap_nested.golden +3/−0
• .golden/single_zap_no_annotation.golden +1/−0
• .golden/single_zap_simple.golden +3/−0
• CHANGELOG.md +12/−0
• antigen.cabal +15/−7
• bench/Main.hs +79/−10
• src/Test/AntiGen.hs +67/−9
• src/Test/AntiGen/Internal.hs +204/−61
• test/Main.hs +295/−11

@@ -0,0 +1,3 @@+Zapped 3 decision points+Annotations:+  - annotated

@@ -0,0 +1,5 @@+Zapped 3 decision points+Annotations:+  - user.name+  - user.email+  - address.street

@@ -0,0 +1,1 @@+Zapped 0 decision points

@@ -0,0 +1,3 @@+Zapped 1 decision points+Annotations:+  - root.child.leaf

@@ -0,0 +1,1 @@+Zapped 1 decision points

@@ -0,0 +1,3 @@+Zapped 1 decision points+Annotations:+  - positive

@@ -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`

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

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

@@ -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 ||!

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

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