2 people like it.
Like the snippet!

Staged Interpreter

A staged intepreter that embeds a DSL in F#. Translated from MetaOCaml. Details in this paper http://www.cs.rice.edu/~taha/publications/journal/gttse07.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:

open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Linq.QuotationEvaluation
open Microsoft.FSharp.Quotations.Patterns
open Microsoft.FSharp.Quotations.DerivedPatterns


type exp = 
 Int of int | Varr of string | App of string * exp
 | Add of exp * exp | Sub of exp * exp
 | Mul of exp * exp | Div of exp * exp | Ifz of exp * exp * exp

type def = Declaration of string * string * exp

type prog = Program of def list * exp

// a program to calculate the factorial of 10
let y = Program ([Declaration
                    ("fact","x", 
                     Ifz(Varr "x", Int 1,
                         Mul(Varr"x", (App ("fact", Sub(Varr "x",Int 1))))))
                 ],
                 App ("fact", Int 10))


let rec eval2 e env (fenv : (string * Expr<int -> int>) list) =
    match e with
    | Int i -> <@ i @>
    | Varr s -> env |> List.find (fun (a, b) -> a = s) |> snd
    | App (s,e2) -> let f = fenv |> List.find (fun (a, b) -> a = s) |> snd
                    let arg = (eval2 e2 env fenv)
                    <@ (%f)(%arg) @>
    | Add (e1,e2)    -> <@ %(eval2 e1 env fenv) + %(eval2 e2 env fenv) @>
    | Sub (e1,e2)    -> <@ %(eval2 e1 env fenv) - %(eval2 e2 env fenv) @>
    | Mul (e1,e2)    -> <@ %(eval2 e1 env fenv) * %(eval2 e2 env fenv) @>
    | Div (e1,e2)    -> <@ %(eval2 e1 env fenv) / %(eval2 e2 env fenv) @>
    | Ifz (e1,e2,e3) -> <@ if %(eval2 e1 env fenv) = 0 then %(eval2 e2 env fenv) else %(eval2 e3 env fenv) @>

let rec peval2 p env fenv : Expr<int>=
    match p with
    | Program ([],e) -> eval2 e env fenv
    | Program (Declaration (s1,s2,e1)::tl,e) ->
        let fDummyVar = Var("fDummy", typeof<int -> int>)
        let xDummyVar = Var("xDummy", typeof<int>)
        let fDummy = Expr.Var(fDummyVar)
        let xDummy = Expr.Var(xDummyVar)
        let r = <@ let rec f (x : int) = 
                        %(eval2 e1 ((s2,<@ %%xDummy @>)::env) ((s1, <@ %%fDummy @>)::fenv))
                        in %(peval2 (Program(tl,e)) env ((s1,<@  %%fDummy @>)::fenv)) 
                @>
        let fActual, xActual = 
            match r with
            | LetRecursive([f,Lambda(x, _)],_) -> f, x
            | _ -> failwith "unexpected"
        r.Substitute(
            fun v -> match v with
                        | a  when a = fDummyVar -> Expr.Var(fActual) |> Some
                        | b  when b = xDummyVar -> Expr.Var(xActual) |> Some
                        | _                     -> Expr.Var(v) |> Some) |> Expr.Cast

let z = peval2 y [] []

let w = Swensen.Unquote.Operators.eval z // result should be 3628800

namespace Microsoft

namespace Microsoft.FSharp

namespace Microsoft.FSharp.Quotations

namespace Microsoft.FSharp.Linq

module Patterns

from Microsoft.FSharp.Quotations

module DerivedPatterns

from Microsoft.FSharp.Quotations

union case exp.Int: int -> exp

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 exp.Varr: string -> exp

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

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

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string

union case exp.App: string * exp -> exp

union case exp.Add: exp * exp -> exp

union case exp.Sub: exp * exp -> exp

union case exp.Mul: exp * exp -> exp

union case exp.Div: exp * exp -> exp

union case exp.Ifz: exp * exp * exp -> exp

type def = | Declaration of string * string * exp

Full name: Script.def

union case def.Declaration: string * string * exp -> def

type prog = | Program of def list * exp

Full name: Script.prog

union case prog.Program: def list * exp -> prog

type 'T list = List<'T>

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

val y : prog

Full name: Script.y

val eval2 : e:exp -> env:(string * Expr<int>) list -> fenv:(string * Expr<(int -> int)>) list -> Expr<int>

Full name: Script.eval2

val e : exp

val env : (string * Expr<int>) list

val fenv : (string * Expr<(int -> int)>) list

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 i : int

val s : string

Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

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

val find : predicate:('T -> bool) -> list:'T list -> 'T

Full name: Microsoft.FSharp.Collections.List.find

val a : string

val b : Expr<int>

val snd : tuple:('T1 * 'T2) -> 'T2

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

val e2 : exp

val f : Expr<(int -> int)>

val b : Expr<(int -> int)>

val arg : Expr<int>

val e1 : exp

val e3 : exp

val peval2 : p:prog -> env:(string * Expr<int>) list -> fenv:(string * Expr<(int -> int)>) list -> Expr<int>

Full name: Script.peval2

val p : prog

val s1 : string

val s2 : string

val tl : def list

val fDummyVar : Var

Multiple items
active recognizer Var: Expr -> Var option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Var|_| )

--------------------
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:System.Type * ?isMutable:bool -> Var

val typeof<'T> : System.Type

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

val xDummyVar : Var

val fDummy : Expr

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

val xDummy : Expr

val r : Expr<int>

val f : (int -> int)

val x : int

val fActual : Var

val xActual : Var

active recognizer LetRecursive: Expr -> ((Var * Expr) list * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |LetRecursive|_| )

val f : Var

active recognizer Lambda: Expr -> (Var * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Lambda|_| )

val x : Var

val failwith : message:string -> 'T

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

member Expr.Substitute : substitution:(Var -> Expr option) -> Expr

val v : Var

val a : Var

union case Option.Some: Value: 'T -> Option<'T>

val b : Var

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

val z : Expr<int>

Full name: Script.z

val w : obj

Full name: Script.w

module Operators

from Microsoft.FSharp.Core

Raw view Test code New version

More information

Link:	http://fssnip.net/gk
Posted:	11 years ago
Author:	Muigai
Tags:	interpreter metaprogramming