How to Build an Accumulating Either Builder

Question

I want to build an computational expression for either expressions. That is simple enough

type Result<'TSuccess> = 
| Success of 'TSuccess
| Failure of List<string>

type Foo = {
    a: int
    b: string
    c: bool
}

type EitherBuilder () =
    member this.Bind(x, f) = 
        match x with
        | Success s -> f s
        | Failure f -> Failure f

        member this.Return x = Success x

let either = EitherBuilder ()

let Ok = either {
    let! a = Success 1
    let! b = Success "foo"
    let! c = Success true
    return 
        {
             a = a
             b = b
             c = c
        }
}

let fail1 = either {
    let! a = Success 1
    let! b = Failure ["Oh nose!"]
    let! c = Success true
    return 
        {
             a = a
             b = b
             c = c
        }
    } //returns fail1 = Failure ["Oh nose!"]

But in the case of Failures (multiple) I want to accumulate those and return an Failure as below.

let fail2 = either {
    let! a = Success 1
    let! b = Failure ["Oh nose!"]
    let! c = Failure ["God damn it, uncle Bob!"]
    return 
        {
             a = a
             b = b
             c = c
        }
    } //should return fail2 = Failure ["Oh nose!"; "God damn it, uncle Bob!"]

I have an idea on how to do that by rewriting Bind and always returning Success (albeit with some additional structure that signifies the accumulated erors). However if I do this then I am missing the stop signal and I always get back the return value (actually not really as I will run into a runtime exception, but in principle)

Answer 1

As @tomasp is saying one approach is to always provide a value in addition to the failures in order to make bind work properly. This is the approach I have been using when dealing with this subject. I would then change the definition of Result to, for example, this:

type BadCause =
  | Exception of exn
  | Message   of string

type BadTree =
  | Empty
  | Leaf  of BadCause
  | Fork  of BadTree*BadTree

type [<Struct>] Result<'T> = Result of 'T*BadTree

This means that a Result always has a value whether it's good or bad. The value is good iff the BadTree is empty.

The reason I prefer trees over list is that Bind will aggregate two separate results that may have subfailures leading to list concatenations.

Some functions that let us create either good or bad value:

let rreturn     v       = Result (v, Empty)
let rbad        bv bt   = Result (bv, bt)
let rfailwith   bv msg  = rbad bv (Message msg |> Leaf)

Because even bad results need to carry a value in order to make Bind work we need to provide the value through bv parameter. For types that support Zero we can create a convinience method:

let inline rfailwithz  msg  = rfailwith LanguagePrimitives.GenericZero<_> msg

Bind is easy to implement:

let rbind (Result (tv, tbt)) uf =
  let (Result (uv, ubt)) = uf tv
  Result (uv, btjoin tbt ubt)

That is; we evaluate both results and join the bad trees if needed.

With a computation expression builder the following program:

  let r =
    result {
      let! a = rreturn    1
      let! b = rfailwithz "Oh nose!"
      let! c = rfailwithz "God damn it, uncle Bob!"
      return a + b + c
    }

  printfn "%A" r

Outputs:

Result (1,Fork (Leaf (Message "Oh nose!"),Leaf (Message "God damn it, uncle Bob!")))

That is; we get a bad value 1 and the reasons it's bad is because of the two joined error leafs.

I have used this approach when transforming and validating tree structures using composable combinators. It's in my case important to get all validation failure, not just the first. This means that both branches in Bind needs to be evaluated but in order to do we must always have a value in order to call uf in Bind t uf.

As in OP:s own answer I did experiment with Unchecked.defaultof<_> but I abandoned for example because the default value of a string is null and it usually leads to crashes when invoking uf. I did create a map Type -> empty value but in my final solution I require a bad value when constructing a bad result.

Hope this helps

Full example:

type BadCause =
  | Exception of exn
  | Message   of string

type BadTree =
  | Empty
  | Leaf  of BadCause
  | Fork  of BadTree*BadTree

type [<Struct>] Result<'T> = Result of 'T*BadTree

let (|Good|Bad|) (Result (v, bt)) =
  let ra = ResizeArray 16
  let rec loop bt =
    match bt with
    | Empty         -> ()
    | Leaf  bc      -> ra.Add bc |> ignore
    | Fork  (l, r)  -> loop l; loop r
  loop bt
  if ra.Count = 0 then 
    Good v
  else 
    Bad (ra.ToArray ())

module Result =
  let btjoin      l  r    =
    match l, r with
    | Empty , _     -> r
    | _     , Empty -> l
    | _     , _     -> Fork (l, r)

  let rreturn     v       = Result (v, Empty)
  let rbad        bv bt   = Result (bv, bt)
  let rfailwith   bv msg  = rbad bv (Message msg |> Leaf)

  let inline rfailwithz  msg  = rfailwith LanguagePrimitives.GenericZero<_> msg

  let rbind (Result (tv, tbt)) uf =
    let (Result (uv, ubt)) = uf tv
    Result (uv, btjoin tbt ubt)

  type ResultBuilder () =
    member x.Bind         (t, uf) = rbind t uf
    member x.Return       v       = rreturn v
    member x.ReturnFrom   r       = r : Result<_>

let result = Result.ResultBuilder ()

open Result

[<EntryPoint>]
let main argv = 
  let r =
    result {
      let! a = rreturn    1
      let! b = rfailwithz "Oh nose!"
      let! c = rfailwithz "God damn it, uncle Bob!"
      return a + b + c
    }

  match r with
  | Good v  -> printfn "Good: %A" v
  | Bad  es -> printfn "Bad: %A" es

  0