2 people like it.

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
Raw view Test code New version

More information

Link:http://fssnip.net/sJ
Posted:8 years ago
Author:Nick Palladinos
Tags: staging , syb , generic programming