2 people like it.

Staged Parser Combinators

Staged Parser Combinators

  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: 
// Staged parser combinators

#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 QuotationCompiler

open Microsoft.FSharp.Quotations

let counter = ref 0

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    incr counter
    let var = new Var(sprintf "__paramTemp_%d__" !counter, 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> =
    incr counter
    let var = new Var(sprintf "__paramTemp_%d__" !counter, typeof<'T>)
    incr counter
    let var' = new Var(sprintf "__paramTemp_%d__" !counter, 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> =
    incr counter
    let var = new Var(sprintf "__paramTemp_%d__" !counter, typeof<'T>)
    incr counter
    let var' = new Var(sprintf "__paramTemp_%d__" !counter, typeof<'S>)
    incr counter
    let var'' = new Var(sprintf "__paramTemp_%d__" !counter, 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''))))))


type Parser<'T> = Expr<string> -> Expr<int> -> (Expr<'T> -> Expr<string> -> Expr<int> -> Expr<bool>) -> Expr<bool>


// combinators
let pchar (matchChar : char) : Parser<char> = 
    fun str index k ->
        <@ let index = %index
           if (%str).Length = index then false 
           else 
            let current = (%str).[index]
            if current <> matchChar then 
                false
            else
                (% lambda2 (fun current index -> k current str index)) current (index + 1) @>


let (=>) (left : Parser<'T>) (right : Parser<'S>) : Parser<'T * 'S> = 
    fun str index k -> left str index (fun value str index -> right str index (fun value' str index -> k <@ (%value, %value') @> str index))

let (<|>) (left : Parser<'T>) (right : Parser<'T>) : Parser<'T> = 
    fun str index k -> <@ let test = (% left str index (fun value  str index -> k value str index)) 
                          if test then true
                          else (% right str index (fun value  str index -> k value str index))  
                       @>

let (<*>) (parser : Parser<'T>) : Parser<'T list> = 
    fun str index k -> 
        <@  let rec loop (index : int) (acc : 'T list) =
                let test = (% lambda3 (fun loop index acc -> parser str index (fun value str index -> <@ (%loop) %index (%value :: %acc) @>))) loop index acc
                if not test then
                    (% lambda2 (fun index acc -> k acc str index)) index acc
                else true
            loop %index []
        @>

let compileParser (parser : Parser<'T>) : string -> 'T option = 
    let f = QuotationCompiler.ToFunc(lambda (fun (str : Expr<string>) -> 
                                        <@ let resultRef = ref Unchecked.defaultof<'T>
                                           let test = (% lambda (fun resultRef -> parser str <@ 0 @>  (fun value _ _ -> <@ %resultRef := %value; true @>))) resultRef
                                           if test then Some !resultRef else None
                                        @>))
    (fun str -> f () str)

    

// Examples
let f = pchar 'a' |> compileParser
f "abc" // Some 'a'
f "bac" // None

let g = (pchar 'a' => pchar 'b') |> compileParser
g "abc" // Some ('a', 'b')
g "bac" // None

let h = (pchar 'a' <|> pchar 'b') |> compileParser
h "abc" // Some 'a'
h "bac" // Some 'b'
h "cab" // None

let k = ((<*>) (pchar 'a')) |> compileParser
k "abc" // Some ['a']
k "aabc" // Some ['a'; 'a']
k "bac" // None
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 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 incr : cell:int ref -> unit

Full name: Microsoft.FSharp.Core.Operators.incr
val var : Var
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:System.Type * ?isMutable:bool -> Var
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
val typeof<'T> : System.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
type Parser<'T> = Expr<string> -> Expr<int> -> (Expr<'T> -> Expr<string> -> Expr<int> -> Expr<bool>) -> Expr<bool>

Full name: Script.Parser<_>
Multiple items
val string : value:'T -> string

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

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
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<_>
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val pchar : matchChar:char -> str:Expr<string> -> index:Expr<int> -> k:(Expr<char> -> Expr<string> -> Expr<int> -> Expr<bool>) -> Expr<bool>

Full name: Script.pchar
val matchChar : char
Multiple items
val char : value:'T -> char (requires member op_Explicit)

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

--------------------
type char = System.Char

Full name: Microsoft.FSharp.Core.char
val str : Expr<string>
val index : Expr<int>
val k : (Expr<char> -> Expr<string> -> Expr<int> -> Expr<bool>)
val index : int
val current : char
val current : Expr<char>
val left : Parser<'T>
val right : Parser<'S>
val k : (Expr<'T * 'S> -> Expr<string> -> Expr<int> -> Expr<bool>)
val value : Expr<'T>
val value' : Expr<'S>
val right : Parser<'T>
val k : (Expr<'T> -> Expr<string> -> Expr<int> -> Expr<bool>)
val test : bool
val parser : Parser<'T>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val k : (Expr<'T list> -> Expr<string> -> Expr<int> -> Expr<bool>)
val loop : (int -> 'T list -> bool)
val acc : 'T list
val loop : Expr<(int -> 'T list -> bool)>
val acc : Expr<'T list>
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val compileParser : parser:Parser<'T> -> (string -> 'T option)

Full name: Script.compileParser
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
val f : (unit -> string -> 'T option)
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 resultRef : 'T ref
module Unchecked

from Microsoft.FSharp.Core.Operators
val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val resultRef : Expr<'T ref>
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val str : string
val f : (string -> char option)

Full name: Script.f
val g : (string -> (char * char) option)

Full name: Script.g
val h : (string -> char option)

Full name: Script.h
val k : (string -> char list option)

Full name: Script.k

More information

Link:http://fssnip.net/7R6
Posted:9 months ago
Author:Nick Palladinos
Tags: parser combinators , staging