1 people like it.

The Eff Monad via delimited continuations

The Eff Monad via delimited continuations, based on http://kcsrk.info/papers/eff_ocaml_ml16.pdf.

  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: 
// 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<unit> 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<int> and 'U :> State<int>
let example () =
    eff {
        do! put 1
        let! y = ask ()
        let! x = get ()
        return x + 1
    }

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

(run << runReader 1 << runState<ExEffect, _, _> 0) (example ()) // (1, 2)
abstract member Effect.UnPack : Lambda -> Effect

Full name: Script.Effect.UnPack
type Lambda =
  interface
    abstract member Invoke : ('X -> Effect) -> ('X -> Effect)
  end

Full name: Script.Lambda
type Effect =
  interface
    abstract member UnPack : Lambda -> Effect
  end

Full name: Script.Effect
abstract member Lambda.Invoke : ('X -> Effect) -> ('X -> Effect)

Full name: Script.Lambda.Invoke
type Eff<'U,'A (requires 'U :> Effect)> = | Eff of (('A -> Effect) -> Effect)

Full name: Script.Eff<_,_>
Multiple items
union case Eff.Eff: (('A -> Effect) -> Effect) -> Eff<'U,'A>

--------------------
type Eff<'U,'A (requires 'U :> Effect)> = | Eff of (('A -> Effect) -> Effect)

Full name: Script.Eff<_,_>
Multiple items
type Done<'A> =
  interface Effect
  new : v:'A -> Done<'A>
  member Value : 'A

Full name: Script.Done<_>

--------------------
new : v:'A -> Done<'A>
val v : 'A
val self : Done<'A>
member Done.Value : 'A

Full name: Script.Done`1.Value
override Done.UnPack : Lambda -> Effect

Full name: Script.Done`1.UnPack
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 : v:'A -> Eff<#Effect,'A>

Full name: Script.EffBuilder

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

Full name: Script.EffBuilder.Return
val k : ('A -> Effect)
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>)
val k : ('B -> Effect)
val effK : (('A -> Effect) -> Effect)
val effK' : (('B -> Effect) -> Effect)
val eff : EffBuilder

Full name: Script.eff
val done' : v:'A -> Effect

Full name: Script.Eff.done'
val shift : f:(('A -> Effect) -> Effect) -> Eff<#Effect,'A>

Full name: Script.Eff.shift
val f : (('A -> Effect) -> Effect)
Multiple items
union case Eff.Eff: (('A -> Effect) -> Effect) -> Eff<'U,'A>

--------------------
module Eff

from Script

--------------------
type Eff<'U,'A (requires 'U :> Effect)> = | Eff of (('A -> Effect) -> Effect)

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

Full name: Script.State<_>
Multiple items
type Put<'S> =
  interface State<'S>
  new : v:'S * k:(unit -> Effect) -> Put<'S>
  member K : (unit -> Effect)
  member Value : 'S

Full name: Script.Put<_>

--------------------
new : v:'S * k:(unit -> Effect) -> Put<'S>
val v : 'S
val k : (unit -> Effect)
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val self : Put<'S>
override Put.UnPack : lambda:Lambda -> Effect

Full name: Script.Put`1.UnPack
val lambda : Lambda
abstract member Lambda.Invoke : ('X -> Effect) -> ('X -> Effect)
member Put.Value : 'S

Full name: Script.Put`1.Value
member Put.K : (unit -> Effect)

Full name: Script.Put`1.K
Multiple items
type Get<'S> =
  interface State<'S>
  new : k:('S -> Effect) -> Get<'S>
  member K : ('S -> Effect)

Full name: Script.Get<_>

--------------------
new : k:('S -> Effect) -> Get<'S>
val k : ('S -> Effect)
val self : Get<'S>
override Get.UnPack : lambda:Lambda -> Effect

Full name: Script.Get`1.UnPack
member Get.K : ('S -> Effect)

Full name: Script.Get`1.K
val get : unit -> Eff<#State<'S>,'S>

Full name: Script.get
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 Ask<'E> =
  interface Reader<'E>
  new : k:('E -> Effect) -> Ask<'E>
  member K : ('E -> Effect)

Full name: Script.Ask<_>

--------------------
new : k:('E -> Effect) -> Ask<'E>
val k : ('E -> Effect)
val self : Ask<'E>
override Ask.UnPack : lambda:Lambda -> Effect

Full name: Script.Ask`1.UnPack
member Ask.K : ('E -> Effect)

Full name: Script.Ask`1.K
val ask : unit -> Eff<#Reader<'E>,'E>

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

Full name: Script.runState
val state : 'S
val eff : Eff<#State<'S>,'A>
val loop : (('S * 'A -> Effect) -> 'S -> Effect -> Effect)
val k : ('S * 'A -> Effect)
val effect : Effect
val get : Get<'S>
property Get.K: 'S -> Effect
val put : Put<'S>
property Put.Value: 'S
property Put.K: unit -> Effect
val done' : Done<'A>
property Done.Value: 'A
abstract member Effect.UnPack : Lambda -> Effect
val self : Lambda
val k' : ('X -> Effect)
val x : '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 loop : (('A -> Effect) -> 'E -> Effect -> Effect)
val ask : Ask<'E>
property Ask.K: 'E -> Effect
val run : eff:Eff<#Effect,'A> -> 'A

Full name: Script.run
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

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

Full name: Script.example
val y : 'b
val x : 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<_>
Raw view New version

More information

Link:http://fssnip.net/7U3
Posted:17 days ago
Author:NIck Palladinos
Tags: effects