Change Applicative GenT to use zippping

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

@@ -4,9 +4,6 @@ module Test.QuickCheck.Hedgehog (
     hedgehog
   ) where
 
-import           Control.Monad.Trans.Maybe (runMaybeT)
-import           Data.Functor.Identity (runIdentity)
-
 import           Hedgehog
 import           Hedgehog.Internal.Gen (runGen)
 import qualified Hedgehog.Internal.Seed as Seed

hedgehog-test-laws/test/test.hs

@@ -9,7 +9,7 @@ import           Data.Functor.Classes (Eq1(..))
 import           Hedgehog.Internal.Gen (GenT(..))
 import           Hedgehog.Internal.Range (Size(..))
 import           Hedgehog.Internal.Seed (Seed(..))
-import           Hedgehog.Internal.Tree (Tree(..), Node(..))
+import           Hedgehog.Internal.Tree (TreeT(..), NodeT(..))
 
 import           Test.QuickCheck (Arbitrary(..), Arbitrary1(..), CoArbitrary(..))
 import           Test.QuickCheck (choose, vector, coarbitraryIntegral, property)
@@ -32,20 +32,20 @@ instances =
       uncurry testProperties
   in
     testGroup "Instances" [
-      testGroup "Tree" $
+      testGroup "TreeT" $
         testBatch <$> [
-            applicative (undefined :: Tree Maybe (Bool, Char, Int))
-          , monad (undefined :: Tree Maybe (Bool, Char, Int))
-          , monadApplicative (undefined :: Tree (Either Bool) (Char, Int))
+            applicative (undefined :: TreeT Maybe (Bool, Char, Int))
+          , monad (undefined :: TreeT Maybe (Bool, Char, Int))
+          , monadApplicative (undefined :: TreeT (Either Bool) (Char, Int))
           ]
-    , testGroup "Node" $
+    , testGroup "NodeT" $
         testBatch <$> [
-            applicative (undefined :: Node Maybe (Bool, Char, Int))
-          , monad (undefined :: Node Maybe (Bool, Char, Int))
-          , monadApplicative (undefined :: Node (Either Bool) (Char, Int))
+            applicative (undefined :: NodeT Maybe (Bool, Char, Int))
+          , monad (undefined :: NodeT Maybe (Bool, Char, Int))
+          , monadApplicative (undefined :: NodeT (Either Bool) (Char, Int))
           ]
-    , ignoreTest . testGroup "GenT" $
-        testBatch <$> [
+    , testGroup "GenT" $
+        ignoreTest . testBatch <$> [
             applicative (undefined :: GenT Maybe (Bool, Char, Int))
           , monad (undefined :: GenT Maybe (Bool, Char, Int))
           , monadApplicative (undefined :: GenT (Either Bool) (Char, Int))
@@ -57,23 +57,23 @@ instances =
 
 -- Tree
 
-instance (Eq1 m, Eq a) => EqProp (Tree m a) where
+instance (Eq1 m, Eq a) => EqProp (TreeT m a) where
   (=-=) =
     eq
 
-instance (Arbitrary1 m, Arbitrary a) => Arbitrary (Tree m a) where
+instance (Arbitrary1 m, Arbitrary a) => Arbitrary (TreeT m a) where
   arbitrary =
-    Tree <$> arbitrary1
+    TreeT <$> arbitrary1
 
 -- Node
 
-instance (Eq1 m, Eq a) => EqProp (Node m a) where
+instance (Eq1 m, Eq a) => EqProp (NodeT m a) where
   (=-=) = eq
 
-instance (Arbitrary1 m, Arbitrary a) => Arbitrary (Node m a) where
+instance (Arbitrary1 m, Arbitrary a) => Arbitrary (NodeT m a) where
   arbitrary = do
     n <- choose (0, 2)
-    liftA2 Node arbitrary (vector n)
+    liftA2 NodeT arbitrary (vector n)
 
 -- GenT
 
@@ -93,7 +93,7 @@ instance (Arbitrary1 m) => Arbitrary1 (MaybeT m) where
   liftArbitrary = fmap MaybeT . liftArbitrary . liftArbitrary
 
 instance Show (GenT m a) where
-  show _ = "GenT { unGen = <function> }"
+  show _ = "GenT { unGenT = <function> }"
 
 instance (Eq1 m, Eq a) => EqProp (GenT m a) where
   GenT f0 =-= GenT f1 = property $ liftA2 (=-=) f0 f1

hedgehog/hedgehog.cabal

@@ -133,6 +133,7 @@ test-suite test
   other-modules:
     Test.Hedgehog.Seed
     Test.Hedgehog.Text
+    Test.Hedgehog.Zip
 
   build-depends:
       hedgehog

hedgehog/src/Hedgehog/Internal/Gen.hs

@@ -180,6 +180,7 @@ import qualified Control.Monad.Trans.State.Strict as Strict
 import qualified Control.Monad.Trans.Writer.Lazy as Lazy
 import qualified Control.Monad.Trans.Writer.Strict as Strict
 import           Control.Monad.Writer.Class (MonadWriter(..))
+import           Control.Monad.Zip (MonadZip(..))
 
 import           Data.Bifunctor (first, second)
 import           Data.ByteString (ByteString)
@@ -207,7 +208,7 @@ import           Hedgehog.Internal.Distributive (Distributive(..))
 import           Hedgehog.Internal.Seed (Seed)
 import qualified Hedgehog.Internal.Seed as Seed
 import qualified Hedgehog.Internal.Shrink as Shrink
-import           Hedgehog.Internal.Tree (TreeT(..), NodeT(..))
+import           Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..))
 import qualified Hedgehog.Internal.Tree as Tree
 import           Hedgehog.Range (Size, Range)
 import qualified Hedgehog.Range as Range
@@ -269,7 +270,7 @@ runDiscardEffect =
 --
 --   'Nothing' means discarded, 'Just' means we have a value.
 --
-runGen :: Size -> Seed -> Gen a -> Maybe (TreeT Identity a)
+runGen :: Size -> Seed -> Gen a -> Maybe (Tree a)
 runGen size seed gen =
   fmap (fmap Maybe.fromJust) .
   Tree.filter Maybe.isJust .
@@ -331,7 +332,7 @@ instance Monad m => MonadGen (GenT m) where
       mx <- Trans.lift . Trans.lift . runMaybeT . runTreeT $ runGenT size seed gen
       case mx of
         Nothing ->
-          mzero
+          empty
         Just (NodeT x xs) ->
           pure (x, liftTreeMaybeT . Tree.fromNodeT $ NodeT x xs)
 
@@ -559,7 +560,7 @@ instance Functor m => Functor (GenT m) where
       fmap f (runGenT seed size gen)
 
 --
--- implementation: satisfies law (ap = <*>)
+-- implementation: parallel shrinking
 --
 instance Monad m => Applicative (GenT m) where
   pure =
@@ -568,8 +569,22 @@ instance Monad m => Applicative (GenT m) where
     GenT $ \ size seed ->
       case Seed.split seed of
         (sf, sm) ->
-          runGenT size sf f <*>
-          runGenT size sm m
+          uncurry ($) <$>
+            runGenT size sf f `mzip`
+            runGenT size sm m
+
+--
+-- implementation: satisfies law (ap = <*>)
+--
+--instance Monad m => Applicative (GenT m) where
+--  pure =
+--    liftTreeMaybeT . pure
+--  (<*>) f m =
+--    GenT $ \ size seed ->
+--      case Seed.split seed of
+--        (sf, sm) ->
+--          runGenT size sf f <*>
+--          runGenT size sm m
 
 instance Monad m => Monad (GenT m) where
   return =
@@ -1267,7 +1282,7 @@ recursive f nonrec rec =
 --
 discard :: MonadGen m => m a
 discard =
-  liftGen mzero
+  liftGen empty
 
 -- | Discards the generator if the generated value does not satisfy the
 --   predicate.

hedgehog/src/Hedgehog/Internal/Tree.hs

@@ -42,6 +42,7 @@ import           Control.Monad.State.Class (MonadState(..))
 import           Control.Monad.Trans.Class (MonadTrans(..))
 import           Control.Monad.Trans.Resource (MonadResource(..))
 import           Control.Monad.Writer.Class (MonadWriter(..))
+import           Control.Monad.Zip (MonadZip(..))
 
 import           Data.Functor.Identity (Identity(..))
 import           Data.Functor.Classes (Eq1(..))
@@ -51,6 +52,7 @@ import           Data.Functor.Classes (showsUnaryWith, showsBinaryWith)
 #endif
 import           Data.Foldable (Foldable(..))
 import           Data.Maybe (mapMaybe)
+import           Data.Semigroup ((<>))
 
 import           Hedgehog.Internal.Distributive
 
@@ -216,6 +218,24 @@ instance MonadPlus m => MonadPlus (TreeT m) where
   mplus x y =
     TreeT (runTreeT x `mplus` runTreeT y)
 
+zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b)
+zipTreeT l0@(TreeT left) r0@(TreeT right) =
+  TreeT $
+    let
+      zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b)
+      zipNodeT (NodeT a ls) (NodeT b rs) =
+          NodeT (a, b) $
+            concat [
+                [zipTreeT l1 r0 | l1 <- ls]
+              , [zipTreeT l0 r1 | r1 <- rs]
+              ]
+    in
+      zipNodeT <$> left <*> right
+
+instance Monad m => MonadZip (TreeT m) where
+  mzip =
+    zipTreeT
+
 instance MonadTrans TreeT where
   lift f =
     TreeT $

