diff --git a/hedgehog/src/Hedgehog/Internal/Property.hs b/hedgehog/src/Hedgehog/Internal/Property.hs index 36f636a1..455b49a2 100644 --- a/hedgehog/src/Hedgehog/Internal/Property.hs +++ b/hedgehog/src/Hedgehog/Internal/Property.hs @@ -127,10 +127,10 @@ import Language.Haskell.TH.Lift (deriveLift) -- | A property test, along with some configurable limits like how many times -- to run the test. -- -data Property = +data Property a = Property { propertyConfig :: !PropertyConfig - , propertyTest :: PropertyT IO () + , propertyTest :: PropertyT IO a } -- | The property monad transformer allows both the generation of test inputs @@ -255,10 +255,10 @@ newtype ShrinkRetries = -- | A named collection of property tests. -- -data Group = +data Group a = Group { groupName :: !GroupName - , groupProperties :: ![(PropertyName, Property)] + , groupProperties :: ![(PropertyName, Property a)] } -- | The name of a group of properties. @@ -741,7 +741,7 @@ defaultConfig = -- | Map a config modification function over a property. -- -mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property +mapConfig :: (PropertyConfig -> PropertyConfig) -> Property a -> Property a mapConfig f (Property cfg t) = Property (f cfg) t @@ -752,21 +752,21 @@ mapConfig f (Property cfg t) = -- need to run repeatedly, you can use @withTests 1@ to define a property that -- will only be checked once. -- -withTests :: TestLimit -> Property -> Property +withTests :: TestLimit -> Property a -> Property a withTests n = mapConfig $ \config -> config { propertyTestLimit = n } -- | Set the number of times a property is allowed to discard before the test -- runner gives up. -- -withDiscards :: DiscardLimit -> Property -> Property +withDiscards :: DiscardLimit -> Property a -> Property a withDiscards n = mapConfig $ \config -> config { propertyDiscardLimit = n } -- | Set the number of times a property is allowed to shrink before the test -- runner gives up and prints the counterexample. -- -withShrinks :: ShrinkLimit -> Property -> Property +withShrinks :: ShrinkLimit -> Property a -> Property a withShrinks n = mapConfig $ \config -> config { propertyShrinkLimit = n } @@ -774,13 +774,13 @@ withShrinks n = -- the test runner gives up and tries a different shrink. See 'ShrinkRetries' -- for more information. -- -withRetries :: ShrinkRetries -> Property -> Property +withRetries :: ShrinkRetries -> Property a -> Property a withRetries n = mapConfig $ \config -> config { propertyShrinkRetries = n } -- | Creates a property with the default configuration. -- -property :: HasCallStack => PropertyT IO () -> Property +property :: HasCallStack => PropertyT IO a -> Property a property m = Property defaultConfig $ withFrozenCallStack (evalM m) diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index 174bf468..a2aef7a6 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -26,6 +26,7 @@ import Control.Concurrent.STM (TVar, atomically) import qualified Control.Concurrent.STM.TVar as TVar import Control.Monad.Catch (MonadCatch(..), catchAll) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (void) import Data.Semigroup ((<>)) @@ -203,12 +204,12 @@ checkRegion :: -> Maybe PropertyName -> Size -> Seed - -> Property + -> Property a -> m (Report Result) checkRegion region mcolor name size seed prop = liftIO $ do result <- - checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do + checkReport (propertyConfig prop) size seed (void $ propertyTest prop) $ \progress -> do ppprogress <- renderProgress mcolor name progress case reportStatus progress of Running -> @@ -232,7 +233,7 @@ checkNamed :: => Region -> Maybe UseColor -> Maybe PropertyName - -> Property + -> Property a -> m (Report Result) checkNamed region mcolor name prop = do seed <- liftIO Seed.random @@ -240,14 +241,14 @@ checkNamed region mcolor name prop = do -- | Check a property. -- -check :: MonadIO m => Property -> m Bool +check :: MonadIO m => Property a -> m Bool check prop = liftIO . displayRegion $ \region -> (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop -- | Check a property using a specific size and seed. -- -recheck :: MonadIO m => Size -> Seed -> Property -> m () +recheck :: MonadIO m => Size -> Seed -> Property a -> m () recheck size seed prop0 = do let prop = withTests 1 prop0 _ <- liftIO . displayRegion $ \region -> @@ -256,7 +257,7 @@ recheck size seed prop0 = do -- | Check a group of properties using the specified runner config. -- -checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool +checkGroup :: MonadIO m => RunnerConfig -> Group a -> m Bool checkGroup config (Group group props) = liftIO $ do n <- resolveWorkers (runnerWorkers config) @@ -283,7 +284,7 @@ checkGroupWith :: WorkerCount -> Verbosity -> Maybe UseColor - -> [(PropertyName, Property)] + -> [(PropertyName, Property a)] -> IO Summary checkGroupWith n verbosity mcolor props = displayRegion $ \sregion -> do @@ -348,7 +349,7 @@ checkGroupWith n verbosity mcolor props = -- > ] -- -- -checkSequential :: MonadIO m => Group -> m Bool +checkSequential :: MonadIO m => Group a -> m Bool checkSequential = checkGroup RunnerConfig { @@ -382,7 +383,7 @@ checkSequential = -- > ("prop_reverse", prop_reverse) -- > ] -- -checkParallel :: MonadIO m => Group -> m Bool +checkParallel :: MonadIO m => Group a -> m Bool checkParallel = checkGroup RunnerConfig { diff --git a/hedgehog/src/Hedgehog/Internal/TH.hs b/hedgehog/src/Hedgehog/Internal/TH.hs index b0d31ae3..c57e138f 100644 --- a/hedgehog/src/Hedgehog/Internal/TH.hs +++ b/hedgehog/src/Hedgehog/Internal/TH.hs @@ -23,7 +23,7 @@ type TExpQ a = -- -- Functions starting with `prop_` are assumed to be properties. -- -discover :: TExpQ Group +discover :: TExpQ (Group a) discover = do file <- getCurrentFile properties <- Map.toList <$> runIO (readProperties file) @@ -42,11 +42,11 @@ discover = do [|| Group $$(moduleName) $$(listTE names) ||] -mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property) +mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property a) mkNamedProperty name = do [|| (name, $$(unsafeProperty name)) ||] -unsafeProperty :: PropertyName -> TExpQ Property +unsafeProperty :: PropertyName -> TExpQ (Property a) unsafeProperty = unsafeTExpCoerce . pure . VarE . mkName . unPropertyName