RResult2

RResult2.fs

module RResult2 =
  open System.Collections.Generic
  open System.Text

  [<RequireQualifiedAccess>]
  type RBad =
    | Message         of string
    | Exception       of exn
    | Object          of obj
    | DescribedObject of string*obj

    member x.DescribeTo (sb : StringBuilder) =
      let inline app (t : string) = sb.Append t |> ignore 
      match x with
      | Message         msg   -> app "Message: "    ; app msg
      | Exception       e     -> app "Exception: "  ; app e.Message
      | Object          o     -> app "Object: "     ; sb.Append o |> ignore
      | DescribedObject (d, _)-> app "Object: "     ; sb.Append d |> ignore

  [<RequireQualifiedAccess>]
  type RBadTree =
    | Leaf  of RBad
    | Fork  of RBadTree*RBadTree

    member x.Visit (visitor: RBad -> bool) : bool =
      let stack = Stack<RBadTree> 16
      let rec follow t =
        let inline pop () =
          if stack.Count > 0 then 
            follow (stack.Pop ())
          else
            true
        match t with
        | Leaf  v         -> visitor v && pop ()
        | Fork  (l, r)    -> stack.Push r; follow l
      follow x

    member x.Flatten () : RBad [] =
      let result = ResizeArray 16
      x.Visit (fun v -> result.Add v; true) |> ignore
      result.ToArray ()

    member x.Describe () : string =
      let sb = StringBuilder 16
      x.Visit 
        (fun rbad -> 
          if sb.Length > 0 then sb.Append "; " |> ignore
          rbad.DescribeTo sb
          true
        ) |> ignore
      sb.ToString ()

    member x.Join o = Fork (x, o)

  [<RequireQualifiedAccess>]
  [<Struct>]
  [<StructuredFormatDisplay("{StructuredDisplayString}")>]
  type RResult<'T> =
    | Good  of good : 'T
    | Empty
    | Bad   of bad  : RBadTree

    member x.StructuredDisplayString =
      match x with
      | Empty     -> "Empty"
      | Good good -> sprintf "Good (%A)" good
      | Bad  bad  -> sprintf "Bad (%A)"  bad

    override x.ToString() = x.StructuredDisplayString

  exception DerefException  of RBadTree

  module RResult =

    // Monad

    let inline rreturn  v = RResult.Good v
    let inline rbind (uf : 'T -> RResult<'U>) (t : RResult<'T>) : RResult<'U> =
      match t with
      | RResult.Good    tgood -> uf tgood
      | RResult.Empty         -> RResult.Empty
      | RResult.Bad     tbad  -> RResult.Bad tbad

    // Kleisli

    let inline rarr f         = fun v -> rreturn (f v)
    let inline rkleisli uf tf = fun v -> rbind uf (tf v) 

    // Applicative

    let inline rpure  f = rreturn f
    let inline rapply (t : RResult<'T>)  (f : RResult<'T -> 'U>) : RResult<'U> =
      match f, t with
      | RResult.Good  fgood , RResult.Good  tgood -> rreturn (fgood tgood)
      | RResult.Bad   fbad  , RResult.Bad   tbad  -> RResult.Bad (fbad.Join tbad)
      | RResult.Bad   fbad  , _                   -> RResult.Bad fbad
      | _                   , RResult.Bad   tbad  -> RResult.Bad tbad
      | _                   , _                   -> RResult.Empty
      
    // Functor

    let inline rmap (m : 'T -> 'U) (t : RResult<'T>) : RResult<'U> =
      match t with
      | RResult.Good    tgood -> rreturn (m tgood)
      | RResult.Empty         -> RResult.Empty
      | RResult.Bad     tbad  -> RResult.Bad tbad

    // Lifts

    let inline rgood    v   = rreturn v
    let        rnoResult    = RResult.Empty
    let inline rbad     b   = RResult.Bad (RBadTree.Leaf b)
    let inline rmsg     msg = rbad (RBad.Message msg)
    let inline rexn     e   = rbad (RBad.Exception e)

    // Misc

    let inline rdelay (tf : unit -> RResult<'T>) : RResult<'T> =
      tf ()

    let inline rthen uf t = rbind uf t

    let rdebug name (t : RResult<'T>) : RResult<'T> =
      match t with
      | RResult.Good    tgood -> printfn "GOOD  - %s - %A" name tgood
      | RResult.Empty         -> printfn "EMPTY - %s"      name 
      | RResult.Bad     tbad  -> printfn "BAD   - %s - %A" name tbad
      t

    let inline rbadMap (m : RBadTree -> RBadTree) (t : RResult<'T>) : RResult<'T> =
      match t with
      | RResult.Good    _     -> t
      | RResult.Empty         -> t
      | RResult.Bad     tbad  -> RResult.Bad (m tbad)

    let rtoResult (t : RResult<'T>) = 
      match t with
      | RResult.Good    good  -> Ok     good
      | RResult.Empty         -> Error  None
      | RResult.Bad     bad   -> Error  (Some bad)

    // Exception aware combinators

    let inline rcatch (uf : 'T -> RResult<'U>) (t : RResult<'T>) : RResult<'U> =
      match t with
      | RResult.Good    tgood -> 
        try
          uf tgood
        with
        | e -> rexn e
      | RResult.Empty         -> RResult.Empty
      | RResult.Bad     tbad  -> RResult.Bad tbad

    let inline rcatchMap (m : 'T -> 'U) (t : RResult<'T>) : RResult<'U> =
      match t with
      | RResult.Good    tgood -> 
        try
          rreturn (m tgood)
        with
        | e -> rexn e
      | RResult.Empty         -> RResult.Empty
      | RResult.Bad     tbad  -> RResult.Bad tbad

    // Common combinators

    let rorElse (s : RResult<'T>) (f : RResult<'T>) : RResult<'T> =
      // Note that: Empty || Bad ==> Empty
      match f, s with
      | RResult.Good      _   , _                     -> f
      | _                     , RResult.Good    _     -> s
      | RResult.Empty         , _                     -> RResult.Empty
      | _                     , RResult.Empty         -> RResult.Empty
      | RResult.Bad       fbad, RResult.Bad     sbad  -> RResult.Bad (fbad.Join sbad)

    let rpair (u : RResult<'U>) (t : RResult<'T>) : RResult<'T*'U> =
      // Note that: Empty && Bad ==> Bad
      match t, u with
      | RResult.Good    tgood , RResult.Good  ugood -> rreturn (tgood, ugood)
      | RResult.Bad     tbad  , RResult.Bad   ubad  -> RResult.Bad (tbad.Join ubad)
      | _                     , RResult.Bad   ubad  -> RResult.Bad ubad
      | RResult.Bad     tbad  , _                   -> RResult.Bad tbad
      | _                     , _                   -> RResult.Empty

    // Unpacking results

    let rderef (t : RResult<'T>) : 'T option =
      match t with
      | RResult.Good    tgood -> Some tgood
      | RResult.Empty         -> None
      | RResult.Bad     tbad  -> raise (DerefException tbad)
    
    let inline rderefOr (bf : RBadTree -> 'T option) (t : RResult<'T>) : 'T option =
      match t with
      | RResult.Good    tgood -> Some tgood
      | RResult.Empty         -> None
      | RResult.Bad     tbad  -> bf tbad

    let inline rvisit (onGood : 'T -> 'U) (onNoResult : unit -> 'U) (onBad : RBadTree -> 'U) (t : RResult<'T>) : 'U =
      match t with
      | RResult.Good    tgood -> onGood tgood
      | RResult.Empty         -> onNoResult ()
      | RResult.Bad     tbad  -> onBad  tbad

    type Builder () =
      member inline x.Bind        (t, uf) = rbind   uf t
      member inline x.Delay       tf      = rdelay  tf
      member inline x.Return      v       = rreturn v
      member inline x.ReturnFrom  t       = t        : RResult<_>
      member inline x.Zero        ()      = rreturn LanguagePrimitives.GenericZero<_>

  let rresult = RResult.Builder ()

  type RResult<'T> with
    static member inline (>>=)  (x, uf) = RResult.rbind    uf x
    static member inline (<*>)  (x, t)  = RResult.rapply    t x
    static member inline (|>>)  (x, m)  = RResult.rmap      m x
    static member inline (<|>)  (x, s)  = RResult.rorElse   s x
    static member inline (~%%)  x       = RResult.rderef    x
    static member inline (%%)   (x, bf) = RResult.rderefOr bf x