3 people like it.

The Eff monad

The Eff monad in F#, based on http://okmij.org/ftp/Computation/free-monad.html.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
// The Eff Monad
// based on http://okmij.org/ftp/Computation/free-monad.html

// Helper Equality type
module Eq = 

    type Eq<'A, 'B> = private Refl of ('A -> 'B) * ('B -> 'A)
    
    let refl<'A> () : Eq<'A, 'A> = Refl (id, id)
    let sym : Eq<'A, 'B> -> Eq<'B, 'A> = fun (Refl (f, g)) -> Refl (g, f)
    let trans : Eq<'A, 'B> -> Eq<'B, 'C> -> Eq<'A, 'C> = 
        fun (Refl (f, g)) (Refl (h, k)) -> Refl (f >> h, k >> g)
    let cast : Eq<'A, 'B> -> 'A -> 'B = fun (Refl (f, _)) -> f

open Eq

// Basic GADT encoding
type Effect = interface end

[<AbstractClass>]
type Eff<'U, 'A when 'U :> Effect>() = 
    abstract Invoke<'R> : EffHandler<'U, 'A, 'R> -> 'R 

and EffHandler<'U, 'A, 'R when 'U :> Effect> =
    abstract Handle : 'A -> 'R 
    abstract Handle<'X> : Effect * ('X -> Eff<'U, 'A>) -> 'R
 
and Pure<'U, 'A when 'U :> Effect>(a : 'A) = 
    inherit Eff<'U, 'A>()
        override self.Invoke handler = 
            handler.Handle a
 
 and Impure<'U, 'X, 'A when 'U :> Effect>(effect : Effect, f : 'X -> Eff<'U, 'A>) = 
    inherit Eff<'U, 'A>()
        override self.Invoke handler = 
            handler.Handle<'X>(effect, f)
 
// Monad instance
type EffBuilder() = 
    member self.Return<'U, 'A when 'U :> Effect> (x : 'A) : Eff<'U, 'A> = new Pure<'U, 'A>(x) :> _
    member self.Bind<'U, 'A, 'B when 'U :> Effect>(eff : Eff<'U, 'A>, f : 'A -> Eff<'U, 'B>) : Eff<'U, 'B> = 
        eff.Invoke<Eff<'U, 'B>> {
            new EffHandler<'U, 'A, Eff<'U, 'B>> with
                member self'.Handle x = f x
                member self'.Handle<'X>(effect, f') = 
                    new Impure<'U, 'X, 'B>(effect, fun x -> self.Bind(f' x, f)) :> _
        }

let eff = new EffBuilder()

// State Effect
type State<'S> = inherit Effect
type State<'S, 'A> = 
    abstract Invoke<'R> : StateHandler<'S, 'A, 'R> -> 'R 
    inherit State<'S>
and StateHandler<'S, 'A, 'R> =
    abstract Handle : 'S * Eq<unit, 'A> -> 'R 
    abstract Handle : Eq<'S, 'A> -> 'R
type Get<'S>() = 
    interface State<'S, 'S> with
        member self.Invoke<'R> (handler : StateHandler<'S, 'S, 'R>) = 
            handler.Handle(refl<'S>())
type Put<'S>(state : 'S) = 
    member self.State = state
    interface State<'S, unit> with
        member self.Invoke<'R> (handler : StateHandler<'S, unit, 'R>) = 
            handler.Handle(state, refl<unit>())

let get<'U, 'S when 'U :> State<'S>>() : Eff<'U, 'S> = 
    new Impure<'U, 'S, 'S>(new Get<'S>(), fun x -> new Pure<'U, 'S>(x) :> _) :> _
let put<'U, 'S when 'U :> State<'S>> : 'S -> Eff<'U, unit> = 
    fun s -> new Impure<'U, unit, unit>(new Put<'S>(s), fun _ -> new Pure<'U, unit>(()) :> _) :> _ 

// Reader Effect
type Reader<'E> = inherit Effect
type Reader<'E, 'A> = 
    abstract Invoke<'R> : ReaderHandler<'E, 'A, 'R> -> 'R 
    inherit Reader<'E>
and ReaderHandler<'E, 'A, 'R> =
    abstract Handle : Eq<'E, 'A> -> 'R
type Ask<'E>() = 
    interface Reader<'E, 'E> with
            member self.Invoke<'R> (handler : ReaderHandler<'E, 'E, 'R>) = 
                handler.Handle(refl<'E>())

let ask<'U, 'E when 'U :> Reader<'E>>() : Eff<'U, 'E> = 
    new Impure<'U, 'E, 'E>(new Ask<'E>(), fun x -> new Pure<'U, 'E>(x) :> _) :> _

