F#: Pipelined Monads

Update (12 September 2009): The community has provided a more elegant solution to this problem. See my more recent post for more details here: F# Pipelined Monads – Solutions From the Community. Thanks go to Keith Battocchi and Felix (felixmar on hubFS) for the revised solution. I have left this post unchanged and I advise you to use the revised solution in your own projects.

I recently completed my own construction of a couple of monads that I am using in a mini-project. I like the way that I am able to compose functions returning monadic values by using let! and do! directly. However, I was frustrated by the need to use multiple let! statements when I needed to chain constructs into a pipeline, for example:

let result = myBuilder {
  let result1 = initialValue
  let! r2 = r1 |> f1
  let! r3 = r2 |> f2
  let! r4 = r3 |> f3
  return r4 }

It is important to use let! because each step in the pipeline is allowed to fail. More generally, the behaviour required is that bind must be incorporated into the pipeline. Additionally, the proliferation of intermediary variables greatly increased the possibility of error in my code because I might have referred to one of the intermediate results, rather than the most recent result. Compare this to a non-computation expression version:

let result = 
     initialValue
  |> f1
  |> f2
  |> f3

The challenge before me was could I do any better?

An important observation

The best solution to this problem requires a change to the compiler. The compiler inserts additional code as part of the processing of computation expressions. Specifically:

let! x = expr in [cexpr] ==> builder.Bind(expr, fun x -> [cexpr])
do! expr in [cexpr] ==> builder.Bind(expr, fun () -> [cexpr])

It is not possible to split an expression into separate functions in code and so it is necessary to use this feature of the compiler. This means that a sequence of either let! or do! constructs is necessary and this introduces several requirements to any solution. A much nicer alternative would be for Microsoft to add a monadic pipeline keyword that has the same effect as the above solution using multiple let! statements.

A solution

The solution I chose was to use a state monad approach. I found the following forum post helpful as I was developing the monad: Custom Workflow functions (hubFS).

I chose the state monad because I needed to provide storage for intermediary results. This is because I needed to use do! to avoid introducing intermediary variables but do! expects to return unit. Therefore, I needed to allow these statements to store the result into the monad state.

I used a generic form of the state monad as:

Monad<‘T,’Sin,’Sout>

In addition to the usual monad functions, I needed to provide functions and/or operators that would transform other functions and values into state-adjusting monads:

  • insert : ‘a -> Monad<unit,’b,’a>
  • extract : Monad<‘a,’a,unit>
  • peek : Monad<‘a,’a,’a>
  • simplePipeline : (‘a -> ‘b) -> Monad<unit,’a,’b>
  • complexPipeline : ‘a -> (‘b -> Monad<‘c,’a,’d>) -> Monad<‘c,’b,’d>
  • chainedPipeline : ‘a -> (‘b -> Monad<‘c,’a,’d>) -> Monad<unit,’b,’c>

These deserve some explanation. Each of these are either a value that is a monad or else a function that returns one. This allows them to be composed using do! and let!, and therefore used in bind.

insert creates a monad that replaces any existing state with the provided value. It can be used as:

do! insert value

extract is a monad that extracts the value of the state as a normal result. Because the result type is not unit it must be used with let!:

let! state = extract

Note that extract replaces the existing state with unit.

peek is similar to extract but it maintains the value of the existing state:

let! state = peek

simplePipeline applies a normal function to the state value. It can be used as:

do! insert 0
do! simplePipeline ((+) 5)

complexPipeline passes the state value to a monad maker function and executes that monad. Because the monad state value is passed to the monad maker, another value must be used as the initial state for the secondary monad. This initial state is usually unit. Here is an example based on the original problem at the beginning of this post:

do! insert initialValue
do! complexPipeline () f

This is most useful when f returns a monad with a unit value.

chainedPipeline is a more useful variation of complexPipeline. It combines the behaviour of insert and complexPipeline so that the result of the function is stored in the monad state, ready for the next pipelined invocation. Here is the resulting code:

do! insert initialValue
do! chainedPipeline () f1
do! chainedPipeline () f2
do! chainedPipeline () f3
do! chainedPipeline () f4
let! result = extract
return result

