Change Applicative GenT to use zipping

hedgehogqa/haskell-hedgehog#272

core/src/main/scala/hedgehog/core/GenT.scala

@@ -147,11 +147,14 @@ abstract class GenImplicits2 extends GenImplicits1 {
     new Applicative[GenT] {
       def point[A](a: => A): GenT[A] =
         GenT((_, s) => Tree.TreeApplicative.point((s, Some(a))))
-      def ap[A, B](fa: => GenT[A])(f: => GenT[A => B]): GenT[B] =
-        for {
-          ab <- f
-          a <- fa
-        } yield ab(a)
+      override def ap[A, B](fa: => GenT[A])(f: => GenT[A => B]): GenT[B] =
+        GenT((size, seed) => {
+          val f2 = f.run(size, seed)
+          val fa2 = fa.run(size, f2.value._1)
+          Applicative.zip(fa2, f2).map { case ((seed2, oa), (_, o)) =>
+            (seed2, o.flatMap(y => oa.map(y(_))))
+          }
+        })
     }
 }
 

core/src/main/scala/hedgehog/core/PropertyT.scala

@@ -76,6 +76,10 @@ object PropertyT {
         fa.map(f)
       override def point[A](a: => A): PropertyT[A] =
         propertyT.hoist((Nil, a))
+      override def ap[A, B](fa: => PropertyT[A])(f: => PropertyT[A => B]): PropertyT[B] =
+        PropertyT(Applicative.zip(fa.run, f.run)
+          .map { case ((l1, oa), (l2, oab)) => (l2 ++ l1, oab.flatMap(y => oa.map(y(_)))) }
+        )
       override def bind[A, B](fa: PropertyT[A])(f: A => PropertyT[B]): PropertyT[B] =
         fa.flatMap(f)
     }

core/src/main/scala/hedgehog/core/Tree.scala

@@ -43,12 +43,13 @@ abstract class TreeImplicits2 extends TreeImplicits1 {
       def point[A](a: => A): Tree[A] =
         Tree(a, Identity(LazyList()))
       def ap[A, B](fa: => Tree[A])(f: => Tree[A => B]): Tree[B] =
-        // FIX This isn't ideal, but if it's good enough for the Haskell implementation it's good enough for us
-        // https://github.com/hedgehogqa/haskell-hedgehog/pull/173
-        Tree.TreeMonad.bind(f)(ab =>
-        Tree.TreeMonad.bind(fa)(a =>
-          point(ab(a))
-        ))
+        Tree(
+          f.value(fa.value)
+        , Identity(
+             f.children.value.map(fl => ap(fa)(fl))
+          ++ fa.children.value.map(fal => ap(fal)(f))
+          )
+        )
     }
 }
 
