From 678ef8be94e96834c339560153e4aa481f905ddf Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Tue, 8 Dec 2020 23:21:20 +0000 Subject: [PATCH 1/8] Split Property.fs across multiple files --- src/Hedgehog/Hedgehog.fsproj | 4 + src/Hedgehog/Journal.fs | 24 ++++ src/Hedgehog/Linq/Property.fs | 8 +- src/Hedgehog/Outcome.fs | 40 ++++++ src/Hedgehog/Property.fs | 242 +++------------------------------- src/Hedgehog/Report.fs | 106 +++++++++++++++ src/Hedgehog/Shrink.fs | 2 - src/Hedgehog/Tuple.fs | 7 + 8 files changed, 201 insertions(+), 232 deletions(-) create mode 100644 src/Hedgehog/Journal.fs create mode 100644 src/Hedgehog/Outcome.fs create mode 100644 src/Hedgehog/Report.fs create mode 100644 src/Hedgehog/Tuple.fs diff --git a/src/Hedgehog/Hedgehog.fsproj b/src/Hedgehog/Hedgehog.fsproj index da5d0386..03e188c1 100644 --- a/src/Hedgehog/Hedgehog.fsproj +++ b/src/Hedgehog/Hedgehog.fsproj @@ -32,6 +32,10 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/tutorial.md + + + + diff --git a/src/Hedgehog/Journal.fs b/src/Hedgehog/Journal.fs new file mode 100644 index 00000000..0d9a6edf --- /dev/null +++ b/src/Hedgehog/Journal.fs @@ -0,0 +1,24 @@ +namespace Hedgehog + +[] +type Journal = + | Journal of seq string> + +module Journal = + let ofList (xs : seq string>) : Journal = + Journal xs + + let toList (Journal xs : Journal) : List = + Seq.toList <| Seq.map (fun f -> f ()) xs + + let empty : Journal = + Seq.empty |> ofList + + let singleton (x : string) : Journal = + Seq.singleton (fun () -> x) |> ofList + + let delayedSingleton (x : unit -> string) : Journal = + Seq.singleton x |> ofList + + let append (Journal xs) (Journal ys) : Journal = + Seq.append xs ys |> ofList diff --git a/src/Hedgehog/Linq/Property.fs b/src/Hedgehog/Linq/Property.fs index e0c9c065..6d61d538 100644 --- a/src/Hedgehog/Linq/Property.fs +++ b/src/Hedgehog/Linq/Property.fs @@ -23,11 +23,11 @@ type Property = private Property of Property with Property.ofBool value |> Property - static member FromGen (gen : Gen>) : Property<'T> = + static member FromGen (gen : Gen>) : Property<'T> = Property.ofGen gen - static member FromResult (result : Result<'T>) : Property<'T> = - Property.ofResult result + static member FromOutcome (result : Outcome<'T>) : Property<'T> = + Property.ofOutcome result static member FromThrowing (throwingFunc : Action<'T>, arg : 'T) : Property = Property.ofThrowing throwingFunc.Invoke arg @@ -54,7 +54,7 @@ type Property = private Property of Property with type PropertyExtensions private () = [] - static member ToGen (property : Property<'T>) : Gen> = + static member ToGen (property : Property<'T>) : Gen> = Property.toGen property [] diff --git a/src/Hedgehog/Outcome.fs b/src/Hedgehog/Outcome.fs new file mode 100644 index 00000000..2826ab5b --- /dev/null +++ b/src/Hedgehog/Outcome.fs @@ -0,0 +1,40 @@ +namespace Hedgehog + +type Outcome<'a> = + | Failure + | Discard + | Success of 'a + +module Outcome = + [] + let map (f : 'a -> 'b) (result : Outcome<'a>) : Outcome<'b> = + match result with + | Failure -> + Failure + | Discard -> + Discard + | Success x -> + Success (f x) + + [] + let filter (f : 'a -> bool) (result : Outcome<'a>) : Outcome<'a> = + match result with + | Failure -> + Failure + | Discard -> + Discard + | Success x -> + if f x then + Success x + else + Discard + + [] + let isFailure (result : Outcome<'a>) : bool = + match result with + | Failure -> + true + | Discard -> + false + | Success _ -> + false diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 6d208e17..677cb202 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -2,224 +2,16 @@ open System -[] -type Journal = - | Journal of seq string> - -type Result<'a> = - | Failure - | Discard - | Success of 'a - [] type Property<'a> = - | Property of Gen> - -[] type tests -[] type discards -[] type shrinks - -type FailureReport = { - Size : Size - Seed : Seed - Shrinks : int - Journal : Journal - RenderRecheck : bool -} - -type Status = - | Failed of FailureReport - | GaveUp - | OK - -type Report = { - Tests : int - Discards : int - Status : Status -} - -[] -module private Tuple = - let first (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = - f x, y - - let second (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = - x, f y - -[] -module Journal = - let ofList (xs : seq string>) : Journal = - Journal xs - - let toList (Journal xs : Journal) : List = - xs - |> Seq.map (fun f -> f ()) - |> Seq.toList - - let empty : Journal = - Seq.empty |> ofList - - let singleton (x : string) : Journal = - Seq.singleton (fun () -> x) |> ofList - - let delayedSingleton (x : unit -> string) : Journal = - Seq.singleton x |> ofList - - let append (Journal xs) (Journal ys) : Journal = - Seq.append xs ys |> ofList - -[] -module Result = - [] - let map (f : 'a -> 'b) (r : Result<'a>) : Result<'b> = - match r with - | Failure -> - Failure - | Discard -> - Discard - | Success x -> - Success (f x) - - [] - let filter (f : 'a -> bool) (r : Result<'a>) : Result<'a> = - match r with - | Failure -> - Failure - | Discard -> - Discard - | Success x -> - if f x then - Success x - else - Discard - - [] - let isFailure (x : Result<'a>) : bool = - match x with - | Failure -> - true - | Discard -> - false - | Success _ -> - false - -[] -module private Pretty = - open System.Text - - let private renderTests : int -> string = function - | 1 -> - "1 test" - | n -> - sprintf "%d tests" n - - let private renderDiscards : int -> string = function - | 1 -> - "1 discard" - | n -> - sprintf "%d discards" n - - let private renderAndDiscards : int -> string = function - | 0 -> - "" - | 1 -> - " and 1 discard" - | n -> - sprintf " and %d discards" n - - let private renderAndShrinks : int -> string = function - | 0 -> - "" - | 1 -> - " and 1 shrink" - | n -> - sprintf " and %d shrinks" n - - let private append (sb : StringBuilder) (msg : string) : unit = - sb.AppendLine msg |> ignore - - let private renderf (sb : StringBuilder) (fmt : Printf.StringFormat<'a, unit>) : 'a = - Printf.ksprintf (sb.AppendLine >> ignore) fmt - - let renderOK (report : Report) : string = - sprintf "+++ OK, passed %s." (renderTests report.Tests) - - let renderGaveUp (report : Report) : string = - sprintf "*** Gave up after %s, passed %s." - (renderDiscards report.Discards) - (renderTests report.Tests) - - let renderFailed (failure : FailureReport) (report : Report) : string = - let sb = StringBuilder () - - renderf sb "*** Failed! Falsifiable (after %s%s%s):" - (renderTests report.Tests) - (renderAndShrinks failure.Shrinks) - (renderAndDiscards report.Discards) - - List.iter (append sb) (Journal.toList failure.Journal) - - if failure.RenderRecheck then - renderf sb "This failure can be reproduced by running:" - renderf sb "> Property.recheck (%d : Size) ({ Value = %A; Gamma = %A }) " - failure.Size - failure.Seed.Value - failure.Seed.Gamma - - sb.ToString (0, sb.Length - 1) // Exclude extra newline. - -[] -type HedgehogException (message : string) = - inherit Exception (message) - -type GaveUpException (report : Report) = - inherit HedgehogException (renderGaveUp report) - - member __.Tests = - report.Tests - -type FailedException (failure : FailureReport, report : Report) = - inherit HedgehogException (renderFailed failure report) - - member __.Tests = - report.Tests - - member __.Discards = - report.Discards - - member __.Shrinks = - failure.Shrinks - - member __.Journal = - failure.Journal - -[] -module Report = - - let render (report : Report) : string = - match report.Status with - | OK -> - renderOK report - | GaveUp -> - renderGaveUp report - | Failed failure -> - renderFailed failure report - - let tryRaise (report : Report) : unit = - match report.Status with - | OK -> - () - | GaveUp -> - raise (GaveUpException (report)) - | Failed failure -> - raise (FailedException (failure, report)) + | Property of Gen> module Property = - let ofGen (x : Gen>) : Property<'a> = + let ofGen (x : Gen>) : Property<'a> = Property x - let toGen (Property x : Property<'a>) : Gen> = + let toGen (Property x : Property<'a>) : Gen> = x let tryFinally (m : Property<'a>) (after : unit -> unit) : Property<'a> = @@ -243,21 +35,19 @@ module Property = x.Dispose ()) let filter (p : 'a -> bool) (m : Property<'a>) : Property<'a> = - toGen m - |> Gen.map (second (Result.filter p)) - |> ofGen + Gen.map (Tuple.mapSecond <| Outcome.filter p) (toGen m) |> ofGen - let ofResult (x : Result<'a>) : Property<'a> = + let ofOutcome (x : Outcome<'a>) : Property<'a> = (Journal.empty, x) |> Gen.constant |> ofGen let failure : Property = - Failure |> ofResult + Failure |> ofOutcome let discard : Property = - Discard |> ofResult + Discard |> ofOutcome let success (x : 'a) : Property<'a> = - Success x |> ofResult + Success x |> ofOutcome let ofBool (x : bool) : Property = if x then @@ -269,24 +59,24 @@ module Property = Gen.constant (Journal.delayedSingleton msg, Success ()) |> ofGen let private mapGen - (f : Gen> -> Gen>) + (f : Gen> -> Gen>) (x : Property<'a>) : Property<'b> = toGen x |> f |> ofGen let map (f : 'a -> 'b) (x : Property<'a>) : Property<'b> = - (mapGen << Gen.map << second << Result.map) f x + (mapGen << Gen.map << Tuple.mapSecond << Outcome.map) f x let private bindGen - (m : Gen>) - (k : 'a -> Gen>) : Gen> = - Gen.bind m (fun (journal, result) -> + (m : Gen>) + (k : 'a -> Gen>) : Gen> = + Gen.bind m <| fun (journal, result) -> match result with | Failure -> Gen.constant (journal, Failure) | Discard -> Gen.constant (journal, Discard) | Success x -> - Gen.map (first (Journal.append journal)) (k x)) + Gen.map (Tuple.mapFirst (Journal.append journal)) (k x) let bind (m : Property<'a>) (k : 'a -> Property<'b>) : Property<'b> = bindGen (toGen m) (toGen << k) |> ofGen @@ -309,11 +99,11 @@ module Property = (renderRecheck : bool) (size : Size) (seed : Seed) - (Node ((journal, x), xs) : Tree>) + (Node ((journal, x), xs) : Tree>) (nshrinks : int) : Status = match x with | Failure -> - match Seq.tryFind (Result.isFailure << snd << Tree.outcome) xs with + match Seq.tryFind (Outcome.isFailure << snd << Tree.outcome) xs with | None -> Failed { Size = size; Seed = seed; Shrinks = nshrinks; Journal = journal; RenderRecheck = renderRecheck } | Some tree -> diff --git a/src/Hedgehog/Report.fs b/src/Hedgehog/Report.fs new file mode 100644 index 00000000..18478057 --- /dev/null +++ b/src/Hedgehog/Report.fs @@ -0,0 +1,106 @@ +namespace Hedgehog + +[] type tests +[] type discards +[] type shrinks + +type FailureData = { + Size : Size + Seed : Seed + Shrinks : int + Journal : Journal + RenderRecheck : bool +} + +type Status = + | Failed of FailureData + | GaveUp + | OK + +type Report = { + Tests : int + Discards : int + Status : Status +} + +module Report = + open System + open System.Text + + let private renderTests : int -> string = function + | 1 -> + "1 test" + | n -> + sprintf "%d tests" n + + let private renderDiscards : int -> string = function + | 1 -> + "1 discard" + | n -> + sprintf "%d discards" n + + let private renderAndDiscards : int -> string = function + | 0 -> + "" + | 1 -> + " and 1 discard" + | n -> + sprintf " and %d discards" n + + let private renderAndShrinks : int -> string = function + | 0 -> + "" + | 1 -> + " and 1 shrink" + | n -> + sprintf " and %d shrinks" n + + let private append (sb : StringBuilder) (msg : string) : unit = + sb.AppendLine msg |> ignore + + let private renderf (sb : StringBuilder) (fmt : Printf.StringFormat<'a, unit>) : 'a = + Printf.ksprintf (append sb) fmt + + let private renderOK (report : Report) : string = + sprintf "+++ OK, passed %s." (renderTests report.Tests) + + let private renderGaveUp (report : Report) : string = + sprintf "*** Gave up after %s, passed %s." + (renderDiscards report.Discards) + (renderTests report.Tests) + + let private renderFailed (failure : FailureData) (report : Report) : string = + let sb = StringBuilder () + + renderf sb "*** Failed! Falsifiable (after %s%s%s):" + (renderTests report.Tests) + (renderAndShrinks failure.Shrinks) + (renderAndDiscards report.Discards) + + List.iter (append sb) (Journal.toList failure.Journal) + + if failure.RenderRecheck then + renderf sb "This failure can be reproduced by running:" + renderf sb "> Property.recheck (%d : Size) ({ Value = %A; Gamma = %A }) " + failure.Size + failure.Seed.Value + failure.Seed.Gamma + + sb.ToString (0, sb.Length - 1) // Exclude extra newline. + + let render (report : Report) : string = + match report.Status with + | OK -> + renderOK report + | GaveUp -> + renderGaveUp report + | Failed failure -> + renderFailed failure report + + let tryRaise (report : Report) : unit = + match report.Status with + | OK -> + () + | GaveUp + | Failed _ -> + raise <| Exception(render report) diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index 398c48b7..e89c80f0 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -1,7 +1,5 @@ namespace Hedgehog -open System - module Seq = let cons (x : 'a) (xs : seq<'a>) : seq<'a> = seq { diff --git a/src/Hedgehog/Tuple.fs b/src/Hedgehog/Tuple.fs new file mode 100644 index 00000000..1c3033e7 --- /dev/null +++ b/src/Hedgehog/Tuple.fs @@ -0,0 +1,7 @@ +module private Hedgehog.Tuple + +let mapFirst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = + f x, y + +let mapSecond (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = + x, f y From c5c5a5c85e83ab1fc7e434df1a9d61b3313bb964 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 9 Dec 2020 17:05:13 +0000 Subject: [PATCH 2/8] Add catamorph function for Outcome --- src/Hedgehog/Hedgehog.fsproj | 1 + src/Hedgehog/Outcome.fs | 46 ++++++++++++++++++++---------------- src/Hedgehog/Util.fs | 5 ++++ 3 files changed, 31 insertions(+), 21 deletions(-) create mode 100644 src/Hedgehog/Util.fs diff --git a/src/Hedgehog/Hedgehog.fsproj b/src/Hedgehog/Hedgehog.fsproj index 03e188c1..fc1a6824 100644 --- a/src/Hedgehog/Hedgehog.fsproj +++ b/src/Hedgehog/Hedgehog.fsproj @@ -25,6 +25,7 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/tutorial.md + diff --git a/src/Hedgehog/Outcome.fs b/src/Hedgehog/Outcome.fs index 2826ab5b..423e0104 100644 --- a/src/Hedgehog/Outcome.fs +++ b/src/Hedgehog/Outcome.fs @@ -6,35 +6,39 @@ type Outcome<'a> = | Success of 'a module Outcome = - [] - let map (f : 'a -> 'b) (result : Outcome<'a>) : Outcome<'b> = + + let cata result failure discard success = match result with | Failure -> - Failure + failure() | Discard -> - Discard - | Success x -> - Success (f x) + discard() + | Success(x) -> + success(x) + + [] + let map (f : 'a -> 'b) (result : Outcome<'a>) : Outcome<'b> = + cata result + <| always Failure + <| always Discard + <| (f >> Success) [] let filter (f : 'a -> bool) (result : Outcome<'a>) : Outcome<'a> = - match result with - | Failure -> - Failure - | Discard -> - Discard - | Success x -> + let successOrDiscard x = if f x then - Success x + Success(x) else - Discard + Discard + + cata result + <| always Failure + <| always Discard + <| successOrDiscard [] let isFailure (result : Outcome<'a>) : bool = - match result with - | Failure -> - true - | Discard -> - false - | Success _ -> - false + cata result + <| always true + <| always false + <| always false diff --git a/src/Hedgehog/Util.fs b/src/Hedgehog/Util.fs new file mode 100644 index 00000000..1c35d5c5 --- /dev/null +++ b/src/Hedgehog/Util.fs @@ -0,0 +1,5 @@ +[] +module private Hedgehog.Util + +let inline always (a : 'a) (_ : 'b) : 'a = + a From 82b4440e0dbdba02bf02057890190995fcb19c92 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 9 Dec 2020 17:15:58 +0000 Subject: [PATCH 3/8] Make journal changes --- src/Hedgehog/Journal.fs | 31 +++++++++++++++++++++---------- src/Hedgehog/Property.fs | 4 ++-- src/Hedgehog/Report.fs | 2 +- 3 files changed, 24 insertions(+), 13 deletions(-) diff --git a/src/Hedgehog/Journal.fs b/src/Hedgehog/Journal.fs index 0d9a6edf..2fa4c283 100644 --- a/src/Hedgehog/Journal.fs +++ b/src/Hedgehog/Journal.fs @@ -5,20 +5,31 @@ type Journal = | Journal of seq string> module Journal = - let ofList (xs : seq string>) : Journal = - Journal xs - let toList (Journal xs : Journal) : List = - Seq.toList <| Seq.map (fun f -> f ()) xs + /// Creates a journal from a sequence of entries. + let ofSeq (entries : seq string>) : Journal = + Journal entries + /// Evaluates a single entry, returning it's message. + let private evalEntry (f : unit -> string) : string = + f() + + /// Evaluates all entries in the journal, returning their messages. + let eval (Journal entries : Journal) : seq = + Seq.map evalEntry entries + + /// Represents a journal with no entries. let empty : Journal = - Seq.empty |> ofList + ofSeq [] - let singleton (x : string) : Journal = - Seq.singleton (fun () -> x) |> ofList + /// Creates a single entry journal from a given message. + let singletonMessage (message : string) : Journal = + ofSeq [ fun () -> message ] - let delayedSingleton (x : unit -> string) : Journal = - Seq.singleton x |> ofList + /// Creates a single entry journal from a given entry. + let singleton (entry : unit -> string) : Journal = + ofSeq [ entry ] + /// Creates a journal composed of entries from two journals. let append (Journal xs) (Journal ys) : Journal = - Seq.append xs ys |> ofList + ofSeq <| Seq.append xs ys diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 677cb202..b8d52560 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -56,7 +56,7 @@ module Property = failure let counterexample (msg : unit -> string) : Property = - Gen.constant (Journal.delayedSingleton msg, Success ()) |> ofGen + Gen.constant (Journal.singleton msg, Success ()) |> ofGen let private mapGen (f : Gen> -> Gen>) @@ -83,7 +83,7 @@ module Property = let forAll (gen : Gen<'a>) (k : 'a -> Property<'b>) : Property<'b> = let handle (e : exn) = - Gen.constant (Journal.singleton (string e), Failure) |> ofGen + Gen.constant (Journal.singletonMessage (string e), Failure) |> ofGen let prepend (x : 'a) = bind (counterexample (fun () -> sprintf "%A" x)) (fun _ -> try k x with e -> handle e) |> toGen Gen.bind gen prepend |> ofGen diff --git a/src/Hedgehog/Report.fs b/src/Hedgehog/Report.fs index 18478057..2aa3db0a 100644 --- a/src/Hedgehog/Report.fs +++ b/src/Hedgehog/Report.fs @@ -77,7 +77,7 @@ module Report = (renderAndShrinks failure.Shrinks) (renderAndDiscards report.Discards) - List.iter (append sb) (Journal.toList failure.Journal) + Seq.iter (append sb) (Journal.eval failure.Journal) if failure.RenderRecheck then renderf sb "This failure can be reproduced by running:" From 0c339763612d3cc25e3dd2624a1f5fa110db88a6 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 9 Dec 2020 10:33:30 -0700 Subject: [PATCH 4/8] Add GenTuple --- src/Hedgehog/Property.fs | 6 +++--- src/Hedgehog/Report.fs | 15 ++++++++------- src/Hedgehog/Tuple.fs | 22 +++++++++++++++++----- 3 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index b8d52560..2df5ad7f 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -35,7 +35,7 @@ module Property = x.Dispose ()) let filter (p : 'a -> bool) (m : Property<'a>) : Property<'a> = - Gen.map (Tuple.mapSecond <| Outcome.filter p) (toGen m) |> ofGen + GenTuple.mapSecond (Outcome.filter p) (toGen m) |> ofGen let ofOutcome (x : Outcome<'a>) : Property<'a> = (Journal.empty, x) |> Gen.constant |> ofGen @@ -64,7 +64,7 @@ module Property = toGen x |> f |> ofGen let map (f : 'a -> 'b) (x : Property<'a>) : Property<'b> = - (mapGen << Gen.map << Tuple.mapSecond << Outcome.map) f x + (mapGen << GenTuple.mapSecond << Outcome.map) f x let private bindGen (m : Gen>) @@ -76,7 +76,7 @@ module Property = | Discard -> Gen.constant (journal, Discard) | Success x -> - Gen.map (Tuple.mapFirst (Journal.append journal)) (k x) + GenTuple.mapFirst (Journal.append journal) (k x) let bind (m : Property<'a>) (k : 'a -> Property<'b>) : Property<'b> = bindGen (toGen m) (toGen << k) |> ofGen diff --git a/src/Hedgehog/Report.fs b/src/Hedgehog/Report.fs index 2aa3db0a..9ce264e7 100644 --- a/src/Hedgehog/Report.fs +++ b/src/Hedgehog/Report.fs @@ -24,6 +24,7 @@ type Report = { } module Report = + open System open System.Text @@ -55,11 +56,11 @@ module Report = | n -> sprintf " and %d shrinks" n - let private append (sb : StringBuilder) (msg : string) : unit = + let private appendLine (sb : StringBuilder) (msg : string) : unit = sb.AppendLine msg |> ignore - let private renderf (sb : StringBuilder) (fmt : Printf.StringFormat<'a, unit>) : 'a = - Printf.ksprintf (append sb) fmt + let private appendLinef (sb : StringBuilder) (fmt : Printf.StringFormat<'a, unit>) : 'a = + Printf.ksprintf (appendLine sb) fmt let private renderOK (report : Report) : string = sprintf "+++ OK, passed %s." (renderTests report.Tests) @@ -72,16 +73,16 @@ module Report = let private renderFailed (failure : FailureData) (report : Report) : string = let sb = StringBuilder () - renderf sb "*** Failed! Falsifiable (after %s%s%s):" + appendLinef sb "*** Failed! Falsifiable (after %s%s%s):" (renderTests report.Tests) (renderAndShrinks failure.Shrinks) (renderAndDiscards report.Discards) - Seq.iter (append sb) (Journal.eval failure.Journal) + Seq.iter (appendLine sb) (Journal.eval failure.Journal) if failure.RenderRecheck then - renderf sb "This failure can be reproduced by running:" - renderf sb "> Property.recheck (%d : Size) ({ Value = %A; Gamma = %A }) " + appendLinef sb "This failure can be reproduced by running:" + appendLinef sb "> Property.recheck (%d : Size) ({ Value = %A; Gamma = %A }) " failure.Size failure.Seed.Value failure.Seed.Gamma diff --git a/src/Hedgehog/Tuple.fs b/src/Hedgehog/Tuple.fs index 1c3033e7..d18b7914 100644 --- a/src/Hedgehog/Tuple.fs +++ b/src/Hedgehog/Tuple.fs @@ -1,7 +1,19 @@ -module private Hedgehog.Tuple +namespace Hedgehog -let mapFirst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = - f x, y +module private Tuple = -let mapSecond (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = - x, f y + let mapFirst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = + f x, y + + let mapSecond (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = + x, f y + + +module private GenTuple = + + let mapFirst (f : 'a -> 'c) (gen : Gen<'a * 'b>) : Gen<'c * 'b> = + Gen.map (Tuple.mapFirst f) gen + + + let mapSecond (f : 'b -> 'c) (gen : Gen<'a * 'b>) : Gen<'a * 'c> = + Gen.map (Tuple.mapSecond f) gen From b9a317517326e6ffc1c416906d26260133875415 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Sun, 10 Jan 2021 23:52:59 +0000 Subject: [PATCH 5/8] Rename tuple methods --- src/Hedgehog/Property.fs | 6 +++--- src/Hedgehog/Tuple.fs | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 2df5ad7f..e59e5a83 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -35,7 +35,7 @@ module Property = x.Dispose ()) let filter (p : 'a -> bool) (m : Property<'a>) : Property<'a> = - GenTuple.mapSecond (Outcome.filter p) (toGen m) |> ofGen + GenTuple.mapSnd (Outcome.filter p) (toGen m) |> ofGen let ofOutcome (x : Outcome<'a>) : Property<'a> = (Journal.empty, x) |> Gen.constant |> ofGen @@ -64,7 +64,7 @@ module Property = toGen x |> f |> ofGen let map (f : 'a -> 'b) (x : Property<'a>) : Property<'b> = - (mapGen << GenTuple.mapSecond << Outcome.map) f x + (mapGen << GenTuple.mapSnd << Outcome.map) f x let private bindGen (m : Gen>) @@ -76,7 +76,7 @@ module Property = | Discard -> Gen.constant (journal, Discard) | Success x -> - GenTuple.mapFirst (Journal.append journal) (k x) + GenTuple.mapFst (Journal.append journal) (k x) let bind (m : Property<'a>) (k : 'a -> Property<'b>) : Property<'b> = bindGen (toGen m) (toGen << k) |> ofGen diff --git a/src/Hedgehog/Tuple.fs b/src/Hedgehog/Tuple.fs index d18b7914..645fdb9b 100644 --- a/src/Hedgehog/Tuple.fs +++ b/src/Hedgehog/Tuple.fs @@ -2,18 +2,18 @@ namespace Hedgehog module private Tuple = - let mapFirst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = + let mapFst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = f x, y - let mapSecond (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = + let mapSnd (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = x, f y module private GenTuple = - let mapFirst (f : 'a -> 'c) (gen : Gen<'a * 'b>) : Gen<'c * 'b> = - Gen.map (Tuple.mapFirst f) gen + let mapFst (f : 'a -> 'c) (gen : Gen<'a * 'b>) : Gen<'c * 'b> = + Gen.map (Tuple.mapFst f) gen - let mapSecond (f : 'b -> 'c) (gen : Gen<'a * 'b>) : Gen<'a * 'c> = - Gen.map (Tuple.mapSecond f) gen + let mapSnd (f : 'b -> 'c) (gen : Gen<'a * 'b>) : Gen<'a * 'c> = + Gen.map (Tuple.mapSnd f) gen From 07694529965cba6c1ccc929b77ab05709f98ef2c Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 20 Jan 2021 01:03:40 +0000 Subject: [PATCH 6/8] Combine Util.fs and AutoOpen.fs --- src/Hedgehog/AutoOpen.fs | 6 +++++- src/Hedgehog/Hedgehog.fsproj | 1 - src/Hedgehog/Util.fs | 5 ----- 3 files changed, 5 insertions(+), 7 deletions(-) delete mode 100644 src/Hedgehog/Util.fs diff --git a/src/Hedgehog/AutoOpen.fs b/src/Hedgehog/AutoOpen.fs index 12c5c640..f45e4bea 100644 --- a/src/Hedgehog/AutoOpen.fs +++ b/src/Hedgehog/AutoOpen.fs @@ -1,4 +1,8 @@ [] module internal AutoOpen - let flip f b a = f a b +let inline always (a : 'a) (_ : 'b) : 'a = + a + +let inline flip (f : 'a -> 'b -> 'c) (b : 'b) (a : 'a) : 'c = + f a b diff --git a/src/Hedgehog/Hedgehog.fsproj b/src/Hedgehog/Hedgehog.fsproj index fc1a6824..03e188c1 100644 --- a/src/Hedgehog/Hedgehog.fsproj +++ b/src/Hedgehog/Hedgehog.fsproj @@ -25,7 +25,6 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/tutorial.md - diff --git a/src/Hedgehog/Util.fs b/src/Hedgehog/Util.fs deleted file mode 100644 index 1c35d5c5..00000000 --- a/src/Hedgehog/Util.fs +++ /dev/null @@ -1,5 +0,0 @@ -[] -module private Hedgehog.Util - -let inline always (a : 'a) (_ : 'b) : 'a = - a From 44bb6fc62fb14e9677871a845cc8db208195362b Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 20 Jan 2021 16:42:24 +0000 Subject: [PATCH 7/8] Remove backwards pipes --- src/Hedgehog/Journal.fs | 3 ++- src/Hedgehog/Outcome.fs | 18 +++++++++--------- src/Hedgehog/Property.fs | 4 ++-- src/Hedgehog/Report.fs | 2 +- 4 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Hedgehog/Journal.fs b/src/Hedgehog/Journal.fs index 2fa4c283..b183a15e 100644 --- a/src/Hedgehog/Journal.fs +++ b/src/Hedgehog/Journal.fs @@ -32,4 +32,5 @@ module Journal = /// Creates a journal composed of entries from two journals. let append (Journal xs) (Journal ys) : Journal = - ofSeq <| Seq.append xs ys + Seq.append xs ys + |> ofSeq diff --git a/src/Hedgehog/Outcome.fs b/src/Hedgehog/Outcome.fs index 423e0104..345857bf 100644 --- a/src/Hedgehog/Outcome.fs +++ b/src/Hedgehog/Outcome.fs @@ -19,9 +19,9 @@ module Outcome = [] let map (f : 'a -> 'b) (result : Outcome<'a>) : Outcome<'b> = cata result - <| always Failure - <| always Discard - <| (f >> Success) + (always Failure) + (always Discard) + (f >> Success) [] let filter (f : 'a -> bool) (result : Outcome<'a>) : Outcome<'a> = @@ -32,13 +32,13 @@ module Outcome = Discard cata result - <| always Failure - <| always Discard - <| successOrDiscard + (always Failure) + (always Discard) + successOrDiscard [] let isFailure (result : Outcome<'a>) : bool = cata result - <| always true - <| always false - <| always false + (always true) + (always false) + (always false) diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index e59e5a83..ff9686a9 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -69,14 +69,14 @@ module Property = let private bindGen (m : Gen>) (k : 'a -> Gen>) : Gen> = - Gen.bind m <| fun (journal, result) -> + Gen.bind m (fun (journal, result) -> match result with | Failure -> Gen.constant (journal, Failure) | Discard -> Gen.constant (journal, Discard) | Success x -> - GenTuple.mapFst (Journal.append journal) (k x) + GenTuple.mapFst (Journal.append journal) (k x)) let bind (m : Property<'a>) (k : 'a -> Property<'b>) : Property<'b> = bindGen (toGen m) (toGen << k) |> ofGen diff --git a/src/Hedgehog/Report.fs b/src/Hedgehog/Report.fs index 9ce264e7..0b285230 100644 --- a/src/Hedgehog/Report.fs +++ b/src/Hedgehog/Report.fs @@ -104,4 +104,4 @@ module Report = () | GaveUp | Failed _ -> - raise <| Exception(render report) + raise (Exception(render report)) From 0904a5215112f2d81b78556ef528dc02ff067bf2 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Wed, 20 Jan 2021 16:54:06 +0000 Subject: [PATCH 8/8] Add missing script references --- src/Hedgehog/Script.fsx | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Hedgehog/Script.fsx b/src/Hedgehog/Script.fsx index d7bea053..18a1e8f9 100644 --- a/src/Hedgehog/Script.fsx +++ b/src/Hedgehog/Script.fsx @@ -1,11 +1,16 @@ #if INTERACTIVE -#load "Numeric.fs" +#load "AutoOpen.fs" + "Numeric.fs" "Seed.fs" "Tree.fs" "Range.fs" "Random.fs" "Shrink.fs" "Gen.fs" + "Journal.fs" + "Tuple.fs" + "Outcome.fs" + "Report.fs" "Property.fs" #endif