2 people like it.
Like the snippet!

Staged Parser Combinators

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

Previous Version Raw view Test code New version

More information

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