hedgehog/test/Test/Hedgehog/Zip.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Test.Hedgehog.Zip where
+
+import           Control.Monad.Zip (mzip)
+
+import           Data.Maybe (fromJust)
+import           Data.Foldable (toList)
+
+import           Hedgehog
+import qualified Hedgehog.Range as Range
+
+import qualified Hedgehog.Internal.Gen as Gen
+import           Hedgehog.Internal.Tree (Tree)
+import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
+import qualified Hedgehog.Internal.Tree as Tree
+import qualified Hedgehog.Internal.Shrink as Shrink
+
+
+mkTree :: Int -> Tree Int
+mkTree n =
+  Tree.expand (Shrink.towards 0) (pure n)
+
+mkGen :: Int -> Gen Int
+mkGen =
+  Gen.liftTreeT . mkTree
+
+prop_gen_applicative :: Property
+prop_gen_applicative =
+  property $ do
+    let
+      treeApplicative n m =
+        (,) <$> mkTree n <*> mkTree m
+
+      treeZip n m =
+        mzip (mkTree n) (mkTree m)
+
+      genApplicative n m =
+        fromJust .
+        Gen.runGen 0 (Seed 0 0) $
+          (,) <$> mkGen n <*> mkGen m
+
+      count00 =
+        length .
+        filter (== (0,0)) .
+        toList
+
+      render :: HasCallStack => Tree (Int, Int) -> PropertyT IO ()
+      render x =
+        withFrozenCallStack $ do
+          annotate . Tree.render $ fmap show x
+          annotate $ "---"
+          annotate $ "count (0,0) = " ++ show (count00 x)
+
+    n <- forAll $ Gen.int (Range.constant 1 5)
+    m <- forAll $ Gen.int (Range.constant 1 5)
+
+    render $ genApplicative n m
+    render $ treeZip n m
+    render $ treeApplicative n m
+
+    genApplicative n m === treeZip n m
+    genApplicative n m /== treeApplicative n m
+
+    success
+
+tests :: IO Bool
+tests =
+  checkParallel $$(discover)

hedgehog/test/test.hs

@@ -2,11 +2,13 @@ import           Hedgehog.Main (defaultMain)
 
 import qualified Test.Hedgehog.Seed
 import qualified Test.Hedgehog.Text
+import qualified Test.Hedgehog.Zip
 
 
 main :: IO ()
 main =
   defaultMain [
       Test.Hedgehog.Text.tests
     , Test.Hedgehog.Seed.tests
+    , Test.Hedgehog.Zip.tests
     ]