0 people like it.
Like the snippet!
Staged typed formatting
Staged typed formatting, based on http://okmij.org/ftp/ML/GADT.txt, https://www.cl.cam.ac.uk/~jdy22/papers/modular-macros.pdf
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:
|
// Staged typed formatting, based on http://okmij.org/ftp/ML/GADT.txt, https://www.cl.cam.ac.uk/~jdy22/papers/modular-macros.pdf
#r "packages/FSharp.Compiler.Service.1.3.1.0/lib/net45/FSharp.Compiler.Service.dll"
#r "packages/QuotationCompiler.0.0.7-alpha/lib/net45/QuotationCompiler.dll"
open System
open QuotationCompiler
open Microsoft.FSharp.Quotations
// helper functions
let counter = ref 0
let rec generateVars (types : Type list) : Var list =
match types with
| [] -> []
| t :: ts ->
incr counter
let var = new Var(sprintf "__paramTemp_%d__" !counter, t)
var :: generateVars ts
// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
let [var] = generateVars [typeof<'T>]
Expr.Cast<_>(Expr.Lambda(var, f (Expr.Cast<_>(Expr.Var var))))
// Helper Equality type
module Eq =
type Eq<'A, 'B> = private Refl of (Expr<'A> -> Expr<'B>) * (Expr<'B> -> Expr<'A>)
let refl<'A> () : Eq<'A, 'A> = Refl (id, id)
let sym : Eq<'A, 'B> -> Eq<'B, 'A> = fun (Refl (f, g)) -> Refl (g, f)
let cast : Eq<'A, 'B> -> Expr<'A> -> Expr<'B> = fun (Refl (f, _)) -> f
open Eq
// Basic type
type Fmt<'A, 'B> =
| FLit of Eq<'A, 'B> * string
| FInt of Eq<int -> 'B, 'A>
| FChar of Eq<char -> 'B, 'A>
| FCmp of Compose<'A, 'B>
and Compose<'A, 'B> =
abstract Invoke<'R> : Handler<'A, 'B, 'R> -> Expr<'R>
and Handler<'A, 'C, 'R> =
abstract Handle<'B> : Fmt<'A, 'B> * Fmt<'B, 'C> -> Expr<'R>
// helper functions
let flit : string -> Fmt<'A, 'A> =
fun x -> FLit (refl (), x)
let fint : unit -> Fmt<int -> 'A, 'A> =
fun () -> FInt (refl ())
let fchar : unit -> Fmt<char -> 'A, 'A> =
fun () -> FChar (refl ())
let cmp : Fmt<'A, 'B> -> Fmt<'B, 'C> -> Fmt<'A, 'C> =
fun left right ->
FCmp <|
{ new Compose<'A, 'C> with
member self.Invoke<'R>(handler : Handler<'A, 'C, 'R>) =
handler.Handle<'B>(left, right) }
let (%) a b = cmp a b
let example () = flit "(" % fchar() % flit "," % fint() % flit ")"
let rec printer<'A, 'B> : Fmt<'A, 'B> -> (Expr<string> -> Expr<'B>) -> Expr<'A> =
fun fmt k ->
match fmt with
| FLit (eq, x) -> cast (sym eq) (k <@ x @>)
| FInt eq -> cast eq (<@ fun x -> (% lambda (fun x -> k <@ string %x @>)) x @>)
| FChar eq -> cast eq (<@ fun x -> (% lambda (fun x -> k <@ string %x @>)) x @>)
| FCmp cmp ->
cmp.Invoke<'A> {
new Handler<'A, 'B, 'A> with
member self.Handle<'C>(left : Fmt<'A, 'C>, right : Fmt<'C, 'B>) : Expr<'A> =
printer<'A, 'C> left (fun x -> printer<'C, 'B> right (fun y -> k <@ %x + %y @>))
}
let exampleExpr = printer (example ()) id
let f = QuotationCompiler.ToFunc exampleExpr ()
f '2' 1 // (2,1)
|
namespace System
namespace Microsoft
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
val counter : int ref
Full name: Script.counter
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 generateVars : types:Type list -> Var list
Full name: Script.generateVars
val types : Type list
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
type 'T list = List<'T>
Full name: Microsoft.FSharp.Collections.list<_>
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:Type * ?isMutable:bool -> Var
val t : Type
val ts : Type list
val incr : cell:int ref -> unit
Full name: Microsoft.FSharp.Core.Operators.incr
val var : Var
val sprintf : format:Printf.StringFormat<'T> -> 'T
Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
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 typeof<'T> : 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 Eq<'A,'B> = private | Refl of (Expr<'A> -> Expr<'B>) * (Expr<'B> -> Expr<'A>)
Full name: Script.Eq.Eq<_,_>
union case Eq.Refl: (Expr<'A> -> Expr<'B>) * (Expr<'B> -> Expr<'A>) -> Eq<'A,'B>
val refl : unit -> Eq<'A,'A>
Full name: Script.Eq.refl
val id : x:'T -> 'T
Full name: Microsoft.FSharp.Core.Operators.id
val sym : Eq<'A,'B> -> Eq<'B,'A>
Full name: Script.Eq.sym
val f : (Expr<'A> -> Expr<'B>)
val g : (Expr<'B> -> Expr<'A>)
val cast : Eq<'A,'B> -> (Expr<'A> -> Expr<'B>)
Full name: Script.Eq.cast
module Eq
from Script
type Fmt<'A,'B> =
| FLit of Eq<'A,'B> * string
| FInt of Eq<(int -> 'B),'A>
| FChar of Eq<(char -> 'B),'A>
| FCmp of Compose<'A,'B>
Full name: Script.Fmt<_,_>
union case Fmt.FLit: Eq<'A,'B> * string -> Fmt<'A,'B>
Multiple items
module Eq
from Script
--------------------
type Eq<'A,'B> = private | Refl of (Expr<'A> -> Expr<'B>) * (Expr<'B> -> Expr<'A>)
Full name: Script.Eq.Eq<_,_>
Multiple items
val string : value:'T -> string
Full name: Microsoft.FSharp.Core.Operators.string
--------------------
type string = String
Full name: Microsoft.FSharp.Core.string
union case Fmt.FInt: Eq<(int -> 'B),'A> -> Fmt<'A,'B>
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<_>
union case Fmt.FChar: Eq<(char -> 'B),'A> -> Fmt<'A,'B>
Multiple items
val char : value:'T -> char (requires member op_Explicit)
Full name: Microsoft.FSharp.Core.Operators.char
--------------------
type char = Char
Full name: Microsoft.FSharp.Core.char
union case Fmt.FCmp: Compose<'A,'B> -> Fmt<'A,'B>
type Compose<'A,'B> =
interface
abstract member Invoke : Handler<'A,'B,'R> -> Expr<'R>
end
Full name: Script.Compose<_,_>
abstract member Compose.Invoke : Handler<'A,'B,'R> -> Expr<'R>
Full name: Script.Compose`2.Invoke
Multiple items
type Handler<'T> =
delegate of obj * 'T -> unit
Full name: Microsoft.FSharp.Control.Handler<_>
--------------------
type Handler<'A,'C,'R> =
interface
abstract member Handle : Fmt<'A,'B> * Fmt<'B,'C> -> Expr<'R>
end
Full name: Script.Handler<_,_,_>
abstract member Handler.Handle : Fmt<'A,'B> * Fmt<'B,'C> -> Expr<'R>
Full name: Script.Handler`3.Handle
val flit : x:string -> Fmt<'A,'A>
Full name: Script.flit
val x : string
val fint : unit -> Fmt<(int -> 'A),'A>
Full name: Script.fint
type unit = Unit
Full name: Microsoft.FSharp.Core.unit
val fchar : unit -> Fmt<(char -> 'A),'A>
Full name: Script.fchar
val cmp : left:Fmt<'A,'B> -> right:Fmt<'B,'C> -> Fmt<'A,'C>
Full name: Script.cmp
val left : Fmt<'A,'B>
val right : Fmt<'B,'C>
val self : Compose<'A,'C>
abstract member Compose.Invoke : Handler<'A,'B,'R> -> Expr<'R>
val handler : Handler<'A,'C,'R>
abstract member Handler.Handle : Fmt<'A,'B> * Fmt<'B,'C> -> Expr<'R>
val a : Fmt<'a,'b>
val b : Fmt<'b,'c>
val example : unit -> Fmt<(char -> int -> 'a),'a>
Full name: Script.example
val printer : fmt:Fmt<'A,'B> -> k:(Expr<string> -> Expr<'B>) -> Expr<'A>
Full name: Script.printer
val fmt : Fmt<'A,'B>
val k : (Expr<string> -> Expr<'B>)
val eq : Eq<'A,'B>
val eq : Eq<(int -> 'B),'A>
val x : int
val x : Expr<int>
val eq : Eq<(char -> 'B),'A>
val x : char
val x : Expr<char>
val cmp : Compose<'A,'B>
val self : Handler<'A,'B,'A>
val left : Fmt<'A,'C>
val right : Fmt<'C,'B>
val x : Expr<string>
val y : Expr<string>
val exampleExpr : Expr<(char -> int -> string)>
Full name: Script.exampleExpr
val f : (char -> int -> obj)
Full name: Script.f
More information