// interpreters
let rec runState<'U, 'S, 'A when 'U :> State<'S>> 
    : 'S -> Eff<'U, 'A> -> Eff<'U, 'S * 'A> = 
    fun state eff ->
        eff.Invoke<Eff<'U, 'S * 'A>> {
            new EffHandler<'U, 'A, Eff<'U, 'S * 'A>> with
                member self.Handle x = new Pure<'U, 'S * 'A>((state, x)) :> _ 
                member self.Handle<'X>(effect, f : 'X -> Eff<'U, 'A>) = 
                    match effect with
                    | :? State<'S, 'X> as stateEffect ->
                        stateEffect.Invoke<Eff<'U, 'S * 'A>> {
                            new StateHandler<'S, 'X, Eff<'U, 'S * 'A>> with
                                member self.Handle(state' : 'S, eq : Eq<unit, 'X>) = 
                                    let eff' = f (cast eq ())
                                    runState state' eff'
                                member self.Handle(eq : Eq<'S, 'X>) = 
                                    let eff' = f (cast eq state)
                                    runState state eff'
                        }
                    | _ -> new Impure<'U, 'X, 'S * 'A>(effect, fun x -> runState state (f x)) :> _
        }

let rec runReader<'U, 'E, 'A when 'U :> Reader<'E>> 
    : 'E -> Eff<'U, 'A> -> Eff<'U, 'A> = 
    fun env eff ->
        eff.Invoke<Eff<'U, 'A>> {
            new EffHandler<'U, 'A, Eff<'U, 'A>> with
                member self.Handle x = new Pure<'U, 'A>(x) :> _ 
                member self.Handle<'X>(effect, f : 'X -> Eff<'U, 'A>) = 
                    match effect with
                    | :? Reader<'E, 'X> as readerEffect ->
                        readerEffect.Invoke<Eff<'U, 'A>> {
                            new ReaderHandler<'E, 'X, Eff<'U, 'A>> with
                                member self.Handle(eq : Eq<'E, 'X>) = 
                                    let eff' = f (cast eq env)
                                    runReader env eff'
                        }
                    | _ -> new Impure<'U, 'X, 'A>(effect, fun x -> runReader env (f x)) :> _
        }

let rec run<'U, 'A when 'U :> Effect> : Eff<'U, 'A> -> 'A = 
    fun eff ->
        eff.Invoke<'A> {
            new EffHandler<'U, 'A, 'A> with
                member self.Handle x = x
                member self.Handle<'X>(effect, f : 'X -> Eff<'U, 'A>) = 
                    failwith "Unhandled effect"
        }

// Example
// val example : unit -> Eff<'U,int> when 'U :> Reader<int> and 'U :> State<int>
let example () =
    eff {
        do! put 1
        let! x = get ()
        let! y = ask ()
        return x + y
    }

type ExEffect = inherit State<int> inherit Reader<int>


(run << runReader 1 << runState<ExEffect, _, _> 0) (example ()) // (1, 2)
type Eq<'A,'B> = private | Refl of ('A -> 'B) * ('B -> 'A)

Full name: Script.Eq.Eq<_,_>
union case Eq.Refl: ('A -> 'B) * ('B -> 'A) -> Eq<'A,'B>
val refl : unit -> Eq<'A,'A>

Full name: Script.Eq.refl
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val sym : Eq<'A,'B> -> Eq<'B,'A>

Full name: Script.Eq.sym
val f : ('A -> 'B)
val g : ('B -> 'A)
val trans : Eq<'A,'B> -> Eq<'B,'C> -> Eq<'A,'C>

Full name: Script.Eq.trans
val h : ('B -> 'C)
val k : ('C -> 'B)
val cast : Eq<'A,'B> -> ('A -> 'B)

Full name: Script.Eq.cast
module Eq

from Script
type Effect

Full name: Script.Effect
Multiple items
type AbstractClassAttribute =
  inherit Attribute
  new : unit -> AbstractClassAttribute

Full name: Microsoft.FSharp.Core.AbstractClassAttribute

