functional test

fstest.fs

module FsTest =
  type TestContext = TC of string list

  [<RequireQualifiedAccess>]
  type TestFailure =
    | Exception of exn
    | Assertion of string

  [<RequireQualifiedAccess>]
  type TestFailureTree =
    | Empty
    | Leaf    of  TestContext*TestFailure
    | Fork    of  TestFailureTree*TestFailureTree

    static member Join l r =
      match l, r with
      | TestFailureTree.Empty , _                     -> r
      | _                     , TestFailureTree.Empty -> l
      | _                     , _                     -> TestFailureTree.Fork (l, r)

  type [<Struct>] TestResult<'T> = TR of ValueOption<'T>*TestFailureTree
  type [<Struct>] Test<'T> = T of (TestContext -> TestResult<'T>)

  module Test =
    let value v : Test<_> =
      T <| fun tc ->
        TR (ValueSome v, TestFailureTree.Empty)

    let abortWith ft : Test<_>=
      T <| fun tc ->
        TR (ValueNone, TestFailureTree.Empty)

    let bind (T t) uf : Test<'U> =
      T <| fun tc ->
        match t tc with
        | TR (ValueNone, tft) ->
          TR (ValueNone, tft)
        | TR (ValueSome tv, tft) ->
          let (T u) = uf tv
          let (TR (uv, uft)) = u tc
          TR (uv, TestFailureTree.Join tft uft)

    let combine (T t) (T u) : Test<'U> =
      T <| fun tc ->
        match t tc with
        | TR (ValueNone, tft) ->
          TR (ValueNone, tft)
        | TR (ValueSome _, tft) ->
          let (TR (uv, uft)) = u tc
          TR (uv, TestFailureTree.Join tft uft)

    let named name (T t) : Test<_> =
      T <| fun (TC names) ->
        let tc = TC (name::names)
        t tc

    let all ts : Test<_> =
      T <| fun tc ->
        let folder struct (vs, ft) (T t) =
          match t tc with
          | TR (ValueNone, tft) ->
            struct (vs, TestFailureTree.Join ft tft)
          | TR (ValueSome tv, tft) ->
            struct (tv::vs, TestFailureTree.Join ft tft)
        let struct (vs, ft) =
          ts
          |> Array.fold folder (struct ([], TestFailureTree.Empty))
        let vs = vs |> List.toArray
        if vs.Length = ts.Length then
          TR (ValueSome vs, ft)
        else
          TR (ValueNone, ft)

    let run (T t) : TestResult<_> =
      t (TC [])

    type Builder () =
      member x.Bind       (t, uf) = bind    t uf
      member x.Combine    (t, u)  = combine t u
      member x.Return     v       = value v
      member x.ReturnFrom t       = t : Test<_>
      member x.Zero       ()      = value ()

    let ensure : ValueOption<unit> = ValueNone
    let check  : ValueOption<unit> = ValueSome ()

    let equal flavour msg e a =
      T <| fun tc ->
        if e = a then
          TR (ValueSome (), TestFailureTree.Empty)
        else
          let msg = sprintf "%s - %A = %A" msg e a
          TR (flavour, TestFailureTree.Leaf (tc, TestFailure.Assertion msg))

  let test = Test.Builder ()

open FsTest
open Test

[<EntryPoint>]
let main argv =
  let test =
    all <| [|
      named "testIdentity" <| test {
        let e = 1
        let a = 1
        do! equal check "identity must hold (1)" e (a + 0)
        do! equal check "identity must hold (2)" e (0 + a)
      }
      named "testAssociativity" <| test {
        let e = 6
        let a = 1
        let b = 2
        let c = 3
        do! equal check "associativity must hold (1)" e ((a + b) + c)
        do! equal check "associativity must hold (2)" e (a + (b + c))
      }
    |]
  run test |> printfn "%A"
  0