diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 2fbb8570..7263cc47 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -4,7 +4,7 @@ open FSharpx.Collections open System type Journal = - | Journal of List + | Journal of LazyList type Result<'a> = | Failure @@ -39,26 +39,23 @@ module private Tuple = [] module Journal = - let ofList (xs : List) : Journal = + let ofList (xs : LazyList) : Journal = Journal xs let toList (Journal xs : Journal) : List = - 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 -> List) (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 [] module Result = @@ -263,8 +260,8 @@ module Property = failure [] - let counterexample (msg : string) : Property = - Gen.constant (Journal.singleton msg, Success ()) |> ofGen + let counterexample (msg : unit -> string) : Property = + Gen.constant (Journal.delayedSingleton msg, Success ()) |> ofGen let private mapGen (f : Gen> -> Gen>) @@ -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 [] @@ -460,7 +457,7 @@ module PropertyBuilder = [] member __.Counterexample(m : Property<'a>, [] 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 [] diff --git a/src/Hedgehog/Script.fsx b/src/Hedgehog/Script.fsx index cbc36743..53ef5c16 100644 --- 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 index 32d8e673..565ad4c9 100644 --- a/tests/Hedgehog.Tests/MinimalTests.fs +++ b/tests/Hedgehog.Tests/MinimalTests.fs @@ -62,10 +62,6 @@ let rec genExp : Gen = 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). [] let ``greedy traversal with a predicate yields the perfect minimal shrink``() = Property.check <| property {