Staged Free Monads

Transform a Free Monad interpreter to a compiler through staging.

 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:

// Staged Free Μonads

#r "packages/FSharp.Compiler.Service.1.3.1.0/lib/net45/FSharp.Compiler.Service.dll"
#r "packages/QuotationCompiler.0.0.7-alpha/lib/net45/QuotationCompiler.dll"

open System
open QuotationCompiler
open Microsoft.FSharp.Quotations

// helper functions
let counter = ref 0
let rec generateVars (types : Type list) : Var list = 
    match types with 
    | [] -> []
    | t :: ts -> 
        incr counter
        let var = new Var(sprintf "__paramTemp_%d__" !counter, t)
        var :: generateVars ts

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    let [var] = generateVars [typeof<'T>]
    Expr.Cast<_>(Expr.Lambda(var,  f (Expr.Cast<_>(Expr.Var var))))


// Basic Types
type Ops<'Next> =
    | Set of Expr<int> * 'Next
    | Get of (Expr<int> -> 'Next)

type Program<'T> = 
    | Done of Expr<'T>
    | Wrap of Ops<Program<'T>>

// helper functions
let get : Program<int> = 
    Wrap <| Get (fun v -> Done v)

let set : Expr<int> -> Program<unit> = fun v ->
    Wrap <| Set (v, Done <@ () @>)

let map : ('T -> 'R) -> Ops<'T> -> Ops<'R> = 
    fun f p ->
        match p with
        | Set (v, next) -> Set (v, f next)
        | Get next -> Get (f << next)
    
let return' : Expr<'T> -> Program<'T> = fun v -> 
    Done v

let rec bind : (Expr<'T> -> Program<'R>) -> Program<'T> -> Program<'R> = 
    fun f p -> 
        match p with
        | Wrap ops ->
            Wrap <| map (bind f) ops 
        | Done v -> f v

let rec compile : Program<'T> -> Expr<int> -> (Expr<int> -> Expr<'T> -> Expr<'T>) -> Expr<'T> = 
    fun p x k -> 
        match p with
        | Wrap ops ->
            match ops with
            | Set (v, next) ->
                <@ let v' = %v in (% lambda (fun v -> compile next v k)) v' @>
            | Get f ->
                compile (f x) x k
        | Done v -> 
            k x v
                 

// Program Builder
type Program() = 
    member self.Return v = 
        return' v
    member self.Bind(p, f) = 
        bind f p

let prg = new Program()

// example
let example : Program<int> = 
    prg {
        let! v = get
        let! _ = set <@ %v * 2 @>
        let! v' = get
        return <@ %v' + 1 @>
    }

let exec = QuotationCompiler.ToFunc (lambda (fun x -> compile example x (fun _ v -> v))) ()

exec 2 // 5

namespace System

namespace QuotationCompiler

namespace Microsoft

namespace Microsoft.FSharp

namespace Microsoft.FSharp.Quotations

val counter : int ref

Full name: Script.counter

Multiple items
val ref : value:'T -> 'T ref

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

--------------------
type 'T ref = Ref<'T>

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

val generateVars : types:Type list -> Var list

Full name: Script.generateVars

val types : Type list

type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type

type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>

Multiple items
type Var =
  interface IComparable
  new : name:string * typ:Type * ?isMutable:bool -> Var
  member IsMutable : bool
  member Name : string
  member Type : Type
  static member Global : name:string * typ:Type -> Var

Full name: Microsoft.FSharp.Quotations.Var

--------------------
new : name:string * typ:Type * ?isMutable:bool -> Var

val t : Type

val ts : Type list

val incr : cell:int ref -> unit

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

val var : Var

val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf

val lambda : f:(Expr<'T> -> Expr<'R>) -> Expr<('T -> 'R)>

Full name: Script.lambda

val f : (Expr<'T> -> Expr<'R>)

Multiple items
type Expr =
  override Equals : obj:obj -> bool
  member GetFreeVars : unit -> seq<Var>
  member Substitute : substitution:(Var -> Expr option) -> Expr
  member ToString : full:bool -> string
  member CustomAttributes : Expr list
  member Type : Type
  static member AddressOf : target:Expr -> Expr
  static member AddressSet : target:Expr * value:Expr -> Expr
  static member Application : functionExpr:Expr * argument:Expr -> Expr
  static member Applications : functionExpr:Expr * arguments:Expr list list -> Expr
  ...

Full name: Microsoft.FSharp.Quotations.Expr

--------------------
type Expr<'T> =
  inherit Expr
  member Raw : Expr

Full name: Microsoft.FSharp.Quotations.Expr<_>

val typeof<'T> : Type

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

static member Expr.Cast : source:Expr -> Expr<'T>

static member Expr.Lambda : parameter:Var * body:Expr -> Expr

static member Expr.Var : variable:Var -> Expr

type Ops<'Next> =
| Set of Expr<int> * 'Next
| Get of (Expr<int> -> 'Next)

Full name: Script.Ops<_>

Multiple items
union case Ops.Set: Expr<int> * 'Next -> Ops<'Next>

--------------------
module Set

from Microsoft.FSharp.Collections

--------------------
type Set<'T (requires comparison)> =
  interface IComparable
  interface IEnumerable
  interface IEnumerable<'T>
  interface ICollection<'T>
  new : elements:seq<'T> -> Set<'T>
  member Add : value:'T -> Set<'T>
  member Contains : value:'T -> bool
  override Equals : obj -> bool
  member IsProperSubsetOf : otherSet:Set<'T> -> bool
  member IsProperSupersetOf : otherSet:Set<'T> -> bool
  ...

Full name: Microsoft.FSharp.Collections.Set<_>

--------------------
new : elements:seq<'T> -> Set<'T>

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<_>

union case Ops.Get: (Expr<int> -> 'Next) -> Ops<'Next>

type Program<'T> =
| Done of Expr<'T>
| Wrap of Ops<Program<'T>>

Full name: Script.Program<_>

union case Program.Done: Expr<'T> -> Program<'T>

union case Program.Wrap: Ops<Program<'T>> -> Program<'T>

val get : Program<int>

Full name: Script.get

val v : Expr<int>

val set : v:Expr<int> -> Program<unit>

Full name: Script.set

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val map : f:('T -> 'R) -> p:Ops<'T> -> Ops<'R>

Full name: Script.map

val f : ('T -> 'R)

val p : Ops<'T>

val next : 'T

val next : (Expr<int> -> 'T)

val return' : v:Expr<'T> -> Program<'T>

Full name: Script.return'

val v : Expr<'T>

val bind : f:(Expr<'T> -> Program<'R>) -> p:Program<'T> -> Program<'R>

Full name: Script.bind

val f : (Expr<'T> -> Program<'R>)

val p : Program<'T>

val ops : Ops<Program<'T>>

val compile : p:Program<'T> -> x:Expr<int> -> k:(Expr<int> -> Expr<'T> -> Expr<'T>) -> Expr<'T>

Full name: Script.compile

val x : Expr<int>

val k : (Expr<int> -> Expr<'T> -> Expr<'T>)

val next : Program<'T>

val v' : int

val f : (Expr<int> -> Program<'T>)

Multiple items
type Program =
  new : unit -> Program
  member Bind : p:Program<'a> * f:(Expr<'a> -> Program<'b>) -> Program<'b>
  member Return : v:Expr<'c> -> Program<'c>

Full name: Script.Program

--------------------
type Program<'T> =
  | Done of Expr<'T>
  | Wrap of Ops<Program<'T>>

Full name: Script.Program<_>

--------------------
new : unit -> Program

val self : Program

member Program.Return : v:Expr<'c> -> Program<'c>

Full name: Script.Program.Return

val v : Expr<'c>

member Program.Bind : p:Program<'a> * f:(Expr<'a> -> Program<'b>) -> Program<'b>

Full name: Script.Program.Bind

val p : Program<'a>

val f : (Expr<'a> -> Program<'b>)

val prg : Program

Full name: Script.prg

val example : Program<int>

Full name: Script.example

val v' : Expr<int>

val exec : (int -> int)

Full name: Script.exec

Multiple items
namespace QuotationCompiler

--------------------
type QuotationCompiler =
  private new : unit -> QuotationCompiler
  static member Eval : expr:Expr<'T> * ?useCache:bool -> 'T
  static member ToAssembly : expr:Expr * ?targetDirectory:string * ?assemblyName:string * ?compiledModuleName:string * ?compiledFunctionName:string -> string
  static member ToDynamicAssembly : expr:Expr * ?assemblyName:string -> MethodInfo
  static member ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

Full name: QuotationCompiler.QuotationCompiler

static member QuotationCompiler.ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

Raw view Test code New version

More information

Link:	http://fssnip.net/7SZ
Posted:	7 years ago
Author:	Nick Palladinos
Tags:	freemonad , staging