WIP: Allow for returning counterexamples

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,35 +752,35 @@ 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 }
 
 -- | Set the number of times a property will be executed for each shrink before
 --   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)

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,22 +233,22 @@ checkNamed ::
   => Region
   -> Maybe UseColor
   -> Maybe PropertyName
-  -> Property
+  -> Property a
   -> m (Report Result)
 checkNamed region mcolor name prop = do
   seed <- liftIO Seed.random
   checkRegion region mcolor name 0 seed prop
 
 -- | 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 {

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