Improved, and dare I say minimal, shrinking of lists

hedgehog-example/hedgehog-example.cabal

@@ -45,6 +45,7 @@ library
       Test.Example.Basic
     , Test.Example.Coverage
     , Test.Example.Exception
+    , Test.Example.List
     , Test.Example.QuickCheck
     , Test.Example.References
     , Test.Example.Registry

hedgehog-example/src/Test/Example/List.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Test.Example.List where
+
+import           Control.Monad.Zip (mzip)
+import qualified Control.Monad.State.Lazy as Lazy
+import qualified Control.Monad.State.Class as State
+import qualified Control.Monad.Writer.Lazy as Lazy
+import qualified Control.Monad.Writer.Class as Writer
+import           Control.Monad.Morph (MFunctor(..))
+
+import           Data.Maybe (fromJust)
+import           Data.Foldable (toList)
+import           Data.Monoid (Sum(..))
+import qualified Data.List as List
+
+import           Hedgehog
+import qualified Hedgehog.Range as Range
+
+import qualified Hedgehog.Internal.Gen as Gen
+import qualified Hedgehog.Internal.Shrink as Shrink
+import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
+import           Hedgehog.Internal.Tree (Tree)
+import qualified Hedgehog.Internal.Tree as Tree
+
+
+genInt :: MonadGen m => m Int
+genInt =
+  Gen.int (Range.constant 0 2)
+
+genList :: MonadGen m => m a -> m [a]
+genList =
+  Gen.list (Range.constant 0 2)
+
+prop_list :: Property
+prop_list =
+  property $ do
+    let
+      cond :: [Int] -> Bool
+      cond xs =
+        all (>= length xs) xs
+
+      renderTree :: Tree [Int] -> String
+      renderTree =
+        Tree.render .
+        fmap show .
+        fmap (\xs -> (cond xs, xs))
+
+    ts <- forAllWith renderTree (Gen.toTree $ genList genInt)
+    xs0 <- forAll (Gen.fromTree ts)
+
+    assert (cond xs0)
+
+newtype Index =
+  Index Int
+  deriving (Eq, Num, Show)
+
+genStateInt :: (MonadGen m, State.MonadState Index m) => m (Index, Int)
+genStateInt = do
+  x <- genInt
+  State.modify (+ 1)
+  index <- State.get
+  pure (index, x)
+
+prop_state_list :: Property
+prop_state_list =
+  property $ do
+    let
+      cond :: [(a, Int)] -> Bool
+      cond xs =
+        all ((>= length xs) . snd) xs
+
+      renderTree :: Tree [(Index, Int)] -> String
+      renderTree =
+        Tree.render .
+        fmap show .
+        fmap (\xs -> (cond xs, xs))
+
+    ts <- forAllWith renderTree (Gen.toTree $ hoist (`Lazy.evalStateT` 0) $ genList genStateInt)
+    xs0 <- forAll (Gen.fromTree ts)
+
+    assert (cond xs0)
+
+data Log =
+    List Int
+  | Int Int
+    deriving (Show)
+
+genWriterList :: (MonadGen m, Writer.MonadWriter [Log] m) => m a -> m [a]
+genWriterList gen = do
+  xs <- Gen.list (Range.constant 0 2) gen
+  Writer.tell [List (length xs)]
+  pure xs
+
+genWriterInt :: (MonadGen m, Writer.MonadWriter [Log] m) => m Int
+genWriterInt = do
+  x <- genInt
+  Writer.tell [Int x]
+  pure x
+
+renderLog :: [Log] -> String
+renderLog xs =
+  concat . flip fmap xs $ \case
+    List n ->
+      " L" ++ show n
+    Int n ->
+      show n
+
+prop_writer_list :: Property
+prop_writer_list =
+  property $ do
+    let
+      cond :: [Int] -> Bool
+      cond xs =
+        all ((>= length xs)) xs
+
+      renderTree =
+        Tree.render .
+        fmap (\(ns, ws) -> show (cond ns, ns) ++ " (" ++ renderLog ws ++ ")")
+
+    ts <- forAllWith renderTree (Gen.toTree . Lazy.runWriterT $ genWriterList genWriterInt)
+    (xs0, _) <- forAll (Gen.fromTree ts)
+
+    assert (cond xs0)
+
+
+tests :: IO Bool
+tests =
+  checkParallel $$(discover)

hedgehog-quickcheck/src/Hedgehog/Gen/QuickCheck.hs

@@ -16,7 +16,7 @@ import qualified Test.QuickCheck.Random as QuickCheck
 
 seedQCGen :: MonadGen m => m QuickCheck.QCGen
 seedQCGen =
-  QuickCheck.mkQCGen <$> Gen.lift (Gen.integral_ Range.constantBounded)
+  QuickCheck.mkQCGen <$> fromGenT (Gen.integral_ Range.constantBounded)
 
 -- | Create a Hedgehog 'Gen' from a QuickCheck 'QuickCheck.Gen'.
 --

hedgehog-quickcheck/src/Test/QuickCheck/Hedgehog.hs

@@ -5,9 +5,9 @@ module Test.QuickCheck.Hedgehog (
   ) where
 
 import           Hedgehog
-import           Hedgehog.Internal.Gen (runGen)
+import           Hedgehog.Internal.Gen (evalGen)
 import qualified Hedgehog.Internal.Seed as Seed
-import           Hedgehog.Internal.Tree (NodeT(..), runTree)
+import           Hedgehog.Internal.Tree (treeValue)
 
 import qualified Test.QuickCheck as QuickCheck
 
@@ -30,10 +30,10 @@ hedgehog gen =
       else do
         seed <- genSeed
         size <- QuickCheck.sized (pure . fromIntegral)
-        case runGen size seed gen of
+        case evalGen size seed gen of
           Nothing ->
             loop (n - 1)
           Just x ->
-            pure . nodeValue $ runTree x
+            pure $ treeValue x
   in
     loop (100 :: Int)

hedgehog/hedgehog.cabal

@@ -130,6 +130,7 @@ test-suite test
       hedgehog
     , base                            >= 3          && < 5
     , containers                      >= 0.4        && < 0.7
+    , mtl                             >= 2.1        && < 2.3
     , pretty-show                     >= 1.6        && < 1.10
     , semigroups                      >= 0.16       && < 0.19
     , text                            >= 1.1        && < 1.3

hedgehog/src/Hedgehog.hs

@@ -56,8 +56,6 @@ module Hedgehog (
 
   , forAll
   , forAllWith
-  , classify
-  , cover
   , discard
 
   , check
@@ -112,6 +110,8 @@ module Hedgehog (
   , evalExceptT
 
   -- * Coverage
+  , classify
+  , cover
   , label
   , collect
 
@@ -133,7 +133,7 @@ module Hedgehog (
   , Opaque(..)
 
   -- * Transformers
-  , distribute
+  , distributeT
 
   -- * Functors
   , HTraversable(..)
@@ -150,7 +150,7 @@ module Hedgehog (
 
 import           Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1)
 
-import           Hedgehog.Internal.Distributive (Distributive(..))
+import           Hedgehog.Internal.Distributive (distributeT)
 import           Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..))
 import           Hedgehog.Internal.HTraversable (HTraversable(..))
 import           Hedgehog.Internal.Opaque (Opaque(..))

hedgehog/src/Hedgehog/Gen.hs

@@ -1,9 +1,6 @@
 module Hedgehog.Gen (
-  -- * Combinators
-    lift
-
   -- ** Shrinking
-  , shrink
+    shrink
   , prune
 
   -- ** Size