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) = interface ITerm 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, managerTerm : ITerm, subUnitTermf : IRecTerm -> ITerm) = interface IRecTerm 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, deptTerm : IRecTerm) = interface ITerm 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) = interface ITerm with member self.gmapT forallT = fun manager -> <@ let (M employee) = %manager M ( (% (lambda (fun employee -> forallT.Invoke employeeTerm employee)) ) employee ) @> type EmployeeTerm(personTerm : ITerm, salaryTerm : ITerm) = interface ITerm 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, addressTerm : ITerm
) = interface ITerm 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 with member self.gmapT _ = id type NameTerm() = interface ITerm with member self.gmapT _ = id type AddressTerm() = interface ITerm
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 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() { 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) = <@ let (N name) = %name in N (name.ToUpper()) @> everywhere (mkT nameToUpper) personTerm let incSalary (k : float) (salary : Expr) = <@ let (S value) = %salary in S (value * (1.0 + k)) @> everywhere (mkT (incSalary 10.0)) companyTerm