0 people like it.

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

More information

Link:http://fssnip.net/7Tj
Posted:6 years ago
Author:NIck Palladinos
Tags: formatting , staging

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.