// The Eff Monad via delimited continuations
// based on http://kcsrk.info/papers/eff_ocaml_ml16.pdf
// Basic types
type Effect =
abstract UnPack : Lambda -> Effect
and Lambda =
abstract Invoke<'X> : ('X -> Effect) -> ('X -> Effect)
and Eff<'U, 'A when 'U :> Effect> =
Eff of (('A -> Effect) -> Effect)
and Done<'A>(v : 'A) =
member self.Value = v
interface Effect with
member self.UnPack(_ : Lambda) : Effect =
new Done<'A>(v) :> _
// Monad instance
type EffBuilder() =
member self.Return<'U, 'A when 'U :> Effect> (v : 'A) : Eff<'U, 'A> =
Eff (fun k -> k v)
member self.Bind<'U, 'A, 'B when 'U :> Effect>(eff : Eff<'U, 'A>, f : 'A -> Eff<'U, 'B>) : Eff<'U, 'B> =
Eff (fun k -> let (Eff effK) = eff in effK (fun v -> let (Eff effK') = f v in effK' k))
let eff = new EffBuilder()
module Eff =
let done' (v : 'A) : Effect =
new Done<'A>(v) :> _
let shift (f : ('A -> Effect) -> Effect) : Eff<'U, 'A> =
Eff (fun k -> f k)
open Eff
// State Effect
type State<'S> = inherit Effect
type Put<'S>(v : 'S, k : unit -> Effect) =
interface State<'S> with
member self.UnPack(lambda : Lambda) : Effect =
new Put<'S>(v, lambda.Invoke k) :> _
member self.Value = v
member self.K = k
type Get<'S>(k : 'S -> Effect) =
interface State<'S> with
member self.UnPack(lambda : Lambda) : Effect =
new Get<'S>(lambda.Invoke<'S> k) :> _
member self.K = k
let get<'U, 'S when 'U :> State<'S>>() : Eff<'U, 'S> =
shift (fun k -> new Get<'S>(k) :> _)
let put<'U, 'S when 'U :> State<'S>> : 'S -> Eff<'U, unit> = fun s ->
shift (fun k -> new Put<'S>(s, k) :> _)
// Reader Effect
type Reader<'E> = inherit Effect
type Ask<'E>(k : 'E -> Effect) =
interface Reader<'E> with
member self.UnPack(lambda : Lambda) : Effect =
new Ask<'E>(lambda.Invoke<'E> k) :> _
member self.K = k
let ask<'U, 'E when 'U :> Reader<'E>>() : Eff<'U, 'E> =
shift (fun k -> new Ask<'E>(k) :> _)
// interpreters
let rec runState<'U, 'S, 'A when 'U :> State<'S>>
: 'S -> Eff<'U, 'A> -> Eff<'U, 'S * 'A> =
fun state eff ->
let rec loop : ('S * 'A -> Effect) -> 'S -> Effect -> Effect = fun k state effect ->
match effect with
| :? Get<'S> as get -> loop k state (get.K state)
| :? Put<'S> as put -> loop k put.Value (put.K ())
| :? Done<'A> as done' -> k (state, done'.Value)
| _ -> effect.UnPack {
new Lambda with
member self.Invoke<'X> (k' : 'X -> Effect) =
fun x -> loop k state (k' x)
}
let (Eff effK) = eff
let effect = effK done'
Eff (fun k -> loop k state effect)
let rec runReader<'U, 'E, 'A when 'U :> Reader<'E>>
: 'E -> Eff<'U, 'A> -> Eff<'U, 'A> =
fun env eff ->
let rec loop : ('A -> Effect) -> 'E -> Effect -> Effect = fun k env effect ->
match effect with
| :? Ask<'E> as ask -> loop k env (ask.K env)
| :? Done<'A> as done' -> k done'.Value
| _ -> effect.UnPack {
new Lambda with
member self.Invoke<'X> (k' : 'X -> Effect) =
fun x -> loop k env (k' x)
}
let (Eff effK) = eff
let effect = effK done'
Eff (fun k -> loop k env effect)
let rec run<'U, 'A when 'U :> Effect> : Eff<'U, 'A> -> 'A =
fun eff ->
let (Eff effK) = eff
let effect = effK done'
match effect with
| :? Done<'A> as done' -> done'.Value
| _ -> failwithf "Unhandled effect %A" effect
// Example
// val example : unit -> Eff<'U,int> when 'U :> Reader and 'U :> State
let example () =
eff {
do! put 1
let! y = ask ()
let! x = get ()
return x + 1
}
type ExEffect = inherit State inherit Reader
(run << runReader 1 << runState 0) (example ()) // (1, 2)