2 people like it.

A Simple Evaluator for F# quotations

A simple evaluator for F# quotations using TypeShape

Implementation

  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: 
open System
open System.Collections.Generic
open FSharp.Quotations
open FSharp.Quotations.Patterns
open FSharp.Quotations.DerivedPatterns
open FSharp.Quotations.ExprShape
open TypeShape

type CompiledExpr<'T> = Environment -> 'T

and Environment private (index : Map<Var, obj ref>) =
    new () = new Environment(Map.empty)
    member __.NewVar(v : Var, value : obj) = new Environment(Map.add v (ref value) index)
    member __.GetVar(v : Var) = index.[v].Value
    member __.UpdateVar(v : Var, value : obj) = index.[v] := value


let rec meaning<'T> (expr : Expr<'T>) : CompiledExpr<'T> =
    let EQ(f : CompiledExpr<'a>) = unbox<CompiledExpr<'T>> f
    let cast (e : Expr) = Expr.Cast<_> e

    match expr with
    | Value(:? 'T as t, _) -> fun _ -> t
    | Var var -> fun env -> env.GetVar var :?> 'T
    | Application(func, arg) ->
        let argShape = TypeShape.Create arg.Type
        argShape.Accept { new ITypeShapeVisitor<CompiledExpr<'T>> with
            member __.Visit<'Arg>() =
                let cfunc = meaning<'Arg -> 'T> (cast func)
                let carg = meaning<'Arg> (cast arg)
                EQ(fun env -> (cfunc env) (carg env)) }

    | Lambda(var, body) ->
        match shapeof<'T> with
        | Shape.FSharpFunc s ->
            s.Accept { new IFSharpFuncVisitor<CompiledExpr<'T>> with
                member __.Visit<'Dom, 'Cod> () = 
                    let cbody = meaning<'Cod> (cast body)
                    EQ(fun env (v : 'Dom) -> let env' = env.NewVar(var, v) in cbody env') }

        | _ -> failwith "internal error"

    | Let(var, bind, cont) ->
        let vShape = TypeShape.Create var.Type
        vShape.Accept { new ITypeShapeVisitor<CompiledExpr<'T>> with
            member __.Visit<'Var>() = 
                let cbind = meaning<'Var> (cast bind)
                let ccont = meaning<'T> (cast cont)
                fun env -> 
                    let v = cbind env
                    let env' = env.NewVar(var, v)
                    ccont env'
                |> EQ }

    | IfThenElse(cond, left, right) ->
        let ccond = meaning<bool> (cast cond)
        let cleft = meaning<'T> (cast left)
        let cright = meaning<'T> (cast right)
        fun env -> if ccond env then cleft env else cright env

    | Sequential(left, right) when left.Type = typeof<unit> ->
        let cleft = meaning<unit> (cast left)
        let cright = meaning<'T> (cast right)
        fun env -> cleft env ; cright env

    | SpecificCall <@ (+) @> (None, _, [left; right]) when typeof<'T> = typeof<int> ->
        let cleft = meaning<int> (cast left)
        let cright = meaning<int> (cast right)
        EQ(fun env -> cleft env + cright env)

    | SpecificCall <@ (-) @> (None, _, [left; right]) when typeof<'T> = typeof<int> ->
        let cleft = meaning<int> (cast left)
        let cright = meaning<int> (cast right)
        EQ(fun env -> cleft env - cright env)

    | SpecificCall <@ (*) @> (None, _, [left; right]) when typeof<'T> = typeof<int> ->
        let cleft = meaning<int> (cast left)
        let cright = meaning<int> (cast right)
        EQ(fun env -> cleft env * cright env)

    | SpecificCall <@ (=) @> (None, _, [left; right]) ->
        match TypeShape.Create left.Type with
        | Shape.Equality s ->
            s.Accept { new IEqualityVisitor<CompiledExpr<'T>> with
                member __.Visit<'a when 'a : equality>() =
                    let cleft = meaning<'a> (cast left)
                    let cright = meaning<'a> (cast right)
                    EQ(fun env -> cleft env = cright env) }

        | _ -> failwith "internal error"

    | SpecificCall <@ not @> (None, _, [pred]) ->
        let cleft = meaning<bool> (cast pred)
        EQ(not << cleft)

    | LetRecursive([(fvar, body)], cont) ->
        let fshape = TypeShape.Create fvar.Type
        fshape.Accept { new ITypeShapeVisitor<CompiledExpr<'T>> with
            member __.Visit<'Func>() =
                let cbody = meaning<'Func> (cast body)
                let ccont = meaning<'T> (cast cont)
                EQ(fun env -> 
                    let env' = env.NewVar(fvar, null)
                    env'.UpdateVar(fvar, cbody env')
                    ccont env') }

    | _ -> failwithf "Unsupported expression %A" expr


let compile (e : Expr<'T>) : unit -> 'T = 
    let c = meaning e
    fun () -> c (Environment())

let run (e : Expr<'T>) : 'T = 
    compile e ()

Samples

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
let factorial =
    run <@ 
            let rec factorial n = 
                if n = 0 then 1 
                else n * factorial (n - 1)

            factorial
        @>

[for i in 1 .. 10 -> factorial i]

let fib =
    run <@
            let rec fib n =
                match n with
                | 0 | 1 -> n
                | _ -> fib(n-2) + fib(n-1)

            fib
        @>

[for i in 1 .. 10 -> fib i]
namespace System
namespace System.Collections
namespace System.Collections.Generic
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
module Patterns

from Microsoft.FSharp.Quotations
module DerivedPatterns

from Microsoft.FSharp.Quotations
module ExprShape

from Microsoft.FSharp.Quotations
module TypeShape
type CompiledExpr<'T> = Environment -> 'T

Full name: Script.CompiledExpr<_>
Multiple items
type Environment =
  new : unit -> Environment
  private new : index:Map<Var,obj ref> -> Environment
  member GetVar : v:Var -> obj
  member NewVar : v:Var * value:obj -> Environment
  member UpdateVar : v:Var * value:obj -> unit

Full name: Script.Environment

--------------------
new : unit -> Environment
Multiple items
type Environment =
  new : unit -> Environment
  private new : index:Map<Var,obj ref> -> Environment
  member GetVar : v:Var -> obj
  member NewVar : v:Var * value:obj -> Environment
  member UpdateVar : v:Var * value:obj -> unit

Full name: Script.Environment

--------------------
new : unit -> Environment
private new : index:Map<Var,obj ref> -> Environment
val index : Map<Var,obj ref>
Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
  interface IEnumerable
  interface IComparable
  interface IEnumerable<KeyValuePair<'Key,'Value>>
  interface ICollection<KeyValuePair<'Key,'Value>>
  interface IDictionary<'Key,'Value>
  new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
  member Add : key:'Key * value:'Value -> Map<'Key,'Value>
  member ContainsKey : key:'Key -> bool
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
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:Type * ?isMutable:bool -> Var
type obj = Object

Full name: Microsoft.FSharp.Core.obj
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 empty<'Key,'T (requires comparison)> : Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.empty
member Environment.NewVar : v:Var * value:obj -> Environment

Full name: Script.Environment.NewVar
val v : Var
val value : obj
val add : key:'Key -> value:'T -> table:Map<'Key,'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.add
val __ : Environment
member Environment.GetVar : v:Var -> obj

Full name: Script.Environment.GetVar
active recognizer Value: Expr -> (obj * Type) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Value|_| )
member Environment.UpdateVar : v:Var * value:obj -> unit

Full name: Script.Environment.UpdateVar
val meaning : expr:Expr<'T> -> CompiledExpr<'T>

Full name: Script.meaning
val expr : Expr<'T>
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 EQ : (CompiledExpr<'a> -> Environment -> 'T)
val f : CompiledExpr<'a>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val cast : (Expr -> Expr<'a>)
val e : Expr
static member Expr.Cast : source:Expr -> Expr<'T>
val t : 'T
val var : Var
val env : Environment
member Environment.GetVar : v:Var -> obj
active recognizer Application: Expr -> (Expr * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Application|_| )
val func : Expr
val arg : Expr
val argShape : TypeShape
Multiple items
module TypeShape

--------------------
type TypeShape =
  private new : unit -> TypeShape
  abstract member Accept : ITypeShapeVisitor<'R> -> 'R
  abstract member ShapeInfo : TypeShapeInfo
  abstract member Type : Type
  override ToString : unit -> string
  static member Create : unit -> TypeShape<'T>
  static member Create : typ:Type -> TypeShape
  static member FromValue : obj:obj -> TypeShape

Full name: TypeShape.TypeShape

--------------------
type TypeShape<'T> =
  inherit TypeShape
  new : unit -> TypeShape<'T>
  override Accept : v:ITypeShapeVisitor<'a1> -> 'a1
  override Equals : o:obj -> bool
  override GetHashCode : unit -> int
  override ShapeInfo : TypeShapeInfo
  override Type : Type
  static member ( === ) : shape1:TypeShape * shape2:#TypeShape -> bool

Full name: TypeShape.TypeShape<_>

--------------------
new : unit -> TypeShape<'T>
static member TypeShape.Create : unit -> TypeShape<'T>
static member TypeShape.Create : typ:Type -> TypeShape
property Expr.Type: Type
abstract member TypeShape.Accept : ITypeShapeVisitor<'R> -> 'R
type ITypeShapeVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.ITypeShapeVisitor<_>
val cfunc : (Environment -> 'Arg -> 'T)
val carg : (Environment -> 'Arg)
active recognizer Lambda: Expr -> (Var * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Lambda|_| )
val body : Expr
val shapeof<'T> : TypeShape<'T>

Full name: TypeShape.shapeof
module Shape

from TypeShape
active recognizer FSharpFunc: TypeShape -> IShapeFSharpFunc option

Full name: TypeShape.Shape.( |FSharpFunc|_| )
val s : IShapeFSharpFunc
abstract member IShapeFSharpFunc.Accept : IFSharpFuncVisitor<'R> -> 'R
type IFSharpFuncVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpFuncVisitor<_>
val cbody : (Environment -> 'Cod)
val v : 'Dom
val env' : Environment
member Environment.NewVar : v:Var * value:obj -> Environment
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
active recognizer Let: Expr -> (Var * Expr * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Let|_| )
val bind : Expr
val cont : Expr
val vShape : TypeShape
property Var.Type: Type
val cbind : (Environment -> 'Var)
val ccont : (Environment -> 'T)
val v : 'Var
active recognizer IfThenElse: Expr -> (Expr * Expr * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |IfThenElse|_| )
val cond : Expr
val left : Expr
val right : Expr
val ccond : (Environment -> bool)
type bool = Boolean

Full name: Microsoft.FSharp.Core.bool
val cleft : (Environment -> 'T)
val cright : (Environment -> 'T)
active recognizer Sequential: Expr -> (Expr * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Sequential|_| )
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val cleft : (Environment -> unit)
active recognizer SpecificCall: Expr -> Expr -> (Expr option * Type list * Expr list) option

Full name: Microsoft.FSharp.Quotations.DerivedPatterns.( |SpecificCall|_| )
union case Option.None: Option<'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<_>
val cleft : (Environment -> int)
val cright : (Environment -> int)
active recognizer Equality: TypeShape -> IShapeEquality option

Full name: TypeShape.Shape.( |Equality|_| )
val s : IShapeEquality
abstract member IShapeEquality.Accept : IEqualityVisitor<'R> -> 'R
type IEqualityVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IEqualityVisitor<_>
val cleft : (Environment -> 'a) (requires equality)
val cright : (Environment -> 'a) (requires equality)
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val pred : Expr
val cleft : (Environment -> bool)
active recognizer LetRecursive: Expr -> ((Var * Expr) list * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |LetRecursive|_| )
val fvar : Var
val fshape : TypeShape
Multiple items
type Func<'TResult> =
  delegate of unit -> 'TResult

Full name: System.Func<_>

--------------------
type Func<'T,'TResult> =
  delegate of 'T -> 'TResult

Full name: System.Func<_,_>

--------------------
type Func<'T1,'T2,'TResult> =
  delegate of 'T1 * 'T2 -> 'TResult

Full name: System.Func<_,_,_>

--------------------
type Func<'T1,'T2,'T3,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 -> 'TResult

Full name: System.Func<_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 -> 'TResult

Full name: System.Func<_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 -> 'TResult

Full name: System.Func<_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'T12,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 * 'T12 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'T12,'T13,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 * 'T12 * 'T13 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'T12,'T13,'T14,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 * 'T12 * 'T13 * 'T14 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'T12,'T13,'T14,'T15,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 * 'T12 * 'T13 * 'T14 * 'T15 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_>

--------------------
type Func<'T1,'T2,'T3,'T4,'T5,'T6,'T7,'T8,'T9,'T10,'T11,'T12,'T13,'T14,'T15,'T16,'TResult> =
  delegate of 'T1 * 'T2 * 'T3 * 'T4 * 'T5 * 'T6 * 'T7 * 'T8 * 'T9 * 'T10 * 'T11 * 'T12 * 'T13 * 'T14 * 'T15 * 'T16 -> 'TResult

Full name: System.Func<_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_>
val cbody : (Environment -> 'Func)
member Environment.UpdateVar : v:Var * value:obj -> unit
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val compile : e:Expr<'T> -> (unit -> 'T)

Full name: Script.compile
val e : Expr<'T>
val c : (Environment -> 'T)
val run : e:Expr<'T> -> 'T

Full name: Script.run
val factorial : (int -> int)

Full name: Script.factorial
val factorial : (int -> int)
val n : int
val i : int
val fib : (int -> int)

Full name: Script.fib
val fib : (int -> int)

More information

Link:http://fssnip.net/7RW
Posted:7 years ago
Author:Eirik Tsarpalis
Tags: quotations , typeshape