Finally, by defining operators it is possible to abbreviate the standard cases of using insert and chainedPipeline:

do! !<- initialValue
do! !-> f1
do! !-> f2
do! !-> f3
do! !-> f4
let! result = extract
return result

I am fairly pleased with the result, although I would prefer that the language included a keyword for this instead.

Implementation

My implementation is based on my previous post: F#: Custom Monad (Workflow) Development. However, the delayed execution semantics that I describe in that post are not necessary in this implementation because the state monad introduces the same behaviour.

The main types are as follows:

// Definition is used by the full application but is not needed for this post
type Definition = unit

type internal ModelResultCatch<'T> =
  | ModelResultOK of 'T
  | ModelResultException of System.Exception

type ModelResultState<'T, 'Sin, 'Sout> =
  | ModelResultState of ('Sin -> 'Sout * 'T)

type ModelResult<'T> =
  | ModelValue of 'T
  // Exception semantics
  | Collision of Definition*Definition
  | UndefinedScope of string list
  | InvalidContainment of Definition*Definition
  | InvalidOperation of string

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

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

type ModelResultMonad<'T,'Sin,'Sout> = ModelResultState<ModelResult<'T>,'Sin,'Sout>
type ModelResultCatchValue<'T> = ModelResultCatch<ModelResult<'T>>
type ModelResultCatchData<'T> = ModelResult<ModelResultCatchValue<'T>>
type ModelResultCatchMonad<'T,'Sin,'Sout> = ModelResultState<ModelResultCatchData<'T>,'Sin,'Sout>

The type aliases can help to understand the behaviour of the functions. In particular, the three “catch” type aliases are only used internally.

The basic monad structure is a function that takes a state and returns a new state and a value of type MonadResult. MonadResult is generic and wraps either a computation error or any result value. See my previous article for more on MonadResult as it is almost identical. You can think of the structure as an error monad inside of a state monad.

When I began adapting MonadResult in this way, I tried to modify MonadResult to combine the behaviour of a state monad and an error monad directly. I found that this was not possible because I needed the actual value of the input state in order to decide whether an error or a result was needed.

The functions for the monad are incorporated in the ModelResult module, which I will describe in sections:

module ModelResult =

  // ------------------- Internal utility functions (START)

  let internal castException e = ModelResult.CastException<_,_>(e)
  let internal castState<'s> : 's = Unchecked.defaultof<'s>  
  let internal castExceptionAndState e = castState<_>, castException e

  let internal run<'t,'sin,'sout> 
        ((ModelResultState e):ModelResultMonad<'t,'sin,'sout>) 
        (s:'sin) 
        : 'sout * ModelResult<'t> = 
    e s

  let internal wrapException (e:#System.Exception) : ModelResultCatchData<'a> = ModelValue(ModelResultException(e))

  let internal wrapSuccess (v:ModelResult<'t>) : ModelResultCatchData<'t> = ModelValue(ModelResultOK(v))

  // ------------------- Internal utility functions (END)

The first three functions allow for automatic type transitions when either an exception or a computation error occurs. In particular, Unchecked.defaultof<_> is worth knowing! Of course, it is the responsibility of the workflow author to ensure that unknown values are not used. An alternative would have been to wrap the state in a discriminated union type, similar to ModelResult, but I have not done so.

run is a simple function that unpacks the state monad function and executes it with the provided state. The type annotations are added to make the code more readable and compiler errors more targeted.

The final two, “wrap”, functions are utility functions used by catch later in the module. These help catch to create a true monadic value with success or exception details incorporated.

  // ------------------- Composition functions (START)

  let insert (a:'a) 
        : ModelResultMonad<unit, 'b, 'a> = 
    ModelResultState (fun s -> a, ModelValue ())

  let extract 
        : ModelResultMonad<'a,'a,unit> = 
    ModelResultState (fun s -> (), ModelValue s)

  let peek : 
        ModelResultMonad<'a,'a,'a> = 
    ModelResultState (fun s -> s, ModelValue s)  

  let simplePipeline (f:'a->'b) 
        : ModelResultMonad<unit,'a,'b> = 
    ModelResultState (fun (s:'a) -> f s, ModelValue ())

  let complexPipeline 
        (si:'si) 
        (f:'sin->ModelResultMonad<'t,'si,'sout>) 
        : ModelResultMonad<'t,'sin,'sout> =
    ModelResultState (fun s ->
      let m = f s
      run m si)

  let chainedPipeline 
        (si:'si) 
        (f:'sin->ModelResultMonad<'t,'si,'so>) 
        : ModelResultMonad<unit,'sin,'t> =
    ModelResultState (fun s ->
      let m = f s
      let s2, v = run m si
      match v with
      | ModelValue x -> x, ModelValue ()
      | _ -> castExceptionAndState v)
      
  // ------------------- Composition functions (END)

These composition functions have the behaviour described earlier in this post.

  // ------------------- Monad implementation methods (START)

  let resultDirect (e:ModelResult<'t>)
        : ModelResultMonad<'t,'s,'s> = 
    ModelResultState(fun s -> s, e)

  let result<'t,'s> (x:'t) 
        : ModelResultMonad<'t,'s,'s> = 
    resultDirect (ModelValue(x))

  let error (e:ModelResult<'u>) 
        : ModelResultMonad<'t,'s,'s> =
    resultDirect (castException(e))

  let bind 
        (k:'t->ModelResultMonad<'u,'sinternal,'sout>) 
        (e:ModelResultMonad<'t,'sin,'sinternal>) 
        : ModelResultMonad<'u,'sin,'sout> =
    ModelResultState(fun s -> 
      let s2, v = run e s
      match v with
      | ModelValue x -> run (k x) s2
      | _ -> castExceptionAndState v)

  let zero<'s> 
        : ModelResultMonad<unit,'s,'s> = 
    result ()

  let delay f 
        : ModelResultMonad<_,_,_> = 
    result() |> bind f

result is the usual monadic return function. However, because error values are wrapped in the state monad it is useful to factor out the internal construction of the value. resultDirect adds a state monad wrapper to any value and error inserts an existing error value (created by the discriminated union constructors), casting it to any required type as inferred by the F# compiler.

bind performs the function of adding a continuation to the monad, which is only executed if e results in a non-error value.

zero and delay are typical implementations.

  let rec internal catch (e:ModelResultMonad<'t,'sin,'sout>) :
        ModelResultCatchMonad<'t,'sin,'sout> =
    ModelResultState(fun s ->
      try
        let s2, v = run e s
        s2, wrapSuccess v
      with
      | e -> castState, wrapException e
      )

catch was difficult to design! Defining the precise types that I needed it to accept and return was definitely the most important design step. After that it was much easier to determine how to proceed. The most important part to this was recognising that it should return a monadic value that was compatible with bind. This is why ModelResultCatchMonad is such a deep type structure.

  /// The tryFinally operator
  let tryFinally 
        (e:ModelResultMonad<'t,'sin,'sout>) 
        compensation =
    catch (e)
    |> bind (fun (res:ModelResultCatchValue<'t>) -> 
        ModelResultState(fun s ->
          compensation() ;
          match res with
          | ModelResultOK v -> s, v
          | ModelResultException e -> raise e))
  
  /// The tryWith operator
  let tryWith e handler =
       catch (e)
    |> bind (fun (res:ModelResultCatchValue<'t>) ->
        ModelResultState(fun s ->
          match res with
          | ModelResultOK v -> s, v 
          | ModelResultException e -> run (handler e) castState))

tryFinally was straightforward once catch was correct. The type annotations definitely helped in this.

For tryWith, I am fairly sure the implementation is correct. Normal operation is easy, but the decision was to treat handler as a function that returned a monad. I believe this is what the F# Draft Language Specification requires, as the handler can be a computation expression.

  /// 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 sequanial 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 =
    tryFinally 
      (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()
    tryFinally 
      (whileLoop 
        (fun () -> ie.MoveNext())
        (delay (fun () -> 
            let v = ie.Current
            f v)))
      (fun () -> ie.Dispose())

  // ------------------- Monad implementation methods (END)
  
  let complete 
        (initialState:'b) 
        (e:ModelResultMonad<'a,'b,'c>) =
    run e initialState |> snd
    
  let get = function
    | ModelValue v -> v
    | _ -> failwith "ModelResult represents an error and cannot be accessed with ModelResult.get"

whileLoop, combine, using and forLoop are standard implementations based on other functions.

Because the monad does not execute automatically, complete is used for the purpose. If the result is successful, get can be used to retrieve the stored value. In general, this should not be used and instead a match clause should be used to act according to whether an error has resulted, however it is helpful for test code.

The builder class and some operators

The builder class is identical to the one in my previous post and has the semantics of a manual-execution monad:

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

The builder and operators are provided by the following module:

[<AutoOpen>]
module ModelResultPervasives =
  let modelResultOf = new ModelResultBuilder()
  
  let (!<-) x = ModelResult.insert x
  
  let (!|>) f = ModelResult.simplePipeline f
  
  let (!->) f = ModelResult.chainedPipeline () f
  let (!+>) f = ModelResult.complexPipeline () f
  
  let (-->) s f = ModelResult.chainedPipeline s f
  let (++>) s f = ModelResult.complexPipeline s f
  
  let (!~~) e = ModelResult.error e

Concluding remarks

If you would like to see Microsoft add this functionality to the language, please consider voting for it on Microsoft Connect here: F#: Pipelining in monads/workflows (Microsoft Connect).

Full code

#light

// Definition is used by the full application but is not needed for this post
type Definition = unit


type internal ModelResultCatch =
  | ModelResultOK of 'T
  | ModelResultException of System.Exception


type ModelResultState =
  | ModelResultState of ('Sin -&gt; 'Sout * 'T)


type ModelResult =
  | ModelValue of 'T
  // Exception semantics
  | Collision of Definition*Definition
  | UndefinedScope of string list
  | InvalidContainment of Definition*Definition
  | InvalidOperation of string

  member s.IsException () =
    match s with
    | ModelValue(_) -&gt; false
    | _ -&gt; true

  static member CastException (e:ModelResult) : ModelResult =  
    match e with
    | ModelValue(_) -&gt; failwith "invalid cast"
    | Collision(d1,d2) -&gt; Collision(d1,d2)
    | UndefinedScope(s) -&gt; UndefinedScope(s)
    | InvalidContainment(d1,d2) -&gt; InvalidContainment(d1,d2)
    | InvalidOperation(s) -&gt; InvalidOperation(s)


type ModelResultMonad = ModelResultState&lt;ModelResult,'Sin,'Sout&gt;
type ModelResultCatchValue = ModelResultCatch&lt;ModelResult&gt;
type ModelResultCatchData = ModelResult&lt;ModelResultCatchValue&gt;
type ModelResultCatchMonad = ModelResultState&lt;ModelResultCatchData,'Sin,'Sout&gt;


module ModelResult =

  // ------------------- Internal utility functions (START)

  let internal castException e = ModelResult.CastException<_,_>(e)
  let internal castState<'s> : 's = Unchecked.defaultof<'s>  
  let internal castExceptionAndState e = castState<_>, castException e

  let internal run<'t,'sin,'sout> 
        ((ModelResultState e):ModelResultMonad<'t,'sin,'sout>) 
        (s:'sin) 
        : 'sout * ModelResult<'t> = 
    e s

  let internal wrapException (e:#System.Exception) : ModelResultCatchData<'a> = ModelValue(ModelResultException(e))

  let internal wrapSuccess (v:ModelResult<'t>) : ModelResultCatchData<'t> = ModelValue(ModelResultOK(v))

  // ------------------- Internal utility functions (END)

  // ------------------- Composition functions (START)

  let insert (a:'a) 
        : ModelResultMonad<unit, 'b, 'a> = 
    ModelResultState (fun s -> a, ModelValue ())

  let extract 
        : ModelResultMonad<'a,'a,unit> = 
    ModelResultState (fun s -> (), ModelValue s)

  let peek : 
        ModelResultMonad<'a,'a,'a> = 
    ModelResultState (fun s -> s, ModelValue s)  

  let simplePipeline (f:'a->'b) 
        : ModelResultMonad<unit,'a,'b> = 
    ModelResultState (fun (s:'a) -> f s, ModelValue ())

  let complexPipeline 
        (si:'si) 
        (f:'sin->ModelResultMonad<'t,'si,'sout>) 
        : ModelResultMonad<'t,'sin,'sout> =
    ModelResultState (fun s ->
      let m = f s
      run m si)

  let chainedPipeline 
        (si:'si) 
        (f:'sin->ModelResultMonad<'t,'si,'so>) 
        : ModelResultMonad<unit,'sin,'t> =
    ModelResultState (fun s ->
      let m = f s
      let s2, v = run m si
      match v with
      | ModelValue x -> x, ModelValue ()
      | _ -> castExceptionAndState v)
      
  // ------------------- Composition functions (END)

  // ------------------- Monad implementation methods (START)

  let resultDirect (e:ModelResult<'t>)
        : ModelResultMonad<'t,'s,'s> = 
    ModelResultState(fun s -> s, e)

  let result<'t,'s> (x:'t) 
        : ModelResultMonad<'t,'s,'s> = 
    resultDirect (ModelValue(x))

  let error (e:ModelResult<'u>) 
        : ModelResultMonad<'t,'s,'s> =
    resultDirect (castException(e))

  let bind 
        (k:'t->ModelResultMonad<'u,'sinternal,'sout>) 
        (e:ModelResultMonad<'t,'sin,'sinternal>) 
        : ModelResultMonad<'u,'sin,'sout> =
    ModelResultState(fun s -> 
      let s2, v = run e s
      match v with
      | ModelValue x -> run (k x) s2
      | _ -> castExceptionAndState v)

  let zero<'s> 
        : ModelResultMonad<unit,'s,'s> = 
    result ()

  let delay f 
        : ModelResultMonad<_,_,_> = 
    result() |> bind f

  let rec internal catch (e:ModelResultMonad<'t,'sin,'sout>) :
        ModelResultCatchMonad<'t,'sin,'sout> =
    ModelResultState(fun s ->
      try
        let s2, v = run e s
        s2, wrapSuccess v
      with
      | e -> castState, wrapException e
      )

  /// The tryFinally operator
  let tryFinally 
        (e:ModelResultMonad<'t,'sin,'sout>) 
        compensation =
    catch (e)
    |> bind (fun (res:ModelResultCatchValue<'t>) -> 
        ModelResultState(fun s ->
          compensation() ;
          match res with
          | ModelResultOK v -> s, v
          | ModelResultException e -> raise e))
  
  /// The tryWith operator
  let tryWith e handler =
       catch (e)
    |> bind (fun (res:ModelResultCatchValue<'t>) ->
        ModelResultState(fun s ->
          match res with
          | ModelResultOK v -> s, v 
          | ModelResultException e -> run (handler e) castState))

  /// 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 sequanial 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 =
    tryFinally 
      (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()
    tryFinally 
      (whileLoop 
        (fun () -> ie.MoveNext())
        (delay (fun () -> 
            let v = ie.Current
            f v)))
      (fun () -> ie.Dispose())

  // ------------------- Monad implementation methods (END)
  
  let complete 
        (initialState:'b) 
        (e:ModelResultMonad<'a,'b,'c>) =
    run e initialState |> snd
    
  let get = function
    | ModelValue v -> v
    | _ -> 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


[<AutoOpen>]
module ModelResultPervasives =
  let modelResultOf = new ModelResultBuilder()
  
  let (!<-) x = ModelResult.insert x
  
  let (!|>) f = ModelResult.simplePipeline f
  
  let (!->) f = ModelResult.chainedPipeline () f
  let (!+>) f = ModelResult.complexPipeline () f
  
  let (-->) s f = ModelResult.chainedPipeline s f
  let (++>) s f = ModelResult.complexPipeline s f
  
  let (!~~) e = ModelResult.error e

I hope you have found this interesting.

Advertisements

One thought on “F#: Pipelined Monads

  1. Pingback: F# Pipelined Monads – Solutions From the Community « Steve Horsfield

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 )

Twitter picture

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

Facebook photo

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

Google+ photo

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

Connecting to %s