2 people like it.
Like the snippet!
Stage your boilerplate
Application of staging to "scrap your boilerplate" generic programming technique.
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:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
|
open Microsoft.FSharp.Quotations
// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
let var = new Var("__temp__", typeof<'T>)
Expr.Cast<_>(Expr.Lambda(var, f (Expr.Cast<_>(Expr.Var var))))
// encoding of rank-2 polymorphism
type IForallT =
abstract Invoke<'T> : ITerm<'T> -> (Expr<'T> -> Expr<'T>)
abstract Invoke<'T> : IRecTerm<'T> -> Expr<'T -> 'T>
and IForallQ<'R> =
abstract Invoke<'T> : ITerm<'T> -> (Expr<'T> -> Expr<'R>)
abstract Invoke<'T> : IRecTerm<'T> -> Expr<'T -> 'R>
// Type Class encoding
and ITerm<'T> =
abstract gmapT : IForallT -> (Expr<'T> -> Expr<'T>)
// TODO: abstract gmapQ<'R> : IForallQ<'R> -> (Expr<'T> -> Expr<'R list>)
and IRecTerm<'T> =
abstract gmapT : IForallT -> Expr<'T -> 'T>
// TODO: abstract gmapQ<'R> : IForallQ<'R> -> Expr<'T -> 'R list>
// Example - Company
type Company = C of Dept list
and Dept = D of Name * Manager * SubUnit list
and SubUnit = PU of Employee | DU of Dept
and Employee = E of Person * Salary
and Person = P of Name * Address
and Salary = S of float
and Manager = M of Employee
and Name = N of string
and Address = A of string
// Data for a small company
let ralf = E (P (N "Ralf", A "Amsterdam"), S 8000.0)
let joost = E (P (N "Joost", A "Amsterdam"), S 1000.0)
let marlow = E (P (N "Marlow", A "Cambridge"), S 2000.0)
let blair = E (P (N "Blair", A "London"), S 100000.0)
let genCom =
C [ D (N "Research", M ralf, [PU joost; PU marlow]);
D (N "Strategy", M blair, [])]
// Term Representations
type CompanyTerm(deptTerm : IRecTerm<Dept>) =
interface ITerm<Company> with
member self.gmapT forallT = fun company ->
<@ let (C depts) = %company
C ( depts |> List.map (fun dept -> (% forallT.Invoke deptTerm ) dept )) @>
type DeptTerm(nameTerm : ITerm<Name>, managerTerm : ITerm<Manager>, subUnitTermf : IRecTerm<Dept> -> ITerm<SubUnit>) =
interface IRecTerm<Dept> with
member self.gmapT forallT = <@ fun dept ->
let (D (name, manager, subUnits)) = dept
D ( (% (lambda (fun name -> forallT.Invoke nameTerm name)) ) name,
(% (lambda (fun manager -> forallT.Invoke managerTerm manager)) ) manager,
subUnits |> List.map (fun subUnit -> (% (lambda (fun subUnit -> forallT.Invoke (subUnitTermf self) subUnit)) ) subUnit )) @>
type SubUnitTerm(employeeTerm : ITerm<Employee>, deptTerm : IRecTerm<Dept>) =
interface ITerm<SubUnit> with
member self.gmapT forallT = fun subUnit ->
<@ match %subUnit with
| PU employee -> PU ((% (lambda (fun employee -> forallT.Invoke employeeTerm employee)) ) employee)
| DU dept -> DU ((% forallT.Invoke deptTerm ) dept) @>
type ManagerTerm(employeeTerm : ITerm<Employee>) =
interface ITerm<Manager> with
member self.gmapT forallT = fun manager ->
<@ let (M employee) = %manager
M ( (% (lambda (fun employee -> forallT.Invoke employeeTerm employee)) ) employee ) @>
type EmployeeTerm(personTerm : ITerm<Person>, salaryTerm : ITerm<Salary>) =
interface ITerm<Employee> with
member self.gmapT forallT = fun employee ->
<@ let (E (person, salary)) = %employee
E ( (% (lambda (fun person -> forallT.Invoke personTerm person)) ) person,
(% (lambda (fun salary -> forallT.Invoke salaryTerm salary)) ) salary) @>
type PersonTerm(nameTerm : ITerm<Name>, addressTerm : ITerm<Address>) =
interface ITerm<Person> with
member self.gmapT forallT = fun person ->
<@ let (P (name, address)) = %person
P ( (% (lambda (fun name -> forallT.Invoke nameTerm name)) ) name,
(% (lambda (fun address -> forallT.Invoke addressTerm address)) ) address) @>
type SalaryTerm() =
interface ITerm<Salary> with
member self.gmapT _ = id
type NameTerm() =
interface ITerm<Name> with
member self.gmapT _ = id
type AddressTerm() =
interface ITerm<Address> with
member self.gmapT _ = id
let nameTerm = new NameTerm()
let addressTerm = new AddressTerm()
let salaryTerm = new SalaryTerm()
let personTerm = new PersonTerm(nameTerm, addressTerm)
let employeeTerm = new EmployeeTerm(personTerm, salaryTerm)
let managerTerm = new ManagerTerm(employeeTerm)
let subUnitTerm deptTerm = new SubUnitTerm(employeeTerm, deptTerm) :> ITerm<SubUnit>
let deptTerm = new DeptTerm(nameTerm, managerTerm, subUnitTerm)
let companyTerm = new CompanyTerm(deptTerm)
// Type safe conversion functions
let cast (v : Expr<'T>) : Expr<'R> = v :> Expr :?> Expr<'R>
let mkT (f : Expr<'T> -> Expr<'T>) =
let dict = new System.Collections.Generic.Dictionary<System.Type, Expr>()
{ new IForallT with
member self.Invoke<'R> (term : ITerm<'R>) : Expr<'R> -> Expr<'R> =
if typeof<'T> = typeof<'R> then
(fun (v : Expr<'R>) -> v |> cast |> f |> cast)
else term.gmapT self
member self.Invoke<'R> (term : IRecTerm<'R>) : Expr<'R -> 'R> =
match dict.TryGetValue(typeof<'R>) with
| (true, expr) -> expr :?> _
| (false, _) ->
<@ let rec loop x =
(% lambda (fun recf -> let recf' = if typeof<'T> = typeof<'R> then
lambda (fun (v : Expr<'R>) ->
v |> cast |> f |> cast)
else recf
dict.Add(typeof<'R>, recf'); <@ () @>) ) loop
(% term.gmapT self ) x
loop @> }
// transformations-queries
let everywhere (forallT : IForallT) (term : ITerm<'T>) : Expr<'T -> 'T> =
lambda (forallT.Invoke term)
let everywhereRec (forallT : IForallT) (term : IRecTerm<'T>) : Expr<'T -> 'T> =
forallT.Invoke term
// Example
let nameToUpper (name : Expr<Name>) =
<@ let (N name) = %name in N (name.ToUpper()) @>
everywhere (mkT nameToUpper) personTerm
let incSalary (k : float) (salary : Expr<Salary>) =
<@ let (S value) = %salary in S (value * (1.0 + k)) @>
everywhere (mkT (incSalary 10.0)) companyTerm
|
namespace Microsoft
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
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 var : Var
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:System.Type * ?isMutable:bool -> Var
val typeof<'T> : System.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 IForallT =
interface
abstract member Invoke : ITerm<'T> -> (Expr<'T> -> Expr<'T>)
abstract member Invoke : IRecTerm<'T> -> Expr<('T -> 'T)>
end
Full name: Script.IForallT
abstract member IForallT.Invoke : ITerm<'T> -> (Expr<'T> -> Expr<'T>)
Full name: Script.IForallT.Invoke
type ITerm<'T> =
interface
abstract member gmapT : IForallT -> (Expr<'T> -> Expr<'T>)
end
Full name: Script.ITerm<_>
abstract member IForallT.Invoke : IRecTerm<'T> -> Expr<('T -> 'T)>
Full name: Script.IForallT.Invoke
type IRecTerm<'T> =
interface
abstract member gmapT : IForallT -> Expr<('T -> 'T)>
end
Full name: Script.IRecTerm<_>
type IForallQ<'R> =
interface
abstract member Invoke : ITerm<'T> -> (Expr<'T> -> Expr<'R>)
abstract member Invoke : IRecTerm<'T> -> Expr<('T -> 'R)>
end
Full name: Script.IForallQ<_>
abstract member IForallQ.Invoke : ITerm<'T> -> (Expr<'T> -> Expr<'R>)
Full name: Script.IForallQ`1.Invoke
abstract member IForallQ.Invoke : IRecTerm<'T> -> Expr<('T -> 'R)>
Full name: Script.IForallQ`1.Invoke
abstract member ITerm.gmapT : IForallT -> (Expr<'T> -> Expr<'T>)
Full name: Script.ITerm`1.gmapT
abstract member IRecTerm.gmapT : IForallT -> Expr<('T -> 'T)>
Full name: Script.IRecTerm`1.gmapT
type Company = | C of Dept list
Full name: Script.Company
union case Company.C: Dept list -> Company
type Dept = | D of Name * Manager * SubUnit list
Full name: Script.Dept
type 'T list = List<'T>
Full name: Microsoft.FSharp.Collections.list<_>
union case Dept.D: Name * Manager * SubUnit list -> Dept
type Name = | N of string
Full name: Script.Name
type Manager = | M of Employee
Full name: Script.Manager
type SubUnit =
| PU of Employee
| DU of Dept
Full name: Script.SubUnit
union case SubUnit.PU: Employee -> SubUnit
type Employee = | E of Person * Salary
Full name: Script.Employee
union case SubUnit.DU: Dept -> SubUnit
union case Employee.E: Person * Salary -> Employee
type Person = | P of Name * Address
Full name: Script.Person
type Salary = | S of float
Full name: Script.Salary
union case Person.P: Name * Address -> Person
type Address = | A of string
Full name: Script.Address
union case Salary.S: float -> Salary
Multiple items
val float : value:'T -> float (requires member op_Explicit)
Full name: Microsoft.FSharp.Core.Operators.float
--------------------
type float = System.Double
Full name: Microsoft.FSharp.Core.float
--------------------
type float<'Measure> = float
Full name: Microsoft.FSharp.Core.float<_>
union case Manager.M: Employee -> Manager
union case Name.N: string -> Name
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 Address.A: string -> Address
val ralf : Employee
Full name: Script.ralf
val joost : Employee
Full name: Script.joost
val marlow : Employee
Full name: Script.marlow
val blair : Employee
Full name: Script.blair
val genCom : Company
Full name: Script.genCom
Multiple items
type CompanyTerm =
interface ITerm<Company>
new : deptTerm:IRecTerm<Dept> -> CompanyTerm
Full name: Script.CompanyTerm
--------------------
new : deptTerm:IRecTerm<Dept> -> CompanyTerm
val deptTerm : IRecTerm<Dept>
val self : CompanyTerm
override CompanyTerm.gmapT : forallT:IForallT -> (Expr<Company> -> Expr<Company>)
Full name: Script.CompanyTerm.gmapT
val forallT : IForallT
val company : Expr<Company>
val depts : Dept list
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 map : mapping:('T -> 'U) -> list:'T list -> 'U list
Full name: Microsoft.FSharp.Collections.List.map
val dept : Dept
abstract member IForallT.Invoke : ITerm<'T> -> (Expr<'T> -> Expr<'T>)
abstract member IForallT.Invoke : IRecTerm<'T> -> Expr<('T -> 'T)>
Multiple items
type DeptTerm =
interface IRecTerm<Dept>
new : nameTerm:ITerm<Name> * managerTerm:ITerm<Manager> * subUnitTermf:(IRecTerm<Dept> -> ITerm<SubUnit>) -> DeptTerm
Full name: Script.DeptTerm
--------------------
new : nameTerm:ITerm<Name> * managerTerm:ITerm<Manager> * subUnitTermf:(IRecTerm<Dept> -> ITerm<SubUnit>) -> DeptTerm
val nameTerm : ITerm<Name>
val managerTerm : ITerm<Manager>
val subUnitTermf : (IRecTerm<Dept> -> ITerm<SubUnit>)
val self : DeptTerm
override DeptTerm.gmapT : forallT:IForallT -> Expr<(Dept -> Dept)>
Full name: Script.DeptTerm.gmapT
val name : Name
val manager : Manager
val subUnits : SubUnit list
val name : Expr<Name>
val manager : Expr<Manager>
val subUnit : SubUnit
val subUnit : Expr<SubUnit>
Multiple items
type SubUnitTerm =
interface ITerm<SubUnit>
new : employeeTerm:ITerm<Employee> * deptTerm:IRecTerm<Dept> -> SubUnitTerm
Full name: Script.SubUnitTerm
--------------------
new : employeeTerm:ITerm<Employee> * deptTerm:IRecTerm<Dept> -> SubUnitTerm
val employeeTerm : ITerm<Employee>
val self : SubUnitTerm
override SubUnitTerm.gmapT : forallT:IForallT -> (Expr<SubUnit> -> Expr<SubUnit>)
Full name: Script.SubUnitTerm.gmapT
val employee : Employee
val employee : Expr<Employee>
Multiple items
type ManagerTerm =
interface ITerm<Manager>
new : employeeTerm:ITerm<Employee> -> ManagerTerm
Full name: Script.ManagerTerm
--------------------
new : employeeTerm:ITerm<Employee> -> ManagerTerm
val self : ManagerTerm
override ManagerTerm.gmapT : forallT:IForallT -> (Expr<Manager> -> Expr<Manager>)
Full name: Script.ManagerTerm.gmapT
Multiple items
type EmployeeTerm =
interface ITerm<Employee>
new : personTerm:ITerm<Person> * salaryTerm:ITerm<Salary> -> EmployeeTerm
Full name: Script.EmployeeTerm
--------------------
new : personTerm:ITerm<Person> * salaryTerm:ITerm<Salary> -> EmployeeTerm
val personTerm : ITerm<Person>
val salaryTerm : ITerm<Salary>
val self : EmployeeTerm
override EmployeeTerm.gmapT : forallT:IForallT -> (Expr<Employee> -> Expr<Employee>)
Full name: Script.EmployeeTerm.gmapT
val person : Person
val salary : Salary
val person : Expr<Person>
val salary : Expr<Salary>
Multiple items
type PersonTerm =
interface ITerm<Person>
new : nameTerm:ITerm<Name> * addressTerm:ITerm<Address> -> PersonTerm
Full name: Script.PersonTerm
--------------------
new : nameTerm:ITerm<Name> * addressTerm:ITerm<Address> -> PersonTerm
val addressTerm : ITerm<Address>
val self : PersonTerm
override PersonTerm.gmapT : forallT:IForallT -> (Expr<Person> -> Expr<Person>)
Full name: Script.PersonTerm.gmapT
val address : Address
val address : Expr<Address>
Multiple items
type SalaryTerm =
interface ITerm<Salary>
new : unit -> SalaryTerm
Full name: Script.SalaryTerm
--------------------
new : unit -> SalaryTerm
val self : SalaryTerm
override SalaryTerm.gmapT : IForallT -> (Expr<Salary> -> Expr<Salary>)
Full name: Script.SalaryTerm.gmapT
val id : x:'T -> 'T
Full name: Microsoft.FSharp.Core.Operators.id
Multiple items
type NameTerm =
interface ITerm<Name>
new : unit -> NameTerm
Full name: Script.NameTerm
--------------------
new : unit -> NameTerm
val self : NameTerm
override NameTerm.gmapT : IForallT -> (Expr<Name> -> Expr<Name>)
Full name: Script.NameTerm.gmapT
Multiple items
type AddressTerm =
interface ITerm<Address>
new : unit -> AddressTerm
Full name: Script.AddressTerm
--------------------
new : unit -> AddressTerm
val self : AddressTerm
override AddressTerm.gmapT : IForallT -> (Expr<Address> -> Expr<Address>)
Full name: Script.AddressTerm.gmapT
val nameTerm : NameTerm
Full name: Script.nameTerm
val addressTerm : AddressTerm
Full name: Script.addressTerm
val salaryTerm : SalaryTerm
Full name: Script.salaryTerm
val personTerm : PersonTerm
Full name: Script.personTerm
val employeeTerm : EmployeeTerm
Full name: Script.employeeTerm
val managerTerm : ManagerTerm
Full name: Script.managerTerm
val subUnitTerm : deptTerm:IRecTerm<Dept> -> ITerm<SubUnit>
Full name: Script.subUnitTerm
val deptTerm : DeptTerm
Full name: Script.deptTerm
val companyTerm : CompanyTerm
Full name: Script.companyTerm
val cast : v:Expr<'T> -> Expr<'R>
Full name: Script.cast
val v : Expr<'T>
val mkT : f:(Expr<'T> -> Expr<'T>) -> IForallT
Full name: Script.mkT
val f : (Expr<'T> -> Expr<'T>)
val dict : System.Collections.Generic.Dictionary<System.Type,Expr>
namespace System
namespace System.Collections
namespace System.Collections.Generic
Multiple items
type Dictionary<'TKey,'TValue> =
new : unit -> Dictionary<'TKey, 'TValue> + 5 overloads
member Add : key:'TKey * value:'TValue -> unit
member Clear : unit -> unit
member Comparer : IEqualityComparer<'TKey>
member ContainsKey : key:'TKey -> bool
member ContainsValue : value:'TValue -> bool
member Count : int
member GetEnumerator : unit -> Enumerator<'TKey, 'TValue>
member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
member Item : 'TKey -> 'TValue with get, set
...
nested type Enumerator
nested type KeyCollection
nested type ValueCollection
Full name: System.Collections.Generic.Dictionary<_,_>
--------------------
System.Collections.Generic.Dictionary() : unit
System.Collections.Generic.Dictionary(capacity: int) : unit
System.Collections.Generic.Dictionary(comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>) : unit
System.Collections.Generic.Dictionary(capacity: int, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
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
val self : IForallT
val term : ITerm<'R>
val v : Expr<'R>
abstract member ITerm.gmapT : IForallT -> (Expr<'T> -> Expr<'T>)
val term : IRecTerm<'R>
System.Collections.Generic.Dictionary.TryGetValue(key: System.Type, value: byref<Expr>) : bool
val expr : Expr
val loop : ('R -> 'R)
val x : 'R
val recf : Expr<('R -> 'R)>
val recf' : Expr<('R -> 'R)>
System.Collections.Generic.Dictionary.Add(key: System.Type, value: Expr) : unit
abstract member IRecTerm.gmapT : IForallT -> Expr<('T -> 'T)>
val everywhere : forallT:IForallT -> term:ITerm<'T> -> Expr<('T -> 'T)>
Full name: Script.everywhere
val term : ITerm<'T>
val everywhereRec : forallT:IForallT -> term:IRecTerm<'T> -> Expr<('T -> 'T)>
Full name: Script.everywhereRec
val term : IRecTerm<'T>
val nameToUpper : name:Expr<Name> -> Expr<Name>
Full name: Script.nameToUpper
val name : string
System.String.ToUpper() : string
System.String.ToUpper(culture: System.Globalization.CultureInfo) : string
val incSalary : k:float -> salary:Expr<Salary> -> Expr<Salary>
Full name: Script.incSalary
val k : float
val value : float
More information