@@ -60,6 +61,8 @@ object Tree extends TreeImplicits2 {
         fa.map(f)
       override def point[A](a: => A): Tree[A] =
         TreeApplicative.point(a)
+      override def ap[A, B](fa: => Tree[A])(f: => Tree[A => B]): Tree[B] =
+        TreeApplicative.ap(fa)(f)
       override def bind[A, B](fa: Tree[A])(f: A => Tree[B]): Tree[B] = {
         val y = f(fa.value)
         Tree(

core/src/main/scala/hedgehog/predef/LazyList.scala

@@ -23,6 +23,17 @@ sealed trait LazyList[A] {
       case Cons(h, t) =>
         Cons(h, () => t() ++ b)
     }
+
+  def toList(length: Int): List[A] =
+    if (length <= 0)
+      List.empty[A]
+    else
+      this match {
+        case Nil() =>
+          List.empty[A]
+        case Cons(h, t) =>
+          h() :: t().toList(length - 1)
+      }
 }
 
 object LazyList {

core/src/main/scala/hedgehog/predef/data.scala

@@ -15,10 +15,16 @@ trait Applicative[F[_]] extends Functor[F] {
     ap(fa)(point(f))
 }
 
+object Applicative {
+
+  def zip[F[_], A, B](fa: => F[A], f: => F[B])(implicit F: Applicative[F]): F[(A, B)] =
+    F.ap(fa)(F.map(f)(b => (a: A) => (a, b)))
+
+  def ap[F[_], A, B](fa: => F[A])(f: => F[A => B])(implicit F: Monad[F]): F[B] =
+    F.bind(f)(x => F.map(fa)(x))
+}
+
 trait Monad[F[_]] extends Applicative[F] {
 
   def bind[A, B](fa: F[A])(f: A => F[B]): F[B]
-
-  override def ap[A, B](fa: => F[A])(f: => F[A => B]): F[B] =
-    bind(f)(x => map(fa)(x))
 }

test/src/test/scala/hedgehog/GenTest.scala

@@ -11,6 +11,8 @@ object GenTest extends Properties {
     , example("frequency is random", testFrequency)
     , example("fromSome some", testFromSomeSome)
     , example("fromSome none", testFromSomeNone)
+    , example("applicative", testApplicative)
+    , example("monad", testMonad)
     )
 
   def testLong: Property = {
@@ -36,4 +38,26 @@ object GenTest extends Properties {
     val r = Property.checkRandom(PropertyConfig.default, Gen.fromSome(Gen.constant(Option.empty[Result])).forAll)
     r ==== Report(SuccessCount(0), DiscardCount(100), GaveUp)
   }
+
+  def testApplicative: Result = {
+    val r = TTree.fromTree(100, 100, forTupled(
+      Gen.int(Range.linear(0, 1))
+    , Gen.int(Range.linear(0, 1))
+    ).run(Size(100), Seed.fromLong(0)).map(_._2.orNull))
+    r ==== TTree((1, 1), List(
+        TTree((0, 1), List(TTree((0, 0), List())))
+      , TTree((1, 0), List(TTree((0, 0), List())))
+      ))
+  }
+
+  def testMonad: Result = {
+    val r = TTree.fromTree(100, 100, (for {
+      x <- Gen.int(Range.linear(0, 1))
+      y <- Gen.int(Range.linear(0, 1))
+    } yield (x, y)).run(Size(100), Seed.fromLong(0)).map(_._2.orNull))
+    r ==== TTree((1, 1), List(
+        TTree((0, 1), List(TTree((0, 0), List())))
+      , TTree((1, 0), List())
+      ))
+  }
 }

test/src/test/scala/hedgehog/PropertyTest.scala

@@ -9,6 +9,9 @@ object PropertyTest extends Properties {
   def tests: List[Test] =
     List(
       example("example1", example1)
+    , example("applicative", testApplicative)
+    , property("applicative shrink", testApplicativeShrinking)
+    , example("monad shrinking", testMonadShrinking)
     , example("total", total)
     , example("fail", fail)
     )
@@ -26,6 +29,45 @@ object PropertyTest extends Properties {
       ))
   }
 
+  def testApplicative: Result = {
+    val seed = Seed.fromLong(5489)
+    val r = Property.check(PropertyConfig.default, forTupled(
+      Gen.char('a', 'z').log("x")
+    , Gen.int(Range.linear(0, 50)).log("y")
+    )
+    .flatMap { case (x, y) =>
+      (if (y % 2 == 0) Property.discard else Property.point(())).map(_ =>
+      Result.assert(y < 87 && x <= 'r')
+    )}, seed)
+    r ==== Report(SuccessCount(2), DiscardCount(4), Failed(ShrinkCount(2), List(
+        ForAll("x", "s")
+      , ForAll("y", "1"))
+      ))
+  }
+
+  def testApplicativeShrinking: Property = {
+    for {
+      l <- Gen.long(Range.linearFrom(0L, Long.MinValue, Long.MaxValue)).forAll
+    } yield {
+      val seed = Seed.fromLong(l)
+      val r = Property.report(PropertyConfig.default, Some(Size(100)), seed, forTupled(
+        Gen.int(Range.linear(0, 10)).log("x")
+      , Gen.int(Range.linear(0, 10)).log("y")
+      ).map { case (x, y) => Result.assert(x < y) })
+      statusLog(r.status) ==== List(ForAll("x", "0"), ForAll("y", "0"))
+    }
+  }
+
+  def testMonadShrinking: Result = {
+    // This is one example where using a monad we don't find the optimal shrink (like we do with applicative)
+    val seed = Seed.fromLong(17418018500145L)
+    val r = Property.report(PropertyConfig.default, Some(Size(100)), seed, for {
+      x <- Gen.int(Range.linear(0, 10)).log("x")
+      y <- Gen.int(Range.linear(0, 10)).log("y")
+    } yield Result.assert(x < y))
+    statusLog(r.status) ==== List(ForAll("x", "7"), ForAll("y", "0"))
+  }
+
   case class USD(value: Long)
   case class Item(name: String, price: USD)
   case class Order(items: List[Item]) {
@@ -73,4 +115,12 @@ object PropertyTest extends Properties {
 
   def fail: Result =
     Property.checkRandom(PropertyConfig.default, Property.point(Result.failure)).status ==== Failed(ShrinkCount(0), Nil)
+
+  def statusLog(s: Status): List[Log]=
+    s match {
+      case f@Failed(_, _) =>
+        f.log
+      case _ =>
+        Nil
+    }
 }

test/src/test/scala/hedgehog/TTree.scala

@@ -0,0 +1,24 @@
+package hedgehog
+
+import hedgehog.core._
+import hedgehog.predef._
+
+/**
+ * A simplified strict tree for testing trees with.
+ *
+ * FIXME We should consider introducing a parameter for Tree that lets us do this easily.
+ */
+case class TTree[A](value: A, children: List[TTree[A]]) {
+
+  def toTree: Tree[A] =
+    Tree(value, Identity(LazyList.fromList(children.map(_.toTree))))
+}
+
+object TTree {
+
+  def fromTree[A](depth: Int, width: Int, t: Tree[A]): TTree[A] =
+    if (depth <= 0)
+      TTree(t.value, Nil)
+    else
+      TTree(t.value, t.children.value.toList(width).map(TTree.fromTree(depth - 1, width, _)))
+}

test/src/test/scala/hedgehog/TreeTest.scala

@@ -0,0 +1,33 @@
+package hedgehog
+
+import hedgehog.runner._
+
+object TreeTest extends Properties {
+
+  def tests: List[Test] =
+    List(
+      example("applicative", testApplicative)
+    , example("monad", testMonad)
+    )
+
+  def testApplicative: Result = {
+    TTree.fromTree(100, 100, forTupled(
+      TTree(1, List(TTree(2, List()))).toTree
+    , TTree(3, List(TTree(4, List()))).toTree
+    )) ==== TTree((1, 3), List(
+        TTree((2, 3), List(TTree((2, 4), List())))
+      , TTree((1, 4), List(TTree((2, 4), List())))
+      ))
+  }
+
+  def testMonad: Result = {
+    TTree.fromTree(100, 100, for {
+       a <- TTree(1, List(TTree(2, List()))).toTree
+       b <- TTree(3, List(TTree(4, List()))).toTree
+    } yield (a, b)
+    ) ==== TTree((1, 3), List(
+        TTree((2, 3), List(TTree((2, 4), List())))
+      , TTree((1, 4), List()))
+      )
+   }
+}