Staged CPS Regular Expression Matcher

Staged CPS Regular Expression Matcher based on CPS RegEx matcher in http://dl.acm.org/citation.cfm?id=968582

 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:

// Staged CPS Regular Expression Matcher
// Based on CPS RegEx matcher in http://dl.acm.org/citation.cfm?id=968582

#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

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    let var = new Var("__temp__", 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 = new Var("__temp'__", typeof<'T>)
    let var' = new Var("__temp''__", typeof<'S>)
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var',  f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')))))

type RegExp = 
    | Zero
    | One 
    | Char of char
    | Times of RegExp * RegExp
    | Plus of RegExp * RegExp
    | Star of RegExp


let rec matchRegExp (pattern : RegExp) (chars : Expr<char list>) (k : Expr<char list> -> Expr<bool>) : Expr<bool> = 
    match pattern with
    | Zero -> <@ false @>
    | One -> k chars
    | Char c -> <@ match %chars with x :: xs when x = c -> (% lambda (fun xs -> k xs)) xs | _ -> false @>
    | Times (l, r) -> matchRegExp l chars (fun chars -> matchRegExp r chars k)
    | Plus (l, r) -> <@ if (% matchRegExp l chars k) then true else (% matchRegExp r chars k) @>
    | Star exp -> 
        <@ let rec loop chars = 
            if (% lambda(fun chars -> k chars)) chars then true
            else (% lambda2(fun loop chars -> matchRegExp exp chars (fun chars -> <@ (%loop) %chars @>))) loop chars 
           loop %chars @>

let compileRegEx (pattern : RegExp) : string -> bool = 
    let f = QuotationCompiler.ToFunc(lambda (fun (chars : Expr<char list>) -> 
                                        matchRegExp pattern chars (fun chars -> <@ match %chars with [] -> true | _ -> false @>)))
    (fun text -> f () (List.ofSeq text))

// helpers
let char c = Char c
let (=>) l r = Times (l, r)
let (<|>) l r = Plus (l, r)
let (<*>) e = Star e
let (<+>) e = e => (<*>) e


// example c(a|d)+r
let pattern = char 'c' => (<+>) (char 'a' <|> char 'd') => char 'r'
let test = compileRegEx pattern
test "car" // true
test "cdr" // false
test "cr" // false
test "cddar" // true
test "cdda" // false

namespace QuotationCompiler

namespace Microsoft

namespace Microsoft.FSharp

namespace Microsoft.FSharp.Quotations

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

union case RegExp.Zero: RegExp

union case RegExp.One: RegExp

union case RegExp.Char: char -> RegExp

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

union case RegExp.Times: RegExp * RegExp -> RegExp

union case RegExp.Plus: RegExp * RegExp -> RegExp

union case RegExp.Star: RegExp -> RegExp

val matchRegExp : pattern:RegExp -> chars:Expr<char list> -> k:(Expr<char list> -> Expr<bool>) -> Expr<bool>

Full name: Script.matchRegExp

val pattern : RegExp

val chars : Expr<char list>

type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>

val k : (Expr<char list> -> Expr<bool>)

type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool

val c : char

val x : char

val xs : char list

val xs : Expr<char list>

val l : RegExp

val r : RegExp

val exp : RegExp

val loop : (char list -> bool)

val chars : char list

val loop : Expr<(char list -> bool)>

val compileRegEx : pattern:RegExp -> (string -> bool)

Full name: Script.compileRegEx

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

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

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

Full name: Microsoft.FSharp.Core.string

val f : (unit -> char list -> bool)

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 text : string

Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>

val ofSeq : source:seq<'T> -> 'T list

Full name: Microsoft.FSharp.Collections.List.ofSeq

Multiple items
val char : c:char -> RegExp

Full name: Script.char

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

Full name: Microsoft.FSharp.Core.char

val e : RegExp

val pattern : RegExp

Full name: Script.pattern

val test : (string -> bool)

Full name: Script.test

Raw view Test code New version

More information

Link:	http://fssnip.net/7QS
Posted:	8 years ago
Author:	Nick Palladinos
Tags:	staging, regex, cps