Types.fs

module Persimmon.Types

type StoppedCause =
  | Skipped of string
  | Violated of string
  | Error of exn

type AssertionResult<'T> =
  | Passed of 'T
  | Stopped of NonEmptyList<StoppedCause>

module AssertionResult =
  let map f = function
  | Passed x -> Passed (f x)
  | Stopped causes -> Stopped causes

type ITestMarker = interface end

type Context = {
  Name: string
  Children: ITestMarker list
}
with
  interface ITestMarker

type TestInfo<'T> = {
  Name: string
  Parameters: obj list
  BodyOrResult: 'T
}

type UnexecutedTest<'T> = unit -> AssertionResult<'T>
type ExecutedTest<'T> = AssertionResult<'T>

type Test<'T> =
  | Unexecuted of TestInfo<UnexecutedTest<'T>>
  | Executed of TestInfo<ExecutedTest<'T>>
with
  member this.FullName =
    let (Unexecuted { Name = name; Parameters = ps } | Executed { Name = name; Parameters = ps }) = this
    if ps.IsEmpty then name
    else name + "(" + (String.concat ", " (ps |> List.map string)) + ")"

  member this.BoxTypeParam () =
    match this with
    | Unexecuted info -> Unexecuted { Name = info.Name; Parameters = info.Parameters; BodyOrResult = fun () -> info.BodyOrResult () |> AssertionResult.map box }
    | Executed info -> Executed { Name = info.Name; Parameters = info.Parameters; BodyOrResult = info.BodyOrResult |> AssertionResult.map box }

  interface ITestMarker

module Test =
  let map f = function
  | Unexecuted info -> Unexecuted { Name = info.Name; Parameters = info.Parameters; BodyOrResult = fun () -> info.BodyOrResult () |> AssertionResult.map f }
  | Executed info -> Executed { Name = info.Name; Parameters = info.Parameters; BodyOrResult = info.BodyOrResult |> AssertionResult.map f }

[<AutoOpen>]
module TestExtension =
  let private conv (x: obj) =
    let typ = x.GetType()
    let m = typ.GetMethod("BoxTypeParam")
    m.Invoke(x, [||]) :?> Test<obj>

  type ITestMarker with
    member this.Match<'T>(f, g) : 'T =
      match this with
      | :? Context as c -> f c
      | self when self.GetType().GetGenericTypeDefinition() = typedefof<Test<_>> ->
          g (conv self)
      | _ ->
          failwithf "%s is not supported type." (this.GetType().FullName)

  let (|Context|Test|) (test: ITestMarker) =
    test.Match((fun c -> Context c), (fun t -> Test t))

let context name children =
  { Name = name; Children = children } :> ITestMarker