From 0e011aed87a39327a15576784c7a070cb7a1af99 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Tue, 3 May 2022 16:46:25 +0100 Subject: [PATCH 1/5] Use state to update a Command's input. This allows you to write commands whose input changes when a previous Command shrinks. For example, suppose the state contains `someList :: [Bool]` and you have a command whose input expects "index into `someList` pointing at `True`". You can generate that index directly, but if an earlier command shrinks, `someList` might change and your index now points at `False`. (This is contrived, but hopefully points at the sorts of more complicated situations where it might be useful.) With this you can instead generate a number between 0 and (the number of `True` elements). Then use `mkInput` to turn that number into an index into `someList`. This will still be valid as long as the number of `True` elements doesn't shrink below the generated value. You could also pass this number directly into `exec`. But then in `exec` you'd need to get `someList` directly from the concrete model, which might be complicated and/or slow. I implemented this by adding a new `Command` constructor, `CommandA` where A is for Advanced. I don't love this. I could have simply changed the existing constructor, but that means every existing Command needs to be updated. (It's a simple change, `commandMkInput = const Just` means they work as before, but still a massive pain.) The downside of this approach is implementation complexity, plus any user functions taking a `Command` as input may need to be updated. Other approaches we could take here: 1. We could pass the concrete state into `exec` along with the concrete input. Then you wouldn't need to get `someList` from the model. But you might still need to do complicated calculations in `exec` which could make the failure output hard to follow. If we did this we'd have the same tradeoff between changing the existing constructor and adding a new one. 2. We could add a callback ```haskell MapMaybeInput (state Symbolic -> input Symbolic -> Maybe (input Symbolic) ``` Each of these would be applied in turn to update the input. (`Require` would be equivalent to a `MapMaybeInput` that ignores state, and either returns the input unchanged or `Nothing`.) This would be compatible with existing commands, but functions accepting a `Command` or a `Callback` as input might still need changing. --- hedgehog/hedgehog.cabal | 1 + hedgehog/src/Hedgehog/Internal/State.hs | 155 +++++++++++++++++------- hedgehog/test/Test/Hedgehog/State.hs | 95 +++++++++++++++ hedgehog/test/test.hs | 2 + 4 files changed, 209 insertions(+), 44 deletions(-) create mode 100644 hedgehog/test/Test/Hedgehog/State.hs diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index fdc8a67f..a20dc62d 100644 --- a/hedgehog/hedgehog.cabal +++ b/hedgehog/hedgehog.cabal @@ -138,6 +138,7 @@ test-suite test Test.Hedgehog.Maybe Test.Hedgehog.Seed Test.Hedgehog.Skip + Test.Hedgehog.State Test.Hedgehog.Text Test.Hedgehog.Zip diff --git a/hedgehog/src/Hedgehog/Internal/State.hs b/hedgehog/src/Hedgehog/Internal/State.hs index 1114592e..1521b863 100644 --- a/hedgehog/src/Hedgehog/Internal/State.hs +++ b/hedgehog/src/Hedgehog/Internal/State.hs @@ -43,7 +43,7 @@ module Hedgehog.Internal.State ( , Parallel(..) , takeVariables , variablesOK - , dropInvalid + , rethreadState , action , sequential , parallel @@ -380,6 +380,7 @@ callbackEnsure callbacks s0 s i o = -- your 'Command' list to 'sequential' or 'parallel'. -- data Command gen m (state :: (Type -> Type) -> Type) = + -- | A "simple" command. forall input output. (TraversableB input, Show (input Symbolic), Show output, Typeable output) => Command { @@ -402,22 +403,64 @@ data Command gen m (state :: (Type -> Type) -> Type) = [Callback input output state] } + | + -- | An "advanced" command. + forall input0 input output. + (TraversableB input, Show (input Symbolic), Show output, Typeable output) => + CommandA { + -- | A generator which provides random arguments for a command. If the + -- command cannot be executed in the current state, it should return + -- 'Nothing'. + -- + commandAGen :: + state Symbolic -> Maybe (gen input0) + + -- | Turns the randomly generated argument into the command's input by + -- examining the state. This allows the input to depend on previous steps, + -- in a way that gets preserved during shrinking. If this returns + -- 'Nothing', then the generated argument is invalid on the current state, + -- and the action will be dropped as with 'Require'. + -- + , commandAMkInput :: + state Symbolic -> input0 -> Maybe (input Symbolic) + + -- | Executes a command using the arguments generated by 'commandAGen' and + -- 'commandAMkInput'. + -- + , commandAExecute :: + input Concrete -> m output + + -- | A set of callbacks which provide optional command configuration such + -- as pre-condtions, post-conditions and state updates. + -- + , commandACallbacks :: + [Callback input output state] + } + -- | Checks that input for a command can be executed in the given state. -- commandGenOK :: Command gen m state -> state Symbolic -> Bool commandGenOK (Command inputGen _ _) state = Maybe.isJust (inputGen state) +commandGenOK (CommandA inputGen _ _ _) state = + Maybe.isJust (inputGen state) -- | An instantiation of a 'Command' which can be executed, and its effect -- evaluated. -- data Action m (state :: (Type -> Type) -> Type) = - forall input output. + forall input0 input output. (TraversableB input, Show (input Symbolic), Show output) => Action { - actionInput :: + actionInput0 :: + input0 + + , actionInput :: input Symbolic + , actionRefreshInput :: + state Symbolic -> input0 -> Maybe (input Symbolic) + , actionOutput :: Symbolic output @@ -435,7 +478,7 @@ data Action m (state :: (Type -> Type) -> Type) = } instance Show (Action m state) where - showsPrec p (Action input (Symbolic (Name output)) _ _ _ _) = + showsPrec p (Action _ input _ (Symbolic (Name output)) _ _ _ _) = showParen (p > 10) $ showString "Var " . showsPrec 11 output . @@ -512,26 +555,28 @@ contextNewVar = do put $ Context state (insertSymbolic var vars) pure var --- | Drops invalid actions from the sequence. +-- | Pass the state through the actions, updating inputs and dropping invalid +-- ones. -- -dropInvalid :: [Action m state] -> State (Context state) [Action m state] -dropInvalid = +rethreadState :: [Action m state] -> State (Context state) [Action m state] +rethreadState = let - loop step@(Action input output _execute require update _ensure) = do + loop (Action input0 _ refreshInput output exec require update ensure) = do Context state0 vars0 <- get - if require state0 input && variablesOK input vars0 then do - let - state = - update state0 input (Var output) + case refreshInput state0 input0 of + Just input | require state0 input && variablesOK input vars0 -> do + let + state = + update state0 input (Var output) - vars = - insertSymbolic output vars0 + vars = + insertSymbolic output vars0 - put $ Context state vars - pure $ Just step - else - pure Nothing + put $ Context state vars + pure $ Just $ Action input0 input refreshInput output exec require update ensure + _ -> + pure Nothing in fmap Maybe.catMaybes . traverse loop @@ -545,34 +590,56 @@ action commands = Gen.justT $ do Context state0 _ <- get - Command mgenInput exec callbacks <- + cmd <- 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 -> - error "genCommand: internal error, tried to use generator with invalid state." - Just gen -> - hoist lift $ Gen.toGenT gen - - if not $ callbackRequire callbacks state0 input then - pure Nothing - - else do - contextUpdate $ - callbackUpdate callbacks state0 input (Var output) - pure . Just $ - Action input output exec - (callbackRequire callbacks) - (callbackUpdate callbacks) - (callbackEnsure callbacks) + case cmd of + Command mgenInput exec callbacks -> do + output <- contextNewVar + input <- + case mgenInput state0 of + Nothing -> + error "genCommand: internal error, tried to use generator with invalid state." + Just gen -> + hoist lift $ Gen.toGenT gen + + if not $ callbackRequire callbacks state0 input then + pure Nothing + else do + contextUpdate $ + callbackUpdate callbacks state0 input (Var output) + + pure . Just $ + Action input input (const Just) output exec + (callbackRequire callbacks) + (callbackUpdate callbacks) + (callbackEnsure callbacks) + CommandA mgenInput mkInput exec callbacks -> do + output <- contextNewVar + input0 <- + case mgenInput state0 of + Nothing -> + error "genCommand: internal error, tried to use generator with invalid state." + Just gen -> + hoist lift $ Gen.toGenT gen + + case mkInput state0 input0 of + Just input | callbackRequire callbacks state0 input -> do + contextUpdate $ + callbackUpdate callbacks state0 input (Var output) + + pure . Just $ + Action input0 input mkInput output exec + (callbackRequire callbacks) + (callbackUpdate callbacks) + (callbackEnsure callbacks) + _ -> + pure Nothing genActions :: (MonadGen gen, MonadTest m) @@ -583,7 +650,7 @@ genActions :: genActions range commands ctx = do xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands) pure $ - dropInvalid xs `runState` ctx + rethreadState xs `runState` ctx -- | A sequence of actions to execute. -- @@ -594,7 +661,7 @@ newtype Sequential m state = } renderAction :: Action m state -> [String] -renderAction (Action input (Symbolic (Name output)) _ _ _ _) = +renderAction (Action _ input _ (Symbolic (Name output)) _ _ _ _) = let prefix0 = "Var " ++ show output ++ " = " @@ -610,7 +677,7 @@ renderAction (Action input (Symbolic (Name output)) _ _ _ _) = fmap (prefix ++) xs renderActionResult :: Environment -> Action m state -> [String] -renderActionResult env (Action _ output@(Symbolic (Name name)) _ _ _ _) = +renderActionResult env (Action _ _ _ output@(Symbolic (Name name)) _ _ _ _) = let prefix0 = "Var " ++ show name ++ " = " @@ -709,7 +776,7 @@ data ActionCheck state = } execute :: (MonadTest m, HasCallStack) => Action m state -> StateT Environment m (ActionCheck state) -execute (Action sinput soutput exec _require update ensure) = +execute (Action _ sinput _ soutput exec _require update ensure) = withFrozenCallStack $ do env0 <- get input <- evalEither $ reify env0 sinput @@ -736,7 +803,7 @@ executeUpdateEnsure :: => (state Concrete, Environment) -> Action m state -> m (state Concrete, Environment) -executeUpdateEnsure (state0, env0) (Action sinput soutput exec _require update ensure) = +executeUpdateEnsure (state0, env0) (Action _ sinput _ soutput exec _require update ensure) = withFrozenCallStack $ do input <- evalEither $ reify env0 sinput output <- exec input diff --git a/hedgehog/test/Test/Hedgehog/State.hs b/hedgehog/test/Test/Hedgehog/State.hs new file mode 100644 index 00000000..60a0ec56 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/State.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Test.Hedgehog.State where + +import Control.Applicative (Const(..)) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import qualified Data.IORef as IORef +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Internal.Config as Config +import qualified Hedgehog.Internal.Property as Property +import qualified Hedgehog.Internal.Runner as Runner +import qualified Hedgehog.Range as Range + +-- | Test that 'commandAMkInput' works as expected when shrinking. +-- +-- We create a state machine that always generates two actions. Initially, one +-- will have the number 5 as input and put it in state. The other will have +-- (True, 5) as input. It checks the number is less than 5. Since it's not, we +-- start shrinking. +-- +-- We shrink the first action initially, through 4,3,2,1,0. Each of these +-- changes the input to the second action, even though we're not shrinking that, +-- because `commandMkInput` looks at the state. The second action passes with +-- each of these. +-- +-- So then we shrink the second action, to (False, 5). That fails again, so we +-- go back to shrinking the first one. All of those shrinks pass again. +-- +-- We log the list of inputs to the second action, and after running this state +-- machine (and ignoring its result) we check that this list is correct. +-- +-- This depends on the order shrinks are performed in state machines. Hopefully +-- it won't be too fragile. +prop_mkInput :: Property +prop_mkInput = + withTests 1 . property $ do + actionListsRef <- liftIO $ IORef.newIORef [] + let + prop = property $ do + actions <- forAll $ Gen.sequential + (Range.linear 2 2) + (Const Nothing) + [ let + commandGen = \case + Const Nothing -> + Just $ Const <$> Gen.shrink (\n -> reverse [0..n-1]) + (pure (5 :: Int)) + Const (Just _) -> Nothing + commandExecute _ = pure () + commandCallbacks = + [Update $ \_ (Const input) _ -> Const $ Just input] + in + Command { .. } + , let + commandAGen = \case + Const Nothing -> + Nothing + Const (Just _) -> + Just $ Gen.shrink (\b -> if b then [False] else []) + (pure True) + commandAMkInput (Const st) inputB = case st of + Nothing -> + Nothing + Just stateN -> + Just $ Const (stateN, inputB) + commandAExecute (Const (stateN, inputB)) = liftIO $ do + IORef.modifyIORef' actionListsRef ((stateN, inputB) :) + commandACallbacks = + [Ensure $ \_ _ (Const (stateN, _)) _ -> diff stateN (<) 5] + in + CommandA { .. } + ] + executeSequential (Const Nothing) actions + + -- We could simply use `check` here, but that prints its output to the test + -- logs. + seed <- Config.resolveSeed Nothing + void $ liftIO $ Runner.checkReport (Property.propertyConfig prop) + 0 + seed + (Property.propertyTest prop) + (const $ pure ()) + + actionLists <- liftIO $ reverse <$> IORef.readIORef actionListsRef + actionLists === ((, True) <$> [5,4..0]) ++ ((, False) <$> [5,4..0]) + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index 43ee3bff..f9ed19fd 100644 --- a/hedgehog/test/test.hs +++ b/hedgehog/test/test.hs @@ -6,6 +6,7 @@ import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Maybe import qualified Test.Hedgehog.Seed import qualified Test.Hedgehog.Skip +import qualified Test.Hedgehog.State import qualified Test.Hedgehog.Text import qualified Test.Hedgehog.Zip @@ -19,6 +20,7 @@ main = , Test.Hedgehog.Maybe.tests , Test.Hedgehog.Seed.tests , Test.Hedgehog.Skip.tests + , Test.Hedgehog.State.tests , Test.Hedgehog.Text.tests , Test.Hedgehog.Zip.tests ] From 485cbb50d5d9df8929dffd3fcc8833cd8b452165 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Fri, 13 May 2022 08:58:51 +0100 Subject: [PATCH 2/5] Simplify `Action`. We don't need `actionInput0`, because it was only used to pass to `actionRefreshInput`. So we can just hide it in a closure. --- hedgehog/src/Hedgehog/Internal/State.hs | 29 +++++++++++-------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/hedgehog/src/Hedgehog/Internal/State.hs b/hedgehog/src/Hedgehog/Internal/State.hs index 1521b863..176b8f82 100644 --- a/hedgehog/src/Hedgehog/Internal/State.hs +++ b/hedgehog/src/Hedgehog/Internal/State.hs @@ -449,17 +449,14 @@ commandGenOK (CommandA inputGen _ _ _) state = -- evaluated. -- data Action m (state :: (Type -> Type) -> Type) = - forall input0 input output. + forall input output. (TraversableB input, Show (input Symbolic), Show output) => Action { - actionInput0 :: - input0 - - , actionInput :: + actionInput :: input Symbolic , actionRefreshInput :: - state Symbolic -> input0 -> Maybe (input Symbolic) + state Symbolic -> Maybe (input Symbolic) , actionOutput :: Symbolic output @@ -478,7 +475,7 @@ data Action m (state :: (Type -> Type) -> Type) = } instance Show (Action m state) where - showsPrec p (Action _ input _ (Symbolic (Name output)) _ _ _ _) = + showsPrec p (Action input _ (Symbolic (Name output)) _ _ _ _) = showParen (p > 10) $ showString "Var " . showsPrec 11 output . @@ -561,10 +558,10 @@ contextNewVar = do rethreadState :: [Action m state] -> State (Context state) [Action m state] rethreadState = let - loop (Action input0 _ refreshInput output exec require update ensure) = do + loop (Action _ refreshInput output exec require update ensure) = do Context state0 vars0 <- get - case refreshInput state0 input0 of + case refreshInput state0 of Just input | require state0 input && variablesOK input vars0 -> do let state = @@ -574,7 +571,7 @@ rethreadState = insertSymbolic output vars0 put $ Context state vars - pure $ Just $ Action input0 input refreshInput output exec require update ensure + pure $ Just $ Action input refreshInput output exec require update ensure _ -> pure Nothing in @@ -615,7 +612,7 @@ action commands = callbackUpdate callbacks state0 input (Var output) pure . Just $ - Action input input (const Just) output exec + Action input (const $ Just input) output exec (callbackRequire callbacks) (callbackUpdate callbacks) (callbackEnsure callbacks) @@ -634,7 +631,7 @@ action commands = callbackUpdate callbacks state0 input (Var output) pure . Just $ - Action input0 input mkInput output exec + Action input (flip mkInput input0) output exec (callbackRequire callbacks) (callbackUpdate callbacks) (callbackEnsure callbacks) @@ -661,7 +658,7 @@ newtype Sequential m state = } renderAction :: Action m state -> [String] -renderAction (Action _ input _ (Symbolic (Name output)) _ _ _ _) = +renderAction (Action input _ (Symbolic (Name output)) _ _ _ _) = let prefix0 = "Var " ++ show output ++ " = " @@ -677,7 +674,7 @@ renderAction (Action _ input _ (Symbolic (Name output)) _ _ _ _) = fmap (prefix ++) xs renderActionResult :: Environment -> Action m state -> [String] -renderActionResult env (Action _ _ _ output@(Symbolic (Name name)) _ _ _ _) = +renderActionResult env (Action _ _ output@(Symbolic (Name name)) _ _ _ _) = let prefix0 = "Var " ++ show name ++ " = " @@ -776,7 +773,7 @@ data ActionCheck state = } execute :: (MonadTest m, HasCallStack) => Action m state -> StateT Environment m (ActionCheck state) -execute (Action _ sinput _ soutput exec _require update ensure) = +execute (Action sinput _ soutput exec _require update ensure) = withFrozenCallStack $ do env0 <- get input <- evalEither $ reify env0 sinput @@ -803,7 +800,7 @@ executeUpdateEnsure :: => (state Concrete, Environment) -> Action m state -> m (state Concrete, Environment) -executeUpdateEnsure (state0, env0) (Action _ sinput _ soutput exec _require update ensure) = +executeUpdateEnsure (state0, env0) (Action sinput _ soutput exec _require update ensure) = withFrozenCallStack $ do input <- evalEither $ reify env0 sinput output <- exec input From ce7a7c9c289e845b514c5900bdc7f00610b0647d Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Wed, 25 Jan 2023 18:13:26 +0000 Subject: [PATCH 3/5] Remove `recheck`. It's not useful with `recheckAt`, and makes fast growth more awkward to implement. This might break compatibility more than upstream wants, but at this point I've mostly given up on getting things merged there. If they do want fast growth we can figure out something. --- hedgehog/src/Hedgehog.hs | 3 +-- hedgehog/src/Hedgehog/Internal/Runner.hs | 13 ++----------- 2 files changed, 3 insertions(+), 13 deletions(-) diff --git a/hedgehog/src/Hedgehog.hs b/hedgehog/src/Hedgehog.hs index 989e797b..33354437 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -59,7 +59,6 @@ module Hedgehog ( , discard , check - , recheck , recheckAt , discover @@ -194,7 +193,7 @@ import Hedgehog.Internal.Property (Test, TestT, property, test) import Hedgehog.Internal.Property (TestLimit, withTests) import Hedgehog.Internal.Property (collect, label) import Hedgehog.Internal.Range (Range, Size(..)) -import Hedgehog.Internal.Runner (check, recheck, recheckAt, checkSequential, checkParallel) +import Hedgehog.Internal.Runner (check, recheckAt, checkSequential, checkParallel) import Hedgehog.Internal.Seed (Seed(..)) import Hedgehog.Internal.State (Command(..), Callback(..)) import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index c4b883c3..eacb5268 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -12,7 +12,6 @@ module Hedgehog.Internal.Runner ( -- * Running Individual Properties check - , recheck , recheckAt -- * Running Groups of Properties @@ -41,7 +40,7 @@ import Hedgehog.Internal.Property (Group(..), GroupName(..)) import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) -import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip) +import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) import Hedgehog.Internal.Property (TerminationCriteria(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) @@ -425,16 +424,8 @@ check prop = do liftIO . displayRegion $ \region -> (== OK) . reportStatus <$> checkNamed region color Nothing Nothing prop --- | Check a property using a specific size and seed. +-- | Check a property using a specific seed and skip. -- -recheck :: MonadIO m => Size -> Seed -> Property -> m () -recheck size seed prop0 = do - color <- detectColor - let prop = withTests 1 prop0 - _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing size seed prop - pure () - recheckAt :: MonadIO m => Seed -> Skip -> Property -> m () recheckAt seed skip prop0 = do color <- detectColor From 3d2e125e07921e38f9f8a3c22886bf36644bbc7f Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Thu, 26 Jan 2023 12:54:37 +0000 Subject: [PATCH 4/5] Grow sizes faster when we run a small number of tests. Closes #472. We now grow test size in fixed increments from 0 to 99, or as close as we can without going over, in however many tests we run. If we run more than n * 100 tests, then we go from 0 to 99 n times, and then do fixed increments for the remainder. Additionally, if we discard a bunch of times in a row we start to grow the size. --- hedgehog/hedgehog.cabal | 1 + hedgehog/src/Hedgehog/Internal/Runner.hs | 93 +++++++++++++++++++----- hedgehog/test/Test/Hedgehog/Size.hs | 86 ++++++++++++++++++++++ hedgehog/test/Test/Hedgehog/Skip.hs | 6 +- hedgehog/test/Test/Hedgehog/State.hs | 1 - hedgehog/test/test.hs | 2 + 6 files changed, 165 insertions(+), 24 deletions(-) create mode 100644 hedgehog/test/Test/Hedgehog/Size.hs diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index a20dc62d..53144b52 100644 --- a/hedgehog/hedgehog.cabal +++ b/hedgehog/hedgehog.cabal @@ -137,6 +137,7 @@ test-suite test Test.Hedgehog.Filter Test.Hedgehog.Maybe Test.Hedgehog.Seed + Test.Hedgehog.Size Test.Hedgehog.Skip Test.Hedgehog.State Test.Hedgehog.Text diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index eacb5268..398e9481 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -41,7 +41,7 @@ import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCou import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) -import Hedgehog.Internal.Property (TerminationCriteria(..)) +import Hedgehog.Internal.Property (TerminationCriteria(..), TestLimit(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) @@ -52,7 +52,7 @@ import Hedgehog.Internal.Region import Hedgehog.Internal.Report import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) -import Hedgehog.Range (Size) +import Hedgehog.Range (Size(..)) import Language.Haskell.TH.Syntax (Lift) @@ -206,12 +206,11 @@ checkReport :: MonadIO m => MonadCatch m => PropertyConfig - -> Size -> Seed -> PropertyT m () -> (Report Progress -> m ()) -> m (Report Result) -checkReport cfg size0 seed0 test0 updateUI = do +checkReport cfg seed0 test0 updateUI = do skip <- liftIO $ resolveSkip $ propertySkip cfg let @@ -254,14 +253,17 @@ checkReport cfg size0 seed0 test0 updateUI = do loop :: TestCount -> DiscardCount - -> Size + -> DiscardCount -> Seed -> Coverage CoverCount -> m (Report Result) - loop !tests !discards !size !seed !coverage0 = do + loop !tests !discards !recentDiscards !seed !coverage0 = do updateUI $ Report tests discards coverage0 seed0 Running let + size = + calculateSize terminationCriteria tests recentDiscards + coverageReached = successVerified tests coverage0 @@ -301,11 +303,7 @@ checkReport cfg size0 seed0 test0 updateUI = do failureReport $ "Test coverage cannot be reached after " <> show tests <> " tests" - if size > 99 then - -- size has reached limit, reset to 0 - loop tests discards 0 seed coverage0 - - else if enoughTestsRun then + if enoughTestsRun then -- at this point, we know that enough tests have been run in order to -- make a decision on if this was a successful run or not -- @@ -335,7 +333,7 @@ checkReport cfg size0 seed0 test0 updateUI = do -- failed was 31, but we want the user to be able to skip to 32 and -- start with the one that failed. (Just n, _) | n > tests + 1 -> - loop (tests + 1) discards (size + 1) s1 coverage0 + loop (tests + 1) discards recentDiscards s1 coverage0 (Just _, Just shrinkPath) -> do node <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test @@ -348,7 +346,7 @@ checkReport cfg size0 seed0 test0 updateUI = do runTreeT . evalGenT size s0 . runTestT $ unPropertyT test case x of Nothing -> - loop tests (discards + 1) (size + 1) s1 coverage0 + loop tests (discards + 1) (recentDiscards + 1) s1 coverage0 Just (Left _, _) -> let @@ -369,23 +367,78 @@ checkReport cfg size0 seed0 test0 updateUI = do coverage = journalCoverage journal <> coverage0 in - loop (tests + 1) discards (size + 1) s1 coverage + loop (tests + 1) discards 0 s1 coverage + + loop 0 0 0 seed0 mempty + +calculateSize :: TerminationCriteria -> TestCount -> DiscardCount -> Size +calculateSize term (TestCount tests) (DiscardCount discards) = + let + growDiscards (Size n) = + -- If we're discarding a lot, try larger sizes. When we succeed, we should + -- reset the discard count we pass here. + Size $ min 99 $ n + (discards `div` 10) + + steppingSizer (TestLimit limit) = + -- `tests` runs from 0 up to `limit - 1`, so exactly `limit` tests get + -- run. Suppose `limit` is (100n + r). Then we do `n` cycles where size + -- goes 0,1,...,99, and then for the final `r` tests, we try to increase + -- from 0 to 99 in equal increments. So if `r` is 10 we go 0,11,22,...,99. + -- + -- If we can't reach 99 we get as close as we can in equal increments + -- without going over, and if `r` is 1 we just run the final test at size + -- 0. + -- + -- More examples: + -- r == 2: 0, 99 + -- r == 3: 0, 49, 98 + -- r == 4: 0, 33, 66, 99 + -- r == 5: 0, 24, 48, 72, 96 + + let + (fullCycles, leftOvers) = limit `divMod` 100 + (cyclesCompleted, cyclePos) = tests `divMod` 100 + in + if tests >= limit then + error "test count is higher than limit" + else if cyclesCompleted < fullCycles then + Size cyclePos + else + -- leftOvers must be >= 1, or one of the previous branches would have + -- run. + if leftOvers == 1 then + Size 0 + else + let step = 99 `div` (leftOvers - 1) + in Size $ cyclePos * step + in + growDiscards $ case term of + -- Run exactly `limit` tests. + NoConfidenceTermination limit -> + steppingSizer limit + + -- Run exactly `limit` tests, but also use a confidence threshold for + -- coverage. + NoEarlyTermination _ limit -> + steppingSizer limit - loop 0 0 size0 seed0 mempty + -- Run some multiple of 100 tests. The TestLimit is ignored. That's likely + -- a bug elsewhere, but it makes this bit easy. + EarlyTermination _ _ -> + Size $ tests `mod` 100 checkRegion :: MonadIO m => Region -> UseColor -> Maybe PropertyName - -> Size -> Seed -> Property -> m (Report Result) -checkRegion region color name size seed prop = +checkRegion region color name size prop = liftIO $ do result <- - checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do + checkReport (propertyConfig prop) size (propertyTest prop) $ \progress -> do ppprogress <- renderProgress color name progress case reportStatus progress of Running -> @@ -414,7 +467,7 @@ checkNamed :: -> m (Report Result) checkNamed region color name mseed prop = do seed <- resolveSeed mseed - checkRegion region color name 0 seed prop + checkRegion region color name seed prop -- | Check a property. -- @@ -431,7 +484,7 @@ recheckAt seed skip prop0 = do color <- detectColor let prop = withSkip skip prop0 _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing 0 seed prop + checkRegion region color Nothing seed prop pure () -- | Check a group of properties using the specified runner config. diff --git a/hedgehog/test/Test/Hedgehog/Size.hs b/hedgehog/test/Test/Hedgehog/Size.hs new file mode 100644 index 00000000..afb9e621 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Size.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Hedgehog.Size where + +import Control.Monad ( void, when ) +import Control.Monad.IO.Class ( MonadIO(..) ) + +import Data.Foldable ( for_ ) +import qualified Data.IORef as IORef + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Internal.Config as Config +import qualified Hedgehog.Internal.Property as Property +import Hedgehog.Internal.Report ( Report(..) + , Result(..) + ) +import qualified Hedgehog.Internal.Runner as Runner + +checkProp :: MonadIO m => Property -> m (Report Result) +checkProp prop = do + seed <- Config.resolveSeed Nothing + liftIO $ Runner.checkReport (Property.propertyConfig prop) + seed + (Property.propertyTest prop) + (const $ pure ()) + +checkGrowth :: + MonadIO m => (Property -> Property) -> [Size] -> m [Size] +checkGrowth applyTerminationCriteria discardOn = do + logRef <- liftIO $ IORef.newIORef [] + + void $ checkProp $ applyTerminationCriteria $ property $ do + curSize <- forAll $ Gen.sized pure + liftIO $ IORef.modifyIORef' logRef (curSize :) + when (curSize `elem` discardOn) discard + + liftIO $ reverse <$> IORef.readIORef logRef + +data GrowthTest = + GrowthTest + TestLimit -- ^ number of tests to run + [Size] -- ^ which sizes should be discarded + [Size] -- ^ the expected sizes run at (including ones discarded) for + -- NoConfidenceTermination and NoEarlyTermination + [Size] -- ^ the expected sizes run at (including ones discarded) for + -- EarlyTermination + +growthTests :: [GrowthTest] +growthTests = + [ GrowthTest 1 [] [0] [0 .. 99] + , GrowthTest 5 [] [0, 24 .. 96] [0 .. 99] + , GrowthTest 10 [] [0, 11 .. 99] [0 .. 99] + , GrowthTest 101 [] ([0 .. 99] ++ [0]) [0 .. 99] + , GrowthTest 105 [] ([0 .. 99] ++ [0, 24 .. 96]) [0 .. 99] + , GrowthTest 5 [24] (concat [[0], replicate 10 24, [25, 48, 72, 96]]) + (concat [[0 .. 23], replicate 10 24, [25], [25 .. 99]]) + , let discards = concat [ replicate 10 96 + , replicate 10 97 + , replicate 10 98 + , replicate 70 99 -- discard limit is 100 + ] + in GrowthTest 5 [96 .. 99] ([0, 24 .. 72] ++ discards) + ([0 .. 95] ++ discards) + ] + +prop_GrowthTest :: Property +prop_GrowthTest = + withTests 1 . property $ do + for_ growthTests $ + \(GrowthTest testLimit discardOn expected1 expected2) -> do + let noConfidenceTerm = withTests testLimit + sizes1 <- checkGrowth noConfidenceTerm discardOn + sizes1 === expected1 + + let noEarlyTerm = withConfidence 1000 . noConfidenceTerm + sizes2 <- checkGrowth noEarlyTerm discardOn + sizes2 === expected1 + + let earlyTerm = verifiedTermination . noEarlyTerm + sizes3 <- checkGrowth earlyTerm discardOn + sizes3 === expected2 + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/hedgehog/test/Test/Hedgehog/Skip.hs b/hedgehog/test/Test/Hedgehog/Skip.hs index a8ef3957..3681e097 100644 --- a/hedgehog/test/Test/Hedgehog/Skip.hs +++ b/hedgehog/test/Test/Hedgehog/Skip.hs @@ -25,14 +25,15 @@ import Hedgehog.Internal.Report (Report(..), Result(..), FailureReport -- | We use this property to help test skipping. It keeps a log of every time it -- runs in the 'IORef' it's passed. -- --- It ignores its seed. It fails at size 2. When it shrinks, it initially +-- It ignores its seed. The third test fails. When it shrinks, it initially -- shrinks to something that will pass, and then to something that will fail. -- skipTestProperty :: IORef [(Size, Int, Bool)] -> Property skipTestProperty logRef = withTests 5 . property $ do val@(curSize, _, shouldPass) <- forAll $ do - curSize <- Gen.sized pure + -- With 5 tests, size goes 0, 24, 48, 72, 96. + curSize <- Gen.sized $ pure . (`div` 24) (shouldPass, nShrinks) <- (,) <$> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) @@ -50,7 +51,6 @@ checkProp prop = do seed <- Config.resolveSeed Nothing liftIO $ Runner.checkReport (Property.propertyConfig prop) - 0 seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/Test/Hedgehog/State.hs b/hedgehog/test/Test/Hedgehog/State.hs index 60a0ec56..c5b57b28 100644 --- a/hedgehog/test/Test/Hedgehog/State.hs +++ b/hedgehog/test/Test/Hedgehog/State.hs @@ -82,7 +82,6 @@ prop_mkInput = -- logs. seed <- Config.resolveSeed Nothing void $ liftIO $ Runner.checkReport (Property.propertyConfig prop) - 0 seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index f9ed19fd..b83aa7d5 100644 --- a/hedgehog/test/test.hs +++ b/hedgehog/test/test.hs @@ -5,6 +5,7 @@ import qualified Test.Hedgehog.Confidence import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Maybe import qualified Test.Hedgehog.Seed +import qualified Test.Hedgehog.Size import qualified Test.Hedgehog.Skip import qualified Test.Hedgehog.State import qualified Test.Hedgehog.Text @@ -19,6 +20,7 @@ main = , Test.Hedgehog.Filter.tests , Test.Hedgehog.Maybe.tests , Test.Hedgehog.Seed.tests + , Test.Hedgehog.Size.tests , Test.Hedgehog.Skip.tests , Test.Hedgehog.State.tests , Test.Hedgehog.Text.tests From 9dc953c212dc35f28ad3288e0892a448cb21bed8 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Wed, 1 Mar 2023 10:49:08 +0000 Subject: [PATCH 5/5] Restore the `Size` arguments for backwards compatibility. They're ignored, but this means hspec-hedgohog works again. Also, there was a parameter named `size` that should have been named `seed`. --- hedgehog/src/Hedgehog/Internal/Runner.hs | 12 +++++++----- hedgehog/test/Test/Hedgehog/Size.hs | 1 + hedgehog/test/Test/Hedgehog/Skip.hs | 1 + hedgehog/test/Test/Hedgehog/State.hs | 1 + 4 files changed, 10 insertions(+), 5 deletions(-) diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index 398e9481..f36b60ea 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -206,11 +206,12 @@ checkReport :: MonadIO m => MonadCatch m => PropertyConfig + -> Size -- ^ ignored, but retained for backwards compatibility -> Seed -> PropertyT m () -> (Report Progress -> m ()) -> m (Report Result) -checkReport cfg seed0 test0 updateUI = do +checkReport cfg _ seed0 test0 updateUI = do skip <- liftIO $ resolveSkip $ propertySkip cfg let @@ -432,13 +433,14 @@ checkRegion :: => Region -> UseColor -> Maybe PropertyName + -> Size -- ^ ignored, but retained for backwards compatibility -> Seed -> Property -> m (Report Result) -checkRegion region color name size prop = +checkRegion region color name _ seed prop = liftIO $ do result <- - checkReport (propertyConfig prop) size (propertyTest prop) $ \progress -> do + checkReport (propertyConfig prop) undefined seed (propertyTest prop) $ \progress -> do ppprogress <- renderProgress color name progress case reportStatus progress of Running -> @@ -467,7 +469,7 @@ checkNamed :: -> m (Report Result) checkNamed region color name mseed prop = do seed <- resolveSeed mseed - checkRegion region color name seed prop + checkRegion region color name undefined seed prop -- | Check a property. -- @@ -484,7 +486,7 @@ recheckAt seed skip prop0 = do color <- detectColor let prop = withSkip skip prop0 _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing seed prop + checkRegion region color Nothing undefined seed prop pure () -- | Check a group of properties using the specified runner config. diff --git a/hedgehog/test/Test/Hedgehog/Size.hs b/hedgehog/test/Test/Hedgehog/Size.hs index afb9e621..067e7122 100644 --- a/hedgehog/test/Test/Hedgehog/Size.hs +++ b/hedgehog/test/Test/Hedgehog/Size.hs @@ -21,6 +21,7 @@ checkProp :: MonadIO m => Property -> m (Report Result) checkProp prop = do seed <- Config.resolveSeed Nothing liftIO $ Runner.checkReport (Property.propertyConfig prop) + undefined seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/Test/Hedgehog/Skip.hs b/hedgehog/test/Test/Hedgehog/Skip.hs index 3681e097..5b54e17e 100644 --- a/hedgehog/test/Test/Hedgehog/Skip.hs +++ b/hedgehog/test/Test/Hedgehog/Skip.hs @@ -51,6 +51,7 @@ checkProp prop = do seed <- Config.resolveSeed Nothing liftIO $ Runner.checkReport (Property.propertyConfig prop) + undefined seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/Test/Hedgehog/State.hs b/hedgehog/test/Test/Hedgehog/State.hs index c5b57b28..d3173ccb 100644 --- a/hedgehog/test/Test/Hedgehog/State.hs +++ b/hedgehog/test/Test/Hedgehog/State.hs @@ -82,6 +82,7 @@ prop_mkInput = -- logs. seed <- Config.resolveSeed Nothing void $ liftIO $ Runner.checkReport (Property.propertyConfig prop) + undefined seed (Property.propertyTest prop) (const $ pure ())