diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index fdc8a67f..53144b52 100644 --- a/hedgehog/hedgehog.cabal +++ b/hedgehog/hedgehog.cabal @@ -137,7 +137,9 @@ test-suite test Test.Hedgehog.Filter Test.Hedgehog.Maybe Test.Hedgehog.Seed + Test.Hedgehog.Size Test.Hedgehog.Skip + Test.Hedgehog.State Test.Hedgehog.Text Test.Hedgehog.Zip 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..398e9481 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,8 +40,8 @@ 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 (TerminationCriteria(..)) +import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) +import Hedgehog.Internal.Property (TerminationCriteria(..), TestLimit(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) @@ -53,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) @@ -207,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 @@ -255,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 @@ -302,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 -- @@ -336,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 @@ -349,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 @@ -370,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 -> @@ -415,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. -- @@ -425,22 +477,14 @@ 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 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/src/Hedgehog/Internal/State.hs b/hedgehog/src/Hedgehog/Internal/State.hs index 1114592e..176b8f82 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,11 +403,47 @@ 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. @@ -418,6 +455,9 @@ data Action m (state :: (Type -> Type) -> Type) = actionInput :: input Symbolic + , actionRefreshInput :: + state Symbolic -> Maybe (input Symbolic) + , actionOutput :: Symbolic output @@ -435,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 . @@ -512,26 +552,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 _ 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 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 input refreshInput output exec require update ensure + _ -> + pure Nothing in fmap Maybe.catMaybes . traverse loop @@ -545,34 +587,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 (const $ Just input) 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 input (flip mkInput input0) output exec + (callbackRequire callbacks) + (callbackUpdate callbacks) + (callbackEnsure callbacks) + _ -> + pure Nothing genActions :: (MonadGen gen, MonadTest m) @@ -583,7 +647,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 +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 ++ " = " @@ -610,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 ++ " = " @@ -709,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 @@ -736,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 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 new file mode 100644 index 00000000..c5b57b28 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/State.hs @@ -0,0 +1,94 @@ +{-# 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) + 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..b83aa7d5 100644 --- a/hedgehog/test/test.hs +++ b/hedgehog/test/test.hs @@ -5,7 +5,9 @@ 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 import qualified Test.Hedgehog.Zip @@ -18,7 +20,9 @@ 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 , Test.Hedgehog.Zip.tests ]