3 people like it.
Like the snippet!
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