2 people like it.

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
Multiple items
val exp : value:'T -> 'T (requires member Exp)

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

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

Full name: Script.exp
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