Persimmon.FsCheck.fs

module Persimmon.FsCheck

open Persimmon
open FsCheck
open System.Diagnostics
open FsCheck.Random
open System

type FsCheckConfig = {
  MaxTest : int
  MaxFail : int
  Replay : StdGen option
  StartSize : int
  EndSize : int
  QuietOnSuccess: bool
  Every : int -> list<obj> -> string
  EveryShrink : list<obj> -> string 
  Arbitrary : list<Type>
}
with
  static member Default =
    let defaultConfig = Config.Default
    {
      MaxTest = defaultConfig.MaxTest
      MaxFail = defaultConfig.MaxFail
      Replay = defaultConfig.Replay
      StartSize = defaultConfig.StartSize
      EndSize = defaultConfig.EndSize
      QuietOnSuccess = defaultConfig.QuietOnSuccess
      Every = defaultConfig.Every
      EveryShrink = defaultConfig.EveryShrink
      Arbitrary = defaultConfig.Arbitrary
    }

type PropertyState = {
  FsCheckConfig: FsCheckConfig
  Properties: Property seq
}
with
  static member Default =
    {
      FsCheckConfig = FsCheckConfig.Default
      Properties = Seq.empty
    }

module private Impl =
  exception FsCheckFailException of string

  let runner =
    { new IRunner with
        member __.OnStartFixture(_) = ()
        member __.OnArguments(_, _, _) = ()
        member __.OnShrink(_, _) = ()
        member __.OnFinished(name, result) =
          match result with
          | TestResult.True _ -> ()
          | _ -> raise (FsCheckFailException(Runner.onFinishedToString name result))
    }

  let toConfig (tc: TestCase) (c: FsCheckConfig) =
    {
      MaxTest = c.MaxTest
      MaxFail = c.MaxFail
      Replay = c.Replay
      Name = Option.defaultValue Config.Default.Name tc.Name
      StartSize = c.StartSize
      EndSize = c.EndSize
      QuietOnSuccess = c.QuietOnSuccess
      Every = c.Every
      EveryShrink = c.EveryShrink
      Arbitrary = c.Arbitrary
      Runner = runner
    }

  let run (tc: TestCase) (state: PropertyState) =
    let config = toConfig tc state.FsCheckConfig
    state.Properties
    |> Seq.map (fun prop ->
      try
        Check.One(config, prop)
        Passed()
      with
        | FsCheckFailException e -> NotPassed (None, NotPassedCause.Violated e)
        | _ -> reraise()
    )
    |> Seq.toArray
    |> function
      | [||] -> NonEmptyList.singleton (Passed ())
      | xs -> NonEmptyList.ofSeq xs

type PropertyBuilder(name: string option) =
  new() = PropertyBuilder(None)
  new(name: string) = PropertyBuilder(Some name)

  member __.Yield(()) = PropertyState.Default

  [<CustomOperation("maxTest")>]
  member __.MaxTest(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with MaxTest = value } }

  [<CustomOperation("maxFail")>]
  member __.MaxFail(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with MaxFail = value } }

  [<CustomOperation("replay")>]
  member __.Replay(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with Replay = value } }

  [<CustomOperation("startSize")>]
  member __.StartSize(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with StartSize = value } }

  [<CustomOperation("endSize")>]
  member __.EndSize(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with EndSize = value } }

  [<CustomOperation("quietOnSuccess")>]
  member __.QuietOnSuccess(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with QuietOnSuccess = value } }

  [<CustomOperation("every")>]
  member __.Every(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with Every = value } }

  [<CustomOperation("everyShrink")>]
  member __.EveryShrink(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with EveryShrink = value } }

  [<CustomOperation("arbitrary")>]
  member __.Arbitrary(state: PropertyState, value) = { state with FsCheckConfig = { state.FsCheckConfig with Arbitrary = value } }

  [<CustomOperation("config")>]
  member __.Arbitrary(state: PropertyState, value) = { state with FsCheckConfig = value }

  [<CustomOperation("apply")>]
  member __.Apply(state: PropertyState, testable: 'testable) =
    let properties = seq {
      yield! state.Properties
      yield Prop.ofTestable testable
    }
    { state with Properties = properties }

  member __.Delay(f: unit -> _) = f

  member __.Run(f: unit -> PropertyState) : TestCase<unit> =
    let body (tc: TestCase) = async {
      let watch = Stopwatch.StartNew()
      try
        let state = f()
        let results = Impl.run tc state
        do watch.Stop()
        return Done(tc, results, watch.Elapsed)
      with
        | e ->
          do watch.Stop()
          return Error (tc, [| ExceptionWrapper(e) |], [], watch.Elapsed)
    }
    TestCase.init name [] [] body

[<AutoOpen>]
module Syntax =

  let property (name: string) = PropertyBuilder(name)

  module UseTestNameByReflection =
    let property = PropertyBuilder()

module private Test =
  open Syntax.UseTestNameByReflection

  let t: TestCase<unit> = property {
    apply (Prop.forAll Arb.from<int> (fun _ -> false))
    apply (Prop.forAll Arb.from<string> (fun _ -> true))
    apply (Prop.forAll Arb.from<int list> (fun _ -> false))
  }