9 people like it.

Scrap Your Boilerplate

Scrap Your Boilerplate with the help of F#. Based on the original paper by Ralf Laemmel and Simon Peyton Jones.

  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: 
// http://research.microsoft.com/en-us/um/people/simonpj/papers/hmap/hmap.ps

// Type safe conversion functions
let cast<'T, 'R> (v : 'T) : 'R = v :> obj :?> 'R
let mkT<'T, 'R> (f : 'T -> 'T) : 'R -> 'R =
    if typeof<'T> = typeof<'R> then (fun (v : 'R) -> v |> cast |> f |> cast) else id
let mkQ (r : 'R) (q : 'B -> 'R) (a : 'A) : 'R =
    if typeof<'A> = typeof<'B> then
        a |> cast |> q
    else r

// encoding of rank-2 polymorphism
type IForallT = 
    abstract Invoke<'T when 'T :> ITerm<'T>> : 'T -> 'T 
and IForallQ<'R> = 
    abstract Invoke<'T when 'T :> ITerm<'T>> : 'T -> 'R
// Type Class encoding
and ITerm<'T when 'T :> ITerm<'T>> = 
    abstract gmapT : IForallT -> 'T
    abstract gmapQ<'R> : IForallQ<'R> -> 'R list

// recursive transformations-queries
let rec everywhere<'T when 'T :> ITerm<'T>> (forallT : IForallT) (term : 'T) : 'T = 
    forallT.Invoke (term.gmapT { new IForallT with 
                                    member self.Invoke term' = 
                                        everywhere forallT term' })

let rec everything<'T, 'R when 'T :> ITerm<'T>> (k : 'R -> 'R -> 'R) (forallQ : IForallQ<'R>) (term : 'T) : 'R =
    List.fold k (forallQ.Invoke term) (term.gmapQ { new IForallQ<'R> with 
                                                        member self.Invoke term' = 
                                                            everything k forallQ term' })

// Example - Company

type Company = C of Dept list with
    interface ITerm<Company> with
            member self.gmapT forallT =
                let (C depts) = self
                C (depts |> List.map forallT.Invoke)
            member self.gmapQ forallQ = 
                let (C depts) = self
                depts |> List.map forallQ.Invoke
and Dept = D of Name * Manager * SubUnit list with
    interface ITerm<Dept> with
            member self.gmapT forallT =
                let (D (name, manager, subUnits)) = self
                D (forallT.Invoke name, forallT.Invoke manager, subUnits |> List.map forallT.Invoke)
            member self.gmapQ forallQ = 
                let (D (name, manager, subUnits)) = self
                [forallQ.Invoke name; forallQ.Invoke manager] @ (List.map forallQ.Invoke subUnits)
and SubUnit = PU of Employee | DU of Dept with
    interface ITerm<SubUnit> with
            member self.gmapT forallT = 
                match self with
                | PU employee -> PU (forallT.Invoke employee)
                | DU dept -> DU (forallT.Invoke dept)
            member self.gmapQ forallQ = 
                match self with
                | PU employee -> [forallQ.Invoke employee]
                | DU dept -> [forallQ.Invoke dept]
and Employee = E of Person * Salary with
    interface ITerm<Employee> with
            member self.gmapT forallT = 
                let (E (person, salary)) = self
                E (forallT.Invoke person, forallT.Invoke salary)
            member self.gmapQ forallQ = 
                let (E (person, salary)) = self
                [forallQ.Invoke person; forallQ.Invoke salary]
and Person = P of Name * Address with
    interface ITerm<Person> with
            member self.gmapT forallT = 
                let (P (name, address)) = self
                P (forallT.Invoke name, forallT.Invoke address)
            member self.gmapQ forallQ = 
                let (P (name, address)) = self
                [forallQ.Invoke name; forallQ.Invoke address]
and Salary = S of float with
    interface ITerm<Salary> with
            member self.gmapT forallT = self
            member self.gmapQ forallQ = []
and Manager = M of Employee with
    interface ITerm<Manager> with
            member self.gmapT forallT = 
                let (M employee) = self
                M (forallT.Invoke employee)
            member self.gmapQ forallQ =
                let (M employee) = self 
                [forallQ.Invoke employee]
and Name = N of string with
    interface ITerm<Name> with
            member self.gmapT forallT = self
            member self.gmapQ forallQ = []
and Address = A of string with
    interface ITerm<Address> with
            member self.gmapT forallT = self
            member self.gmapQ forallQ = []

// 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, [])]


// Increase salary by 10%
let incSalary (k : float) (S value) = S (value * (1.0 + k))
everywhere { new IForallT with member self.Invoke term = mkT (incSalary 10.0) term } genCom


// sum all salaries
let sumSalary (S value) = value 
everything (+) { new IForallQ<float> with member self.Invoke term = mkQ 0.0 sumSalary term } genCom
val cast : v:'T -> 'R

Full name: Script.cast
val v : 'T
type obj = System.Object

Full name: Microsoft.FSharp.Core.obj
val mkT : f:('T -> 'T) -> ('R -> 'R)

Full name: Script.mkT
val f : ('T -> 'T)
val typeof<'T> : System.Type

Full name: Microsoft.FSharp.Core.Operators.typeof
val v : 'R
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val mkQ : r:'R -> q:('B -> 'R) -> a:'A -> 'R

Full name: Script.mkQ
val r : 'R
val q : ('B -> 'R)
val a : 'A
type IForallT =
  interface
    abstract member Invoke : 'T -> 'T (requires 'T :> ITerm<'T>)
  end

Full name: Script.IForallT
abstract member IForallT.Invoke : 'T -> 'T (requires 'T :> ITerm<'T>)

Full name: Script.IForallT.Invoke
type ITerm<'T (requires 'T :> ITerm<'T>)> =
  interface
    abstract member gmapQ : IForallQ<'R> -> 'R list
    abstract member gmapT : IForallT -> 'T
  end

Full name: Script.ITerm<_>
type IForallQ<'R> =
  interface
    abstract member Invoke : 'T -> 'R (requires 'T :> ITerm<'T>)
  end

Full name: Script.IForallQ<_>
abstract member IForallQ.Invoke : 'T -> 'R (requires 'T :> ITerm<'T>)

Full name: Script.IForallQ`1.Invoke
abstract member ITerm.gmapT : IForallT -> 'T

Full name: Script.ITerm`1.gmapT
abstract member ITerm.gmapQ : IForallQ<'R> -> 'R list

Full name: Script.ITerm`1.gmapQ
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val everywhere : forallT:IForallT -> term:'T -> 'T (requires 'T :> ITerm<'T>)

Full name: Script.everywhere
val forallT : IForallT
val term : 'T (requires 'T :> ITerm<'T>)
abstract member IForallT.Invoke : 'T -> 'T (requires 'T :> ITerm<'T>)
abstract member ITerm.gmapT : IForallT -> 'T
val self : IForallT
val term' : 'a (requires 'a :> ITerm<'a>)
val everything : k:('R -> 'R -> 'R) -> forallQ:IForallQ<'R> -> term:'T -> 'R (requires 'T :> ITerm<'T>)

Full name: Script.everything
val k : ('R -> 'R -> 'R)
val forallQ : IForallQ<'R>
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 fold : folder:('State -> 'T -> 'State) -> state:'State -> list:'T list -> 'State

Full name: Microsoft.FSharp.Collections.List.fold
abstract member IForallQ.Invoke : 'T -> 'R (requires 'T :> ITerm<'T>)
abstract member ITerm.gmapQ : IForallQ<'R> -> 'R list
val self : IForallQ<'R>
type Company =
  | C of Dept list
  interface ITerm<Company>

Full name: Script.Company
union case Company.C: Dept list -> Company
type Dept =
  | D of Name * Manager * SubUnit list
  interface ITerm<Dept>

Full name: Script.Dept
val self : Company
override Company.gmapT : forallT:IForallT -> Company

Full name: Script.Company.gmapT
val depts : Dept list
val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map
override Company.gmapQ : forallQ:IForallQ<'i> -> 'i list

Full name: Script.Company.gmapQ
val forallQ : IForallQ<'i>
union case Dept.D: Name * Manager * SubUnit list -> Dept
type Name =
  | N of string
  interface ITerm<Name>

Full name: Script.Name
type Manager =
  | M of Employee
  interface ITerm<Manager>

Full name: Script.Manager
type SubUnit =
  | PU of Employee
  | DU of Dept
  interface ITerm<SubUnit>

Full name: Script.SubUnit
val self : Dept
override Dept.gmapT : forallT:IForallT -> Dept

Full name: Script.Dept.gmapT
val name : Name
val manager : Manager
val subUnits : SubUnit list
override Dept.gmapQ : forallQ:IForallQ<'h> -> 'h list

Full name: Script.Dept.gmapQ
val forallQ : IForallQ<'h>
union case SubUnit.PU: Employee -> SubUnit
type Employee =
  | E of Person * Salary
  interface ITerm<Employee>

Full name: Script.Employee
union case SubUnit.DU: Dept -> SubUnit
val self : SubUnit
override SubUnit.gmapT : forallT:IForallT -> SubUnit

Full name: Script.SubUnit.gmapT
val employee : Employee
val dept : Dept
override SubUnit.gmapQ : forallQ:IForallQ<'g> -> 'g list

Full name: Script.SubUnit.gmapQ
val forallQ : IForallQ<'g>
union case Employee.E: Person * Salary -> Employee
type Person =
  | P of Name * Address
  interface ITerm<Person>

Full name: Script.Person
type Salary =
  | S of float
  interface ITerm<Salary>

Full name: Script.Salary
val self : Employee
override Employee.gmapT : forallT:IForallT -> Employee

Full name: Script.Employee.gmapT
val person : Person
val salary : Salary
override Employee.gmapQ : forallQ:IForallQ<'f> -> 'f list

Full name: Script.Employee.gmapQ
val forallQ : IForallQ<'f>
union case Person.P: Name * Address -> Person
type Address =
  | A of string
  interface ITerm<Address>

Full name: Script.Address
val self : Person
override Person.gmapT : forallT:IForallT -> Person

Full name: Script.Person.gmapT
val address : Address
override Person.gmapQ : forallQ:IForallQ<'e> -> 'e list

Full name: Script.Person.gmapQ
val forallQ : IForallQ<'e>
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<_>
val self : Salary
override Salary.gmapT : forallT:IForallT -> Salary

Full name: Script.Salary.gmapT
override Salary.gmapQ : forallQ:IForallQ<'d> -> 'd list

Full name: Script.Salary.gmapQ
val forallQ : IForallQ<'d>
union case Manager.M: Employee -> Manager
val self : Manager
override Manager.gmapT : forallT:IForallT -> Manager

Full name: Script.Manager.gmapT
override Manager.gmapQ : forallQ:IForallQ<'c> -> 'c list

Full name: Script.Manager.gmapQ
val forallQ : IForallQ<'c>
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
val self : Name
override Name.gmapT : forallT:IForallT -> Name

Full name: Script.Name.gmapT
override Name.gmapQ : forallQ:IForallQ<'b> -> 'b list

Full name: Script.Name.gmapQ
val forallQ : IForallQ<'b>
union case Address.A: string -> Address
val self : Address
override Address.gmapT : forallT:IForallT -> Address

Full name: Script.Address.gmapT
override Address.gmapQ : forallQ:IForallQ<'a> -> 'a list

Full name: Script.Address.gmapQ
val forallQ : IForallQ<'a>
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
val incSalary : k:float -> Salary -> Salary

Full name: Script.incSalary
val k : float
val value : float
val term : 'a (requires 'a :> ITerm<'a>)
val sumSalary : Salary -> float

Full name: Script.sumSalary
val self : IForallQ<float>

More information

Link:http://fssnip.net/7B
Posted:12 years ago
Author:Nick Palladinos
Tags: generic programming , haskell , rank-2