Staged Functional Unparsing

Staged Functional Unparsing based on http://www.brics.dk/RS/98/12/BRICS-RS-98-12.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:

// Staged Functional Unparsing based on http://www.brics.dk/RS/98/12/BRICS-RS-98-12.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

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))))


// <@ fun x y -> (% <@ x @> ... <@ y @> ) @> ~ lambda (fun x y -> x ... y )
let lambda2 (f : Expr<'T> -> Expr<'S> -> Expr<'R>) : Expr<'T -> 'S -> 'R> =
    let [var; var'] = generateVars [typeof<'T>; typeof<'S>]
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var',  f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')))))

// <@ fun x y z -> (% <@ x @> ... <@ y @> ... <@ z @> ) @> ~ lambda (fun x y z -> x ... y ... z )
let lambda3 (f : Expr<'T> -> Expr<'S> -> Expr<'K> -> Expr<'R>) : Expr<'T -> 'S -> 'K -> 'R> =
    let [var; var'; var''] = generateVars [typeof<'T>; typeof<'S>; typeof<'K>]
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var', Expr.Lambda(var'', f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')) (Expr.Cast<_>(Expr.Var var''))))))



// combinators
let lit : Expr<string> -> (Expr<string> -> 'T) -> Expr<string> -> 'T = 
    fun x k s -> k <@ %s + %x @>

let eol : (Expr<string> -> 'T) -> Expr<string> -> 'T = 
    fun k s -> k <@ %s + Environment.NewLine @>

let int : (Expr<string> -> 'T) -> Expr<string> -> Expr<int> -> 'T = 
    fun k s x -> k <@ %s + string %x @>

let str : (Expr<string> -> 'T) -> Expr<string> -> Expr<string> -> 'T = 
    fun k s x -> k <@ %s + %x @>

let format : ((Expr<string> -> Expr<string>) -> Expr<string> -> 'T) -> 'T = 
    fun p ->  p id <@ "" @>

let compile (f : Expr<'T> -> Expr<'R>) : 'T -> 'R = QuotationCompiler.ToFunc(lambda f) ()
let compile2 (f : Expr<'T> -> Expr<'S> -> Expr<'R>) : 'T -> 'S -> 'R = QuotationCompiler.ToFunc(lambda2 f) ()
let compile3 (f : Expr<'T> -> Expr<'S> -> Expr<'K> -> Expr<'R>) : 'T -> 'S -> 'K -> 'R = QuotationCompiler.ToFunc(lambda3 f) ()

// Examples
let f  = compile2 <| format (int << lit <@ " is " @> << str)
f 42 "number" // "42 is number"
let g = compile2 <| format (int << lit <@ "/" @> << int)
g 1 2 // "1/2"

namespace System

namespace QuotationCompiler

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

val lambda2 : f:(Expr<'T> -> Expr<'S> -> Expr<'R>) -> Expr<('T -> 'S -> 'R)>

Full name: Script.lambda2

val f : (Expr<'T> -> Expr<'S> -> Expr<'R>)

val var' : Var

val lambda3 : f:(Expr<'T> -> Expr<'S> -> Expr<'K> -> Expr<'R>) -> Expr<('T -> 'S -> 'K -> 'R)>

Full name: Script.lambda3

val f : (Expr<'T> -> Expr<'S> -> Expr<'K> -> Expr<'R>)

val var'' : Var

val lit : x:Expr<string> -> k:(Expr<string> -> 'T) -> s:Expr<string> -> 'T

Full name: Script.lit

Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string

val x : Expr<string>

val k : (Expr<string> -> 'T)

val s : Expr<string>

val eol : k:(Expr<string> -> 'T) -> s:Expr<string> -> 'T

Full name: Script.eol

type Environment =
  static member CommandLine : string
  static member CurrentDirectory : string with get, set
  static member Exit : exitCode:int -> unit
  static member ExitCode : int with get, set
  static member ExpandEnvironmentVariables : name:string -> string
  static member FailFast : message:string -> unit + 1 overload
  static member GetCommandLineArgs : unit -> string[]
  static member GetEnvironmentVariable : variable:string -> string + 1 overload
  static member GetEnvironmentVariables : unit -> IDictionary + 1 overload
  static member GetFolderPath : folder:SpecialFolder -> string + 1 overload
  ...
  nested type SpecialFolder
  nested type SpecialFolderOption

Full name: System.Environment

property Environment.NewLine: string

Multiple items
val int : k:(Expr<string> -> 'T) -> s:Expr<string> -> x:Expr<int> -> 'T

Full name: Script.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>

val x : Expr<int>

val str : k:(Expr<string> -> 'T) -> s:Expr<string> -> x:Expr<string> -> 'T

Full name: Script.str

val format : p:((Expr<string> -> Expr<string>) -> Expr<string> -> 'T) -> 'T

Full name: Script.format

val p : ((Expr<string> -> Expr<string>) -> Expr<string> -> 'T)

val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id

val compile : f:(Expr<'T> -> Expr<'R>) -> ('T -> 'R)

Full name: Script.compile

Multiple items
namespace QuotationCompiler

--------------------
type QuotationCompiler =
  private new : unit -> QuotationCompiler
  static member Eval : expr:Expr<'T> * ?useCache:bool -> 'T
  static member ToAssembly : expr:Expr * ?targetDirectory:string * ?assemblyName:string * ?compiledModuleName:string * ?compiledFunctionName:string -> string
  static member ToDynamicAssembly : expr:Expr * ?assemblyName:string -> MethodInfo
  static member ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

Full name: QuotationCompiler.QuotationCompiler

static member QuotationCompiler.ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

val compile2 : f:(Expr<'T> -> Expr<'S> -> Expr<'R>) -> ('T -> 'S -> 'R)

Full name: Script.compile2

val compile3 : f:(Expr<'T> -> Expr<'S> -> Expr<'K> -> Expr<'R>) -> ('T -> 'S -> 'K -> 'R)

Full name: Script.compile3

val f : (int -> string -> string)

Full name: Script.f

val g : (int -> int -> string)

Full name: Script.g

Raw view Test code New version

More information

Link:	http://fssnip.net/7Ra
Posted:	8 years ago
Author:	Nick Palladinos
Tags:	staging , unparsing