F#: Pipelined Monads – Solutions From the Community

I was actually quite pleased that I got my state/error monad working (F#: Pipelined Monads), but there was a far more elegant solution staring me in the face. Thanks to other members of the F# community, I have reverted my code back to how it was and added two operators. In doing so the code is now far more elegant. Read on to see more, but thanks again to:

An elegant solution

The solutions from both Keith and Felix recognised that bind already had the behaviour I needed, of taking a wrapped result and passing it to a monad maker function. I had failed to recognise that that was exactly what I was trying to do. I was concerned about breaking up expressions into functions to delay their evaluation, but I failed to notice that the expressions were partially applied functions (in my real code) and so they would never be evaluated in advance.

The solutions from both Felix and Keith involved creating a single operator that wrapped bind. Felix did this directly and Keith did it by using the computation expression syntax in F#. I have chosen to use Felix’s approach as it is slightly less verbose:

let (>>=) x f = myBuilder.Bind(x, f)

I have adapted the code as follows:

  1. I have used a different character sequence for the operator, |>> because this changes the operator associativity to be similar to pipeline (|>)
  2. I have added a second operator that wraps the first operand in a call to Return so that a simple value can be used to begin the pipeline

Below is an extract of some of my testing code that uses this approach:

let m : ModelResult<Model> = 
  modelResultOf {
    let scopeSystem = "System"::[]
    let scopeString = "String"::scopeSystem
    let scopeMySystem = "MySystem"::[]

    let! result =
      |-> Model.add (Definition.create [] "System" DefinitionType.Namespace EmptySpec)
      |>> Model.add (Definition.create [] "Steve" DefinitionType.Namespace EmptySpec)
      |>> Model.add (Definition.create scopeSystem "ModuleOne" DefinitionType.Module (ModuleSpec({autoOpen = true; autoOpenAssembly = true})))
      |>> Model.add (Definition.create scopeSystem "String" DefinitionType.CustomClass (CustomClassSpec( () )))
      |>> Model.add (Definition.create scopeString "Empty" DefinitionType.DependencyProperty (DependencyPropertySpec( () )))
      |>> (fun (m:Model) -> Model.rename (m.[scopeSystem] |> Option.get) "MySystem" m)
      |>> (fun (m:Model) -> Model.renameAndMove (m.[scopeMySystem] |> Option.get) "MyMovedSystem" ("Steve"::[]) m)
    return result
    |> ModelResult.complete

The syntax is exactly what I wanted to achieve, so thanks again to Keith and Felix.

Here is the full code:


// defined elsewhere in my project but not needed for this blog post
type Definition = unit

// used to implement ModelResult.catch
type internal ModelResultCatch<'T> =
  | ModelResultOK of 'T
  | ModelResultException of System.Exception

type ModelResult<'T> =
  // Delayed execution semantics
  | ModelValue of 'T
  | DelayedModelValue of (unit->ModelResult<'T>)
  // Exception semantics
  | Collision of Definition*Definition
  | UndefinedScope of string list
  | InvalidContainment of Definition*Definition
  | InvalidOperation of string

  member s.IsDelayed () =   
    match s with   
    | DelayedModelValue(_) -> true  
    | _ -> false  
  member s.IsException () =
    match s with
    | ModelValue(_) -> false
    | _ -> true

  member s.Get() =
    match s with
    | ModelValue(m) -> m
    | _ -> failwith "invalid operation"

  member s.Complete() =
    let rec loop x =
      match x with
      | DelayedModelValue work -> loop (work())
      | _ -> x
    loop s

  member s.CastException<'U> () =
    match s with
    | ModelValue(_) -> failwith "invalid cast"
    | DelayedModelValue(_) -> failwith "invalid cast"
    | Collision(d1,d2) -> ModelResult<'U>.Collision(d1,d2)
    | UndefinedScope(s) -> ModelResult<'U>.UndefinedScope(s)
    | InvalidContainment(d1,d2) -> ModelResult<'U>.InvalidContainment(d1,d2)
    | InvalidOperation(s) -> ModelResult<'U>.InvalidOperation(s)

module ModelResult =
  let result x = ModelValue x

  let rec bind k e =
    match e with
    | ModelValue v -> DelayedModelValue (fun () -> k v)
    | DelayedModelValue work -> DelayedModelValue (fun () -> bind k (work()))
    | _ -> e.CastException<_>()

  let zero = result ()

  let delay f = result() |> bind f

  let rec private catch (e:ModelResult<'T>)=
    match e with
    | DelayedModelValue work ->
      let res : ModelResultCatch<ModelResult<_>> =
        try ModelResultOK(work()) with
        | e -> ModelResultException e
      match res with
      | ModelResultOK cont -> catch cont // note, a tailcall
      | ModelResultException e -> result (ModelResultException e)
    | _ -> result (ModelResultOK(e))

  /// The tryFinally operator
  /// Based on boiler-plate code in terms of result, catch and bind.
  let tryFinally e compensation =
    catch (e)
    |> bind (fun res ->
        compensation() ;
        match res with
        | ModelResultOK v -> v
        | ModelResultException e -> raise e)

  /// The tryWith operator
  /// Based on boiler-plate code in terms of result, catch and bind.
  let tryWith e handler =
       catch e
    |> bind (function
        | ModelResultOK v -> v
        | ModelResultException e -> handler e)

  /// The whileLoop operator
  /// This is boiler-plate in terms of result and bind.
  let rec whileLoop gd body =
    if gd() then body |> bind (fun v -> whileLoop gd body)
    else result ()

  /// The sequential composition operator
  /// This is boiler-plate in terms of result and bind.
  let combine e1 e2 =
    e1 |> bind (fun () -> e2)

  /// The using operator
  let using (resource: #System.IDisposable) f =
      (f resource)
      (fun () -> resource.Dispose())

  /// The forLoop operator
  /// This is boiler-plate in terms of catch‚ result and bind.
  let forLoop (e:seq<_>) f =
    let ie = e.GetEnumerator()
        (fun () -> ie.MoveNext())
        (delay (fun () ->
            let v = ie.Current
            f v)))
      (fun () -> ie.Dispose())

  let complete (e:ModelResult<'a>) =

  let get = function
    | ModelValue v -> v
    | DelayedModelValue _ -> "ModelResult has not been executed and cannot be accessed with ModelResult.get"
    | _ -> failwith "ModelResult represents an error and cannot be accessed with ModelResult.get"  

type ModelResultBuilder() =
  member s.Bind(e,k) = ModelResult.bind k e
  member s.Return(v) = ModelResult.result v
  member s.Delay(f) = ModelResult.delay f
  member s.Run(e) = e
  member s.Zero() = ModelResult.zero
  member x.Combine(e1,e2) = ModelResult.combine e1 e2
  member x.TryWith(e,handler) = ModelResult.tryWith e handler
  member x.TryFinally(e,compensation) = ModelResult.tryFinally e compensation
  member x.For(e:seq<_>,f) = ModelResult.forLoop e f
  member x.Using(resource,e) = ModelResult.using resource e

module ModelResultPervasives =
  let modelResultOf = new ModelResultBuilder()
  let (|>>) e k = modelResultOf.Bind(e,k)  
  let (|->) e k = modelResultOf.Bind(modelResultOf.Return(e),k)

2 thoughts on “F#: Pipelined Monads – Solutions From the Community

  1. Pingback: F#: Pipelined Monads « Steve Horsfield

  2. Pingback: Rick Minerich's Development Wonderland : F# Discoveries This Week 10/11/2009

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s