From 6142fce8a2838bbe1abbe740be2656e883a6467d Mon Sep 17 00:00:00 2001 From: Sreenidhi Date: Thu, 20 Feb 2020 17:35:17 +0530 Subject: [PATCH 1/5] tripping with monad --- hedgehog/src/Hedgehog.hs | 3 ++- hedgehog/src/Hedgehog/Internal/Tripping.hs | 23 ++++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/hedgehog/src/Hedgehog.hs b/hedgehog/src/Hedgehog.hs index 5dd39dfe..737c88bf 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -106,6 +106,7 @@ module Hedgehog ( , (===) , (/==) , tripping + , trippingM , eval , evalM @@ -186,4 +187,4 @@ import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) import Hedgehog.Internal.State (executeSequential, executeParallel) import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) import Hedgehog.Internal.TH (discover, discoverPrefix) -import Hedgehog.Internal.Tripping (tripping) +import Hedgehog.Internal.Tripping (tripping, trippingM) diff --git a/hedgehog/src/Hedgehog/Internal/Tripping.hs b/hedgehog/src/Hedgehog/Internal/Tripping.hs index de90dbae..f6115ebc 100644 --- a/hedgehog/src/Hedgehog/Internal/Tripping.hs +++ b/hedgehog/src/Hedgehog/Internal/Tripping.hs @@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Tripping ( tripping + , trippingM ) where import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith) @@ -28,18 +29,24 @@ tripping :: -> (b -> f a) -> m () tripping x encode decode = + trippingM x (pure . encode) (pure . decode) + + +trippingM :: + (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) + => a + -> (a -> m b) + -> (b -> m (f a)) + -> m () +trippingM x encode decode = do let mx = pure x - i = - encode x - - my = - decode i - in - if mx == my then - success + i <- encode x + my <- decode i + if mx == my + then success else case valueDiff <$> mkValue mx <*> mkValue my of Nothing -> From 3dba58a67b571fbce3eb884458e528b6a16f7fdd Mon Sep 17 00:00:00 2001 From: Sreenidhi Date: Sat, 22 Feb 2020 15:18:10 +0530 Subject: [PATCH 2/5] doc for trippingM --- hedgehog/src/Hedgehog/Internal/Tripping.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/hedgehog/src/Hedgehog/Internal/Tripping.hs b/hedgehog/src/Hedgehog/Internal/Tripping.hs index f6115ebc..26ce4aa6 100644 --- a/hedgehog/src/Hedgehog/Internal/Tripping.hs +++ b/hedgehog/src/Hedgehog/Internal/Tripping.hs @@ -32,6 +32,7 @@ tripping x encode decode = trippingM x (pure . encode) (pure . decode) +-- | Similar to tripping, but with a monadic action. trippingM :: (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) => a From 20c4774163925c341ee689105f4ac7701cd578cf Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Mon, 23 May 2022 02:55:51 +0100 Subject: [PATCH 3/5] Don't drop actions depending on shrunk predecessors. (#453) Closes #448. Suppose we have an Action list A 1 -> Var 0 B (Var 0) -> ... Then when we shrink A, we would previously get the list A 0 -> Var 1 B (Var 0) -> ... And then we'd drop B from this list, because `Var 0` no longer exists. Now shrinking will give A 0 -> Var 0 B (Var 0) -> ... which is fine. This means we now generate Vars even for actions whose `Require` fails. --- hedgehog/src/Hedgehog/Internal/State.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/hedgehog/src/Hedgehog/Internal/State.hs b/hedgehog/src/Hedgehog/Internal/State.hs index 71c52822..23d56841 100644 --- a/hedgehog/src/Hedgehog/Internal/State.hs +++ b/hedgehog/src/Hedgehog/Internal/State.hs @@ -548,6 +548,12 @@ action commands = Command mgenInput exec callbacks <- Gen.element_ $ filter (\c -> commandGenOK c state0) commands + -- If we shrink the input, we still want to use the same output. Otherwise + -- any actions using this output as part of their input will be dropped. But + -- the existing output is still in the context, so `contextNewVar` will + -- create a new one. To avoid that, we generate the output before the input. + output <- contextNewVar + input <- case mgenInput state0 of Nothing -> @@ -559,8 +565,6 @@ action commands = pure Nothing else do - output <- contextNewVar - contextUpdate $ callbackUpdate callbacks state0 input (Var output) From 748a6e8c00d129842c738e368d78e09e733cc57d Mon Sep 17 00:00:00 2001 From: Sreenidhi Date: Thu, 20 Feb 2020 17:35:17 +0530 Subject: [PATCH 4/5] tripping with monad --- hedgehog/src/Hedgehog.hs | 3 ++- hedgehog/src/Hedgehog/Internal/Tripping.hs | 23 ++++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/hedgehog/src/Hedgehog.hs b/hedgehog/src/Hedgehog.hs index c4896fd4..61cb7f60 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -106,6 +106,7 @@ module Hedgehog ( , (===) , (/==) , tripping + , trippingM , eval , evalNF @@ -196,7 +197,7 @@ import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) import Hedgehog.Internal.State (executeSequential, executeParallel) import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) import Hedgehog.Internal.TH (discover, discoverPrefix) -import Hedgehog.Internal.Tripping (tripping) +import Hedgehog.Internal.Tripping (tripping, trippingM) -- $functors diff --git a/hedgehog/src/Hedgehog/Internal/Tripping.hs b/hedgehog/src/Hedgehog/Internal/Tripping.hs index 2dba5514..69acc140 100644 --- a/hedgehog/src/Hedgehog/Internal/Tripping.hs +++ b/hedgehog/src/Hedgehog/Internal/Tripping.hs @@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Tripping ( tripping + , trippingM ) where import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith) @@ -28,18 +29,24 @@ tripping :: -> (b -> f a) -> m () tripping x encode decode = + trippingM x (pure . encode) (pure . decode) + + +trippingM :: + (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) + => a + -> (a -> m b) + -> (b -> m (f a)) + -> m () +trippingM x encode decode = do let mx = pure x - i = - encode x - - my = - decode i - in - if mx == my then - success + i <- encode x + my <- decode i + if mx == my + then success else case valueDiff <$> mkValue mx <*> mkValue my of Nothing -> From 24d161221427b431b36190138ca4eec387ae80f7 Mon Sep 17 00:00:00 2001 From: Sreenidhi Date: Sat, 22 Feb 2020 15:18:10 +0530 Subject: [PATCH 5/5] doc for trippingM --- hedgehog/src/Hedgehog/Internal/Tripping.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/hedgehog/src/Hedgehog/Internal/Tripping.hs b/hedgehog/src/Hedgehog/Internal/Tripping.hs index 69acc140..f893d610 100644 --- a/hedgehog/src/Hedgehog/Internal/Tripping.hs +++ b/hedgehog/src/Hedgehog/Internal/Tripping.hs @@ -32,6 +32,7 @@ tripping x encode decode = trippingM x (pure . encode) (pure . decode) +-- | Similar to tripping, but with a monadic action. trippingM :: (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) => a