Merge pull request #147 from Porges:performance-fix

Make Journal store delayed strings, so they are computed on-demand
hedgehogqa · Nov 7, 2017 · 813e1f9 · 813e1f9
2 parents db7c669 + 70d4454
commit 813e1f9
Show file tree

Hide file tree

Showing 3 changed files with 16 additions and 23 deletions.
diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs
@@ -4,7 +4,7 @@ open FSharpx.Collections
 open System
 
 type Journal =
-    | Journal of List<string>
+    | Journal of LazyList<string>
 
 type Result<'a> =
     | Failure
@@ -39,26 +39,23 @@ module private Tuple =
 
 [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
 module Journal =
-    let ofList (xs : List<string>) : Journal =
+    let ofList (xs : LazyList<string>) : Journal =
         Journal xs
 
     let toList (Journal xs : Journal) : List<string> =
-        xs
+        LazyList.toList xs
 
     let empty : Journal =
-        List.empty |> ofList
+        LazyList.empty |> ofList
 
     let singleton (x : string) : Journal =
-        List.singleton x |> ofList
+        LazyList.singleton x |> ofList
 
-    let map (f : List<string> -> List<string>) (xs : Journal) : Journal =
-        toList xs |> f |> ofList
+    let delayedSingleton (x : unit -> string) : Journal =
+        LazyList.delayed (fun () -> LazyList.singleton (x ())) |> ofList
 
-    let addFailure (msg : string) (x : Journal) : Journal =
-        map (List.cons msg) x
-
-    let append (xs : Journal) (ys : Journal) : Journal =
-        toList xs @ toList ys |> ofList
+    let append (Journal xs) (Journal ys) : Journal =
+        LazyList.append xs ys |> ofList
 
 [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
 module Result =
@@ -263,8 +260,8 @@ module Property =
             failure
 
     [<CompiledName("CounterExample")>]
-    let counterexample (msg : string) : Property<unit> =
-        Gen.constant (Journal.singleton msg, Success ()) |> ofGen
+    let counterexample (msg : unit -> string) : Property<unit> =
+        Gen.constant (Journal.delayedSingleton msg, Success ()) |> ofGen
 
     let private mapGen
             (f : Gen<Journal * Result<'a>> -> Gen<Journal * Result<'b>>)
@@ -296,7 +293,7 @@ module Property =
         let handle (e : exn) =
             Gen.constant (Journal.singleton (string e), Failure) |> ofGen
         let prepend (x : 'a) =
-            bind (counterexample (sprintf "%A" x)) (fun _ -> try k x with e -> handle e) |> toGen
+            bind (counterexample (fun () -> sprintf "%A" x)) (fun _ -> try k x with e -> handle e) |> toGen
         Gen.bind gen prepend |> ofGen
 
     [<CompiledName("ForAll")>]
@@ -460,7 +457,7 @@ module PropertyBuilder =
         [<CustomOperation("counterexample", MaintainsVariableSpace = true)>]
         member __.Counterexample(m : Property<'a>, [<ProjectionParameter>] f : 'a -> string) : Property<'a> =
             Property.bind m <| fun x ->
-            Property.bind (Property.counterexample (f x)) <| fun _ ->
+            Property.bind (Property.counterexample (fun () -> f x)) <| fun _ ->
             Property.success x
 
         [<CustomOperation("where", MaintainsVariableSpace = true)>]

diff --git a/src/Hedgehog/Script.fsx b/src/Hedgehog/Script.fsx
@@ -102,7 +102,7 @@ Property.print <| property {
         // Custom operations (i.e. counterexample) can't be used in computation
         // expressions which have control flow :( we can fake it using return!
         // however.
-        return! Property.counterexample (sprintf "x = %A" x)
+        return! Property.counterexample (fun () -> sprintf "x = %A" x)
 
         // Note, return can be used multiple times, its a bit like 'assert'.
         return x <> 'w'
@@ -112,8 +112,8 @@ Property.print <| property {
     while n < 10 do
         n <- n + 1
         let! k = Gen.int <| Range.constant 0 n
-        return! Property.counterexample (sprintf "n = %d" n)
-        return! Property.counterexample (sprintf "k = %d" k)
+        return! Property.counterexample (fun () -> sprintf "n = %d" n)
+        return! Property.counterexample (fun () -> sprintf "k = %d" k)
         return k <> 5
 }
 

diff --git a/tests/Hedgehog.Tests/MinimalTests.fs b/tests/Hedgehog.Tests/MinimalTests.fs
@@ -62,10 +62,6 @@ let rec genExp : Gen<Exp> =
         App <!> Gen.zip genExp genExp
     ]
 
-// FIXME This test takes quite some time to run, it would be good to profile
-// FIXME this and find out where the hotspots are. I have a much more complex
-// FIXME version of the same test in Haskell and it finishes in a few seconds,
-// FIXME even in GHCi (the interpreter).
 [<Fact>]
 let ``greedy traversal with a predicate yields the perfect minimal shrink``() =
     Property.check <| property {