Merge pull request #400 from TysonMN/applicative_CE

Applicative CE

CHANGELOG.md

@@ -3,6 +3,7 @@
 - Add `Tree.apply`. Change `Gen.apply` from monadic to applicative. Revert runtime optimization of `Gen.integral`. ([#398][398], [@TysonMN][TysonMN])
 - Change `ListGen.traverse` from monadic to applicative. ([#399][399], [@TysonMN][TysonMN])
 - Fix bug in the `BindReturn` method of the `property` CE where the generated value is not added to the Journal. ([#401][401], [@TysonMN][TysonMN])
+- Add `BindReturn` to the `gen` CE. This essentially changes the last call to `let!` to use `Gen.map` instead of `Gen.bind`. Add `MergeSources` to the `gen` and `property` CEs.  This change enables the `and!` syntax. ([#400][400], [@TysonMN][TysonMN])
 
 ## Version 0.12.0 (2021-12-12)
 
@@ -193,6 +194,8 @@
 
 [401]:
   https://github.com/hedgehogqa/fsharp-hedgehog/pull/401
+[400]:
+  https://github.com/hedgehogqa/fsharp-hedgehog/pull/400
 [399]:
   https://github.com/hedgehogqa/fsharp-hedgehog/pull/399
 [398]:

src/Hedgehog/Gen.fs

@@ -103,6 +103,8 @@ module Gen =
                 constant ()
         member __.Return(a) : Gen<'a> = constant a
         member __.ReturnFrom(g) : Gen<'a> = g
+        member __.BindReturn(g, f) = map f g
+        member __.MergeSources(ga, gb) = zip ga gb
         member __.Bind(g, f) = g |> bind f
         member __.For(xs, k) =
             let xse = (xs :> seq<'a>).GetEnumerator ()

src/Hedgehog/Property.fs

@@ -330,6 +330,9 @@ module PropertyBuilder =
             |> Property.ofGen
             |> Property.map f
 
+        member __.MergeSources(ga, gb) =
+            Gen.zip ga gb
+
         member __.ReturnFrom(m : Property<'a>) : Property<'a> =
             m
 

tests/Hedgehog.Tests/GenTests.fs

@@ -5,6 +5,50 @@ open Hedgehog
 open Hedgehog.Gen.Operators
 open TestDsl
 
+
+let private testGenPairViaApply gPair =
+    // In addition to asserting that Gen.apply is applicative, this code
+    // also asserts that the integral shrink tree is the one containing
+    // duplicates that existed before PR
+    // https://github.com/hedgehogqa/fsharp-hedgehog/pull/239
+    // The duplicate-free shrink trees that result from the code in that PR
+    // do not work well with the applicative behavior of Gen.apply because
+    // some values would shrink more if using the monadic version of
+    // Gen.apply, which should never happen.
+    let actual =
+        seq {
+            while true do
+                let t = gPair |> Gen.sampleTree 0 1 |> Seq.head
+                if Tree.outcome t = (2, 1) then
+                    yield t
+        } |> Seq.head
+
+    let expected =
+        Node ((2, 1), [
+            Node ((0, 1), [
+                Node ((0, 0), [])
+            ])
+            Node ((1, 1), [
+                Node ((0, 1), [
+                    Node ((0, 0), [])
+                ])
+                Node ((1, 0), [
+                    Node ((0, 0), [])
+                ])
+            ])
+            Node ((2, 0), [
+                Node ((0, 0), [])
+                Node ((1, 0), [
+                    Node ((0, 0), [])
+                ])
+            ])
+        ])
+
+    (actual      |> Tree.map (sprintf "%A") |> Tree.render)
+    =! (expected |> Tree.map (sprintf "%A") |> Tree.render)
+    Expect.isTrue <| Tree.equals actual expected
+
+
 let genTests = testList "Gen tests" [
     yield! testCases "dateTime creates DateTime instances"
         [ 8; 16; 32; 64; 128; 256; 512 ] <| fun count->
@@ -37,21 +81,23 @@ let genTests = testList "Gen tests" [
         [] =! List.filter (fun ch -> ch = char nonchar) actual
 
     testCase "dateTime randomly generates value between max and min ticks" <| fun _ ->
-        let seed0 = Seed.random ()
-        let (seed1, _) = Seed.split seed0
+        // This is a bad test because essentially the same logic used to
+        // implement Gen.dateTime appears in this test. However, keeping it for
+        // now.
+        let seed = Seed.random ()
         let range =
             Range.constant
                 DateTime.MinValue.Ticks
                 DateTime.MaxValue.Ticks
         let ticks =
             Random.integral range
-            |> Random.run seed1 0
+            |> Random.run seed 0
 
         let actual =
             Range.constant DateTime.MinValue DateTime.MaxValue
             |> Gen.dateTime
             |> Gen.toRandom
-            |> Random.run seed0 0
+            |> Random.run seed 0
             |> Tree.outcome
 
         let expected = DateTime ticks
@@ -135,51 +181,20 @@ let genTests = testList "Gen tests" [
         }
         |> Property.check
 
-    testCase "apply is applicative" <| fun () ->
-        // In addition to asserting that Gen.apply is applicative, this test
-        // also asserts that the integral shrink tree is the one containing
-        // duplicates that existed before PR
-        // https://github.com/hedgehogqa/fsharp-hedgehog/pull/239
-        // The duplicate-free shrink trees that result from the code in that PR
-        // do not work well with the applicative behavior of Gen.apply because
-        // some values would shrink more if using the monadic version of
-        // Gen.apply, which should never happen.
+    testCase "apply is applicative via function" <| fun () ->
         let gPair =
             Gen.constant (fun a b -> a, b)
             |> Gen.apply (Range.constant 0 2 |> Gen.int32)
             |> Gen.apply (Range.constant 0 1 |> Gen.int32)
+        testGenPairViaApply gPair
 
-        let actual =
-            seq {
-                while true do
-                    let t = gPair |> Gen.sampleTree 0 1 |> Seq.head
-                    if Tree.outcome t = (2, 1) then
-                        yield t
-            } |> Seq.head
-
-        let expected =
-            Node ((2, 1), [
-                Node ((0, 1), [
-                    Node ((0, 0), [])
-                ])
-                Node ((1, 1), [
-                    Node ((0, 1), [
-                        Node ((0, 0), [])
-                    ])
-                    Node ((1, 0), [
-                        Node ((0, 0), [])
-                    ])
-                ])
-                Node ((2, 0), [
-                    Node ((0, 0), [])
-                    Node ((1, 0), [
-                        Node ((0, 0), [])
-                    ])
-                ])
-            ])
-
-        (actual      |> Tree.map (sprintf "%A") |> Tree.render)
-        =! (expected |> Tree.map (sprintf "%A") |> Tree.render)
-        Expect.isTrue <| Tree.equals actual expected
+    testCase "apply is applicative via CE" <| fun () ->
+        let gPair =
+            gen {
+                let! a = Range.constant 0 2 |> Gen.int32
+                and! b = Range.constant 0 1 |> Gen.int32
+                return a, b
+            }
+        testGenPairViaApply gPair
 
 ]

tests/Hedgehog.Tests/PropertyTests.fs

@@ -110,4 +110,25 @@ let propertyTests = testList "Property tests" [
 
         actual =! "false"
 
+    testCase "and! syntax is applicative" <| fun () ->
+        // Based on https://well-typed.com/blog/2019/05/integrated-shrinking/#:~:text=For%20example%2C%20consider%20the%20property%20that
+        let actual =
+            property {
+                let! x = Range.constant 0 1_000_000_000 |> Gen.int32
+                and! y = Range.constant 0 1_000_000_000 |> Gen.int32
+                return x <= y |> Expect.isTrue
+            }
+            |> Property.report
+            |> Report.render
+            |> (fun x -> x.Split ([|Environment.NewLine|], StringSplitOptions.None))
+            |> Array.item 1
+
+        let actual =
+            // normalize printing of a pair between .NET and Fable/JS
+            actual.Replace("(", "")
+                  .Replace(" ", "")
+                  .Replace(")", "")
+
+        actual =! "1,0"
+
 ]