Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Make Journal store delayed strings, so they are computed on-demand #147

Closed
wants to merge 3 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
29 changes: 13 additions & 16 deletions src/Hedgehog/Property.fs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ open FSharpx.Collections
open System

type Journal =
| Journal of List<string>
| Journal of LazyList<string>

type Result<'a> =
| Failure
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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>>)
Expand Down Expand Up @@ -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")>]
Expand Down Expand Up @@ -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)>]
Expand Down
6 changes: 3 additions & 3 deletions src/Hedgehog/Script.fsx
Original file line number Diff line number Diff line change
Expand Up @@ -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'
Expand All @@ -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
}

Expand Down
4 changes: 0 additions & 4 deletions tests/Hedgehog.Tests/MinimalTests.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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 {
Expand Down