--------------------
new : unit -> AbstractClassAttribute
Multiple items
type Eff<'U,'A (requires 'U :> Effect)> =
  new : unit -> Eff<'U,'A>
  abstract member Invoke : EffHandler<'U,'A,'R> -> 'R

Full name: Script.Eff<_,_>

--------------------
new : unit -> Eff<'U,'A>
abstract member Eff.Invoke : EffHandler<'U,'A,'R> -> 'R

Full name: Script.Eff`2.Invoke
type EffHandler<'U,'A,'R (requires 'U :> Effect)> =
  interface
    abstract member Handle : 'A -> 'R
    abstract member Handle : Effect * ('X -> Eff<'U,'A>) -> 'R
  end

Full name: Script.EffHandler<_,_,_>
abstract member EffHandler.Handle : 'A -> 'R

Full name: Script.EffHandler`3.Handle
abstract member EffHandler.Handle : Effect * ('X -> Eff<'U,'A>) -> 'R

Full name: Script.EffHandler`3.Handle
Multiple items
type Pure<'U,'A (requires 'U :> Effect)> =
  inherit Eff<'U,'A>
  new : a:'A -> Pure<'U,'A>
  override Invoke : handler:EffHandler<'U,'A,'a> -> 'a

Full name: Script.Pure<_,_>

--------------------
new : a:'A -> Pure<'U,'A>
val a : 'A
val self : Pure<#Effect,'A>
override Pure.Invoke : handler:EffHandler<'U,'A,'a> -> 'a

Full name: Script.Pure`2.Invoke
val handler : EffHandler<#Effect,'A,'a>
abstract member EffHandler.Handle : 'A -> 'R
abstract member EffHandler.Handle : Effect * ('X -> Eff<'U,'A>) -> 'R
Multiple items
type Impure<'U,'X,'A (requires 'U :> Effect)> =
  inherit Eff<'U,'A>
  new : effect:Effect * f:('X -> Eff<'U,'A>) -> Impure<'U,'X,'A>
  override Invoke : handler:EffHandler<'U,'A,'a> -> 'a

Full name: Script.Impure<_,_,_>

--------------------
new : effect:Effect * f:('X -> Eff<'U,'A>) -> Impure<'U,'X,'A>
val effect : Effect
val f : ('X -> Eff<#Effect,'A>)
val self : Impure<#Effect,'X,'A>
override Impure.Invoke : handler:EffHandler<'U,'A,'a> -> 'a

Full name: Script.Impure`3.Invoke
Multiple items
type EffBuilder =
  new : unit -> EffBuilder
  member Bind : eff:Eff<'U,'A> * f:('A -> Eff<'U,'B>) -> Eff<'U,'B> (requires 'U :> Effect)
  member Return : x:'A -> Eff<#Effect,'A>

Full name: Script.EffBuilder

--------------------
new : unit -> EffBuilder
val self : EffBuilder
member EffBuilder.Return : x:'A -> Eff<#Effect,'A>

Full name: Script.EffBuilder.Return
val x : 'A
member EffBuilder.Bind : eff:Eff<'U,'A> * f:('A -> Eff<'U,'B>) -> Eff<'U,'B> (requires 'U :> Effect)

Full name: Script.EffBuilder.Bind
val eff : Eff<#Effect,'A>
val f : ('A -> Eff<#Effect,'B>)
abstract member Eff.Invoke : EffHandler<'U,'A,'R> -> 'R
val self' : EffHandler<'U,'A,Eff<'U,'B>> (requires 'U :> Effect)
val f' : ('X -> Eff<#Effect,'A>)
val x : 'X
member EffBuilder.Bind : eff:Eff<'U,'A> * f:('A -> Eff<'U,'B>) -> Eff<'U,'B> (requires 'U :> Effect)
val eff : EffBuilder

Full name: Script.eff
type State<'S> =
  interface
    inherit Effect
  end

Full name: Script.State<_>
Multiple items
type State<'S> =
  interface
    inherit Effect
  end

Full name: Script.State<_>

--------------------
type State<'S,'A> =
  interface
    inherit State<'S>
    abstract member Invoke : StateHandler<'S,'A,'R> -> 'R
  end

Full name: Script.State<_,_>
abstract member State.Invoke : StateHandler<'S,'A,'R> -> 'R

Full name: Script.State`2.Invoke
type StateHandler<'S,'A,'R> =
  interface
    abstract member Handle : 'S * Eq<unit,'A> -> 'R
    abstract member Handle : Eq<'S,'A> -> 'R
  end

Full name: Script.StateHandler<_,_,_>
abstract member StateHandler.Handle : 'S * Eq<unit,'A> -> 'R

Full name: Script.StateHandler`3.Handle
Multiple items
module Eq

from Script

--------------------
type Eq<'A,'B> = private | Refl of ('A -> 'B) * ('B -> 'A)

Full name: Script.Eq.Eq<_,_>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
abstract member StateHandler.Handle : Eq<'S,'A> -> 'R

Full name: Script.StateHandler`3.Handle
Multiple items
type Get<'S> =
  interface State<'S,'S>
  new : unit -> Get<'S>

Full name: Script.Get<_>

--------------------
new : unit -> Get<'S>
val self : Get<'S>
override Get.Invoke : handler:StateHandler<'S,'S,'R> -> 'R

Full name: Script.Get`1.Invoke
val handler : StateHandler<'S,'S,'R>
abstract member StateHandler.Handle : Eq<'S,'A> -> 'R
abstract member StateHandler.Handle : 'S * Eq<unit,'A> -> 'R
Multiple items
type Put<'S> =
  interface State<'S,unit>
  new : state:'S -> Put<'S>
  member State : 'S

Full name: Script.Put<_>

--------------------
new : state:'S -> Put<'S>
val state : 'S
val self : Put<'S>
Multiple items
member Put.State : 'S

Full name: Script.Put`1.State

--------------------
type State<'S> =
  interface
    inherit Effect
  end

Full name: Script.State<_>

--------------------
type State<'S,'A> =
  interface
    inherit State<'S>
    abstract member Invoke : StateHandler<'S,'A,'R> -> 'R
  end

Full name: Script.State<_,_>
override Put.Invoke : handler:StateHandler<'S,unit,'R> -> 'R

Full name: Script.Put`1.Invoke
val handler : StateHandler<'S,unit,'R>
val get : unit -> Eff<#State<'S>,'S>

Full name: Script.get
val x : 'S
val put : s:'S -> Eff<#State<'S>,unit>

Full name: Script.put
val s : 'S
type Reader<'E> =
  interface
    inherit Effect
  end

Full name: Script.Reader<_>
Multiple items
type Reader<'E> =
  interface
    inherit Effect
  end

Full name: Script.Reader<_>

--------------------
type Reader<'E,'A> =
  interface
    inherit Reader<'E>
    abstract member Invoke : ReaderHandler<'E,'A,'R> -> 'R
  end

Full name: Script.Reader<_,_>
abstract member Reader.Invoke : ReaderHandler<'E,'A,'R> -> 'R

Full name: Script.Reader`2.Invoke
type ReaderHandler<'E,'A,'R> =
  interface
    abstract member Handle : Eq<'E,'A> -> 'R
  end

Full name: Script.ReaderHandler<_,_,_>
abstract member ReaderHandler.Handle : Eq<'E,'A> -> 'R

Full name: Script.ReaderHandler`3.Handle
Multiple items
type Ask<'E> =
  interface Reader<'E,'E>
  new : unit -> Ask<'E>

Full name: Script.Ask<_>

--------------------
new : unit -> Ask<'E>
val self : Ask<'E>
override Ask.Invoke : handler:ReaderHandler<'E,'E,'R> -> 'R

Full name: Script.Ask`1.Invoke
val handler : ReaderHandler<'E,'E,'R>
abstract member ReaderHandler.Handle : Eq<'E,'A> -> 'R
val ask : unit -> Eff<#Reader<'E>,'E>

Full name: Script.ask
val x : 'E
val runState : state:'S -> eff:Eff<'U,'A> -> Eff<'U,('S * 'A)> (requires 'U :> State<'S>)

Full name: Script.runState
val eff : Eff<#State<'S>,'A>
val self : EffHandler<'U,'A,Eff<'U,('S * 'A)>> (requires 'U :> State<'S>)
val f : ('X -> Eff<#State<'S>,'A>)
val stateEffect : State<'S,'X>
abstract member State.Invoke : StateHandler<'S,'A,'R> -> 'R
val self : StateHandler<'S,'X,Eff<#State<'S>,('S * 'A)>>
val state' : 'S
val eq : Eq<unit,'X>
val eff' : Eff<#State<'S>,'A>
val eq : Eq<'S,'X>
val runReader : env:'E -> eff:Eff<'U,'A> -> Eff<'U,'A> (requires 'U :> Reader<'E>)

Full name: Script.runReader
val env : 'E
val eff : Eff<#Reader<'E>,'A>
val self : EffHandler<'U,'A,Eff<'U,'A>> (requires 'U :> Reader<'E>)
val f : ('X -> Eff<#Reader<'E>,'A>)
val readerEffect : Reader<'E,'X>
abstract member Reader.Invoke : ReaderHandler<'E,'A,'R> -> 'R
val self : ReaderHandler<'E,'X,Eff<#Reader<'E>,'A>>
val eq : Eq<'E,'X>
val eff' : Eff<#Reader<'E>,'A>
val run : eff:Eff<#Effect,'A> -> 'A

Full name: Script.run
val self : EffHandler<#Effect,'A,'A>
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val example : unit -> Eff<'a,int> (requires 'a :> Reader<int> and 'a :> State<int>)

Full name: Script.example
val x : int
val y : int
type ExEffect =
  interface
    inherit Reader<int>
    inherit State<int>
  end

Full name: Script.ExEffect
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>

More information

Link:http://fssnip.net/7U2
Posted:6 years ago
Author:NIck Palladinos
Tags: effects , monads