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 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..b183a15e --- /dev/null +++ b/src/Hedgehog/Journal.fs @@ -0,0 +1,36 @@ +namespace Hedgehog + +[] +type Journal = + | Journal of seq string> + +module Journal = + + /// 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 = + ofSeq [] + + /// Creates a single entry journal from a given message. + let singletonMessage (message : string) : Journal = + ofSeq [ fun () -> message ] + + /// 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 + |> ofSeq 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..345857bf --- /dev/null +++ b/src/Hedgehog/Outcome.fs @@ -0,0 +1,44 @@ +namespace Hedgehog + +type Outcome<'a> = + | Failure + | Discard + | Success of 'a + +module Outcome = + + let cata result failure discard success = + match result with + | Failure -> + failure() + | Discard -> + 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> = + let successOrDiscard x = + if f x then + Success(x) + else + Discard + + cata result + (always Failure) + (always Discard) + successOrDiscard + + [] + let isFailure (result : Outcome<'a>) : bool = + cata result + (always true) + (always false) + (always false) diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 6d208e17..ff9686a9 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 + GenTuple.mapSnd (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 @@ -266,19 +56,19 @@ 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>) + (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 << GenTuple.mapSnd << Outcome.map) f x let private bindGen - (m : Gen>) - (k : 'a -> Gen>) : Gen> = + (m : Gen>) + (k : 'a -> Gen>) : Gen> = Gen.bind m (fun (journal, result) -> match result with | Failure -> @@ -286,14 +76,14 @@ module Property = | Discard -> Gen.constant (journal, Discard) | Success x -> - Gen.map (first (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 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 @@ -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..0b285230 --- /dev/null +++ b/src/Hedgehog/Report.fs @@ -0,0 +1,107 @@ +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 appendLine (sb : StringBuilder) (msg : string) : unit = + sb.AppendLine msg |> ignore + + 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) + + 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 () + + appendLinef sb "*** Failed! Falsifiable (after %s%s%s):" + (renderTests report.Tests) + (renderAndShrinks failure.Shrinks) + (renderAndDiscards report.Discards) + + Seq.iter (appendLine sb) (Journal.eval failure.Journal) + + if failure.RenderRecheck then + 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 + + 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/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 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..645fdb9b --- /dev/null +++ b/src/Hedgehog/Tuple.fs @@ -0,0 +1,19 @@ +namespace Hedgehog + +module private Tuple = + + let mapFst (f : 'a -> 'c) (x : 'a, y : 'b) : 'c * 'b = + f x, y + + let mapSnd (f : 'b -> 'c) (x : 'a, y : 'b) : 'a * 'c = + x, f y + + +module private GenTuple = + + let mapFst (f : 'a -> 'c) (gen : Gen<'a * 'b>) : Gen<'c * 'b> = + Gen.map (Tuple.mapFst f) gen + + + let mapSnd (f : 'b -> 'c) (gen : Gen<'a * 'b>) : Gen<'a * 'c> = + Gen.map (Tuple.mapSnd f) gen