emo/thin-provisioning-tools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[functional-tests/regex] Get groups working

Browse Source 
Hacked a hotpatch soln.
This commit is contained in:
Joe Thornber 2017-08-28 17:38:49 +01:00
parent 6e9e71da87
commit da4bb22b6a
1 changed files with 45 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
functional-tests/regex.scm
View File

@ -320,59 +320,71 @@
;; any := "." ;; any := "."
(define any (p:>> (p:lit ".") (p:pure (lambda (_) #t)))) (define any (p:>> (p:lit ".") (p:pure (lambda (_) #t))))
;;-----------------------------------------------------------
;; Higher level combinators, these build a symbolic rx
;; The definitions start being mutually recursive from here on in, so we make
;; them thunks to defer evaluation.
;; group := "(" rx ")"
(define (group)
(fmt #t (dsp "group") nl)
(bracket (p:lit "(")
(p:lit ")")
(rx)))
;; elementary-rx := group | any | eos | char-rx | set
;; FIXME: put eos and group back in
(define (elementary-rx)
(p:lift (lambda (fn)
(list (char-instr fn)))
(p:one-of any char-rx set)))
;; plus-rx := elementary-rx "+"
(define (plus-rx)
(p:lift plus (p:<* (elementary-rx) (p:lit "+"))))
;; star-rx := elementary-rx "*"
(define (star-rx)
(p:lift star (p:<* (elementary-rx) (p:lit "*"))))
;; basic-rx := star-rx | plus-rx | elementary-rx
(define (basic-rx)
(p:one-of (star-rx) (plus-rx) (elementary-rx)))
;; simple-rx := basic-rx+
(define (simple-rx)
(define (combine rs) (define (combine rs)
(fold-left seq (car rs) (cdr rs))) (fold-left seq (car rs) (cdr rs)))
(p:lift combine (p:many+ (basic-rx)))) ;;-----------------------------------------------------------
;; Higher level combinators, these build a symbolic rx
;; rx := simple-rx ("|" simple-rx)* ;; FIXME: move a hotpatch form to (utils)
(define (rx) (define rx
(p:lift2 (lambda (r rs) (let ((this (lambda xs #f)))
(fold-left alt r rs)) (lambda args
(simple-rx) (if (and (= (length args) 2)
(p:many* (p:>> (p:lit "|") (eq? (car args) 'hotpatch))
(simple-rx))))) (set! this (cadr args))
(apply this args)))))
;; group := "(" rx ")"
(define group
(bracket (p:lit "(")
(p:lit ")")
rx))
;; elementary-rx := group | any | eos | char-rx | set
;; FIXME: put eos and group back in
(define elementary-rx
(p:alt (p:lift (lambda (fn)
(list (char-instr fn)))
(p:one-of any char-rx set))
group))
;; plus-rx := elementary-rx "+"
(define plus-rx
(p:lift plus (p:<* elementary-rx (p:lit "+"))))
;; star-rx := elementary-rx "*"
(define star-rx
(p:lift star (p:<* elementary-rx (p:lit "*"))))
;; basic-rx := star-rx | plus-rx | elementary-rx
(define basic-rx
(p:one-of star-rx plus-rx elementary-rx))
;; simple-rx := basic-rx+
(define simple-rx
(p:lift combine (p:many+ basic-rx)))
;;----------------------------------------------------------------------- ;;-----------------------------------------------------------------------
;; The top level routine, parses the regex string and compiles it into a ;; The top level routine, parses the regex string and compiles it into a
;; matcher, or returns false if the parse failed. ;; matcher, or returns false if the parse failed.
;; regex :: string -> (matcher <string>) ;; regex :: string -> (matcher <string>)
(define (regex str) ;; FIXME: it's tempting to return a function that raises if there's a parse error.
(receive (v st) (p:parse (rx) str) (define regex
(let ((patched #f))
(lambda (str)
(unless patched
(set! patched #t)
;; rx := simple-rx ("|" simple-rx)*
(rx 'hotpatch
(p:lift2 (lambda (r rs)
(fold-left alt r rs))
simple-rx
(p:many* (p:>> (p:lit "|") simple-rx)))))
(receive (v st) (p:parse rx str)
(if (p:success? st) (if (p:success? st)
(compile-rx v) (compile-rx v)
#f)))) #f))))))