diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-07-13 15:19:03 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-07-13 15:19:03 +0200 |
commit | bf35763d00bed87133880d9435d0014fd98ab7e5 (patch) | |
tree | 36868563756131ffbb14abca0f662f58b4954ac6 /modules/language/python/module/re | |
parent | 7d47faa9e658b14d67697856b3980b2ffa9d6776 (diff) |
missing files
Diffstat (limited to 'modules/language/python/module/re')
-rw-r--r-- | modules/language/python/module/re/compile.scm | 257 | ||||
-rw-r--r-- | modules/language/python/module/re/flags.scm | 25 | ||||
-rw-r--r-- | modules/language/python/module/re/parser.scm | 63 |
3 files changed, 345 insertions, 0 deletions
diff --git a/modules/language/python/module/re/compile.scm b/modules/language/python/module/re/compile.scm new file mode 100644 index 0000000..6ed7162 --- /dev/null +++ b/modules/language/python/module/re/compile.scm @@ -0,0 +1,257 @@ +(define-module (language python module re compile) + #:use-module (language python module re parser) + #:use-module (language python list) + #:use-module (language python string) + #:use-module ((parser stis-parser) #:select + ((parse . stisparse) <p-lambda> <p-cc> .. f-nl! f-nl + f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+ ngmn + g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev *whitespace* + f-nm f-pos)) + + #:use-module (parser stis-parser macros) + #:use-module (ice-9 match) + #:export (compile-reg test-reg parse)) + +(define-syntax-rule (<pp-lambda> (a b) . code) + (<p-lambda> (d) + (let ((a (car d)) + (b (cadr d))) + . code))) + +(define wrap list) + +(define (fw f) + (<pp-lambda> (L c) + (.. c2 (f c)) + (<p-cc> (wrap L c2)))) + +(define-syntax-rule (group f) + (let () + (define-syntax-rule (mac s) (lambda (x n m) (set! s x))) + (let ((I (new-group)) + (ff f)) + (<pp-lambda> (L c) + (let ((e -1) + (s -1)) + (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e)))(list L c))) + (let* ((L (car c2)) + (L (cons (cons I (list (strit c (cadr c2)) s e)) L))) + (<p-cc> (wrap L (cadr c2))))))))) + +(define-syntax-rule (group-name f name) + (let () + (define-syntax-rule (mac s) (lambda (x n m) (set! s x))) + (let* ((n (new-name name)) + (ff f)) + (<pp-lambda> (L c) + (let ((e -1) + (s -1)) + (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e))) (list L c))) + (let* ((L (car c2)) + (c2 (cadr c2)) + (L (cons (cons n (list (strit c c2) s e)) L))) + (<p-cc> (wrap L c2)))))))) + +(define (strit u v) + (let lp ((v v) (r '())) + (if (eq? u v) + (list->string r) + (lp (cdr v) (cons (car v) r))))) + +(define (incant name) + (<p-lambda> (c) + (let* ((L (cadr c)) + (r (if (number? name) + (let lp ((l L)) + (define (f x u l) + (if (= x name) + u + (lp l))) + + (match l + (((x . u) . l) + (if (pair? x) + (f (cdr x) (car u) l) + (f x (car u) l))) + (() (error (+ "could not incant " name))))) + (let lp ((l L)) + (define (f x u l) + (if (equal? x name) + u + (lp l))) + + (match l + (((x . u) . l) + (if (pair? x) + (f (car x) u l) + (f x u l))) + (() (error (+ "could not incant " name)))))))) + + + + (if r + (<and> (.. ((fw (f-tag! r)) c))) + (<code> (error "group is not existing in the history")))))) + +(define (incant-rev name) + (<p-lambda> (c) + (let* ((L (cadr c)) + (r (assoc name L))) + (if r + (<and> (.. ((f-tag (reverse (cdr r))) c))) + (<code> (error "group is not existing in the history")))))) + +(define (reverse-form x) + (match x + ((#:or x) + (reverse-form x)) + ((#:or . l) + (cons #:or (map reverse-form l))) + ((#:sub f) + (list #:group (reverse-form f))) + ((#:?P< f n) + (list #:?P< (reverse-form f) n)) + ((#:?: f) + (reverse-form f)) + ((#:?P= name) + (#:?P=-rev name)) + ((#:?P=-rev name) + (#:?P= name)) + ((#:?if name yes no) + (list #:?if-rev name (reverse-form yes) (reverse-form no))) + ((#:?if-rev name yes no) + (list #:?if name (reverse-form yes) (reverse-form no))) + ((#:?= f ) (list #:?= (reverse-form f))) + ((#:?! f ) (list #:?! (reverse-form f))) + ((#:?<= f ) (list #:?<= f)) + ((#:?<! f ) (list #:?<! f)) + ((#:* x ) (list #:* (reverse-form x))) + ((#:+ x ) (list #:+ (reverse-form x))) + ((#:mn x m n) (list #:mn (reverse-form x) m n)) + ((#:? x ) (list #:? (reverse-form x))) + ((#:*? x ) (list #:*? (reverse-form x))) + ((#:+? x ) (list #:+? (reverse-form x))) + ((#:?? x ) (list #:?? (reverse-form x))) + ((:mn? x m n) (list #:mn? (reverse-form x) m n)) + ((#:ch x ) (list #:ch x)) + ((#:bracket . l) (cons #:bracket l)) + ((x . l) (map reverse-form (cons x l))) + (x x))) + +(define f-w (f-test! (lambda (x) (or (char-numeric? x) (char-alphabetic? x) (eq? x #\_))))) +(define f-d (f-test! (lambda (x) (or (char-numeric? x))))) +(define f-s (f-test! (lambda (x) (or (char-whitespace? x))))) +(define (get-class tag) + (match tag + ("n" f-nl!) + ("t" (f-tag! "\t")) + ("r" (f-tag! "\r")) + ("a" (f-tag! "\a")) + ("v" (f-tag! "\v")) + ("f" (f-tag! "\f")) + ("A" (f-nm 0 1)) + ("b" (f-or! (f-and (f-prev 1 (f-not f-w)) f-w f-true) + (f-and (f-prev 1 f-w) (f-not f-w) f-true))) + ("B" (f-or! (f-and (f-prev 1 (f-not f-w)) (f-not f-w) f-true) + (f-and (f-prev 1 f-w) f-w f-true))) + ("d" f-d) + ("D" (f-not! f-d)) + ("w" f-w) + ("W" (f-not! f-w)) + ("s" f-s) + ("S" (f-not! f-s)) + ("Z" f-eof) + (x (f-tag! x)))) + +(define groups (make-fluid 0)) +(define groupindex (make-fluid 0)) +(define (init) + (fluid-set! groups 1) + (fluid-set! groupindex (make-hash-table))) +(define (new-group) + (let ((i (fluid-ref groups))) + (fluid-set! groups (+ i 1)) + i)) +(define (new-name n) + (let ((i (fluid-ref groups))) + (hash-set! (fluid-ref groupindex) n i) + (fluid-set! groups (+ i 1)) + (cons n i))) + +(define (compile x) + (match x + ((#:or x) + (compile x)) + ((#:or . l) + (apply f-or (map compile l))) + ((#:seq x) + (compile x)) + ((#:seq . l) + (apply f-seq (map compile l))) + ((#:sub f) + (group (compile f))) + ((#:?P< n f) + (group-name (compile f) n)) + ((#:?: f) + (compile f)) + ((#:?P= name) + (incant name)) + ((#:?P=-rev name) + (incant-rev name)) + ((#:?= f) (f-and (compile f) f-true)) + ((#:?! f) (f-and (f-not (compile f)) f-true)) + ((#:?<= f) (f-and (f-seq f-rev (compile (reverse-form f))) f-true)) + ((#:?<! f) (f-and (f-seq f-rev (f-not (compile (reverse-form f)))) f-true)) + ((#:?if name yes no) + (f-or (f-seq (incant name) yes) + no)) + ((#:?if-rev name yes no) + (f-or (f-seq yes (incant-rev name)) + no)) + (#:$ f-eof) + (#:^ (f-nm 0 1)) + ((#:op x #:* ) (g* (compile x) )) + ((#:op x #:+ ) (g+ (compile x) )) + ((#:op x (#:rep m n)) (gmn (compile x) m n)) + ((#:op x (#:rep m )) (gmn (compile x) m m)) + ((#:op x (#:rep? m n)) (ngmn (compile x) m n)) + ((#:op x (#:rep? m )) (ngmn (compile x) m m)) + ((#:op x #:? ) (g? (compile x) )) + ((#:op x #:*?) (ng* (compile x) )) + ((#:op x #:+?) (ng+ (compile x) )) + ((#:op x #:??) (ng? (compile x) )) + ((#:ch (#:class x)) + (fw (get-class x))) + ((#:ch x) + (fw (f-tag! x))) + ((#:bracket not ch ...) + (let ((f (apply f-or! + (map (lambda (x) + (match x + ((#:ch (#:class ch)) + (get-class ch)) + ((#:ch ch) + (f-tag! ch)))) ch)))) + + (if not + (f-not! f) + f))))) + +(define (maybe-add-nk x) + (if (equal? (pylist-ref x (- (len x) 1)) "\n") + (+ x "\n") + x)) + +(define (compile-reg x) + (init) + (let ((p (f-seq (f-out '(() ())) (compile (parse-reg x))))) + (list p (fluid-ref groups) (fluid-ref groupindex)))) + +(define (test-reg y x) + (with-fluids ((*whitespace* f-true)) + (stisparse (maybe-add-nk y) (car (compile-reg x))))) + +(define (parse y x) + (with-fluids ((*whitespace* f-true)) + (stisparse (maybe-add-nk y) x))) + diff --git a/modules/language/python/module/re/flags.scm b/modules/language/python/module/re/flags.scm new file mode 100644 index 0000000..527bb09 --- /dev/null +++ b/modules/language/python/module/re/flags.scm @@ -0,0 +1,25 @@ +(define-module (language python module re flags) + #:export (set-flags get-flags + A ASCII DEBUG I IGNORECASE L LOCALE M MULTILINE X VERBOSE)) + +(define *flags* (make-fluid 0)) +(define (set-flags x) (fluid-set! *flags* x)) +(define (get-flags) (fluid-ref *flags*)) + +(define A 1) +(define ASCII A) + +(define DEBUG 2) + +(define I 4) +(define IGNORECASE I) + +(define L 8) +(define LOCALE L) + +(define M 16) +(define MULTILINE M) + +(define X 32) +(define VERBOSE X) + diff --git a/modules/language/python/module/re/parser.scm b/modules/language/python/module/re/parser.scm new file mode 100644 index 0000000..eae4b3f --- /dev/null +++ b/modules/language/python/module/re/parser.scm @@ -0,0 +1,63 @@ +(define-module (language python module re parser) + #:use-module (parser stis-parser) + #:export(parse-reg e-matcher)) + +(define-syntax-rule (mk n tag str) (define n (f-seq tag (f-tag str)))) +(mk f-. #:dot ".") +(mk f-^ #:^ "^") +(mk f-$ #:$ "$") +(mk q* #:* "*") +(mk q? #:? "?") +(mk q+ #:+ "+") +(mk q*? #:*? "*?") +(mk q?? #:?? "??") +(mk q+? #:+? "+?") + +(define subexpr (f-list #:sub + (f-seq (f-tag "(") (Ds ee) (f-tag ")")))) + +(define f-back + (f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwntr]"))) + (mk-token (f-reg ".")))) + +(define anongroup (f-list #:?: "(?:" (Ds ee) ")")) +(define namegroup (f-list #:?P< "(?P<" (mk-token (f+ (f-not! (f-reg "[> ]")))) ">" (Ds ee) ")")) +(define (ch not) + (f-list #:ch + (f-or! (f-seq (f-char #\\) f-back) + (mk-token (f-not! not))))) +(define number (mk-token (f+ (f-reg! "[0-9]")) string->number)) +(define incant (f-list #:?P= "(?P=" (f-or! number + (mk-token (f+ (f-not! (f-reg "[) ]"))))) ")")) +(define coment (f-seq "(?#" (f* (f-not (f-tag ")"))) ")")) +(define repn? (f-list #:rep? "{" number "}" "?")) +(define repnm? (f-list #:rep? "{" number "," number "}" "?")) +(define repn (f-list #:rep "{" number "}")) +(define repnm (f-list #:rep "{" number "," number "}")) + +(define lookh (f-list #:?= "(?=" (Ds ee) ")")) +(define lookh! (f-list #:?! "(?!" (Ds ee) ")")) +(define bbody (f-cons (ch (f-reg "[\\]")) (ff* (ch (f-reg "[]\\]"))))) + +(define (f-if a b c) (f-or! (f-seq a b) c)) +(define choice + (f-cons #:bracket + (f-or! + (f-seq "[^]" (f-out (list (list #:ch (f-out #f) "^")))) + (f-cons* + (f-tag "[") + (f-if (f-tag "^") (f-out #t) (f-out #f)) + bbody)))) + + +(define f-bar (f-tag "|")) +(define qq (ch (f-reg "[][?+|*.$^() \\]"))) +(define atom (f-or qq f-. choice subexpr anongroup namegroup incant coment lookh lookh! f-^ f-$)) +(define spec (f-list #:op atom (f-or! q+? q?? q*? q* q? q+ repn? repnm? repn repnm))) +(define aatom (f-or! spec atom)) +(define line (f-cons* #:seq aatom (ff* aatom ))) +(define ee (f-cons* #:or line (ff* (f-seq f-bar line)))) + +(define (parse-reg str) (parse str ee)) + +(define e-matcher ee) |