summaryrefslogtreecommitdiff
path: root/modules/language/python/module
diff options
context:
space:
mode:
Diffstat (limited to 'modules/language/python/module')
-rw-r--r--modules/language/python/module/re.scm225
1 files changed, 225 insertions, 0 deletions
diff --git a/modules/language/python/module/re.scm b/modules/language/python/module/re.scm
new file mode 100644
index 0000000..0efbec9
--- /dev/null
+++ b/modules/language/python/module/re.scm
@@ -0,0 +1,225 @@
+(define-module (language python modules re)
+ #:export())
+
+
+(define-sytax-rule (mk n tag str) (define n (f-seq tag (f-tag str))))
+(mk f-. #:. ".")
+(mk f-^ #:^ "^")
+(mk f-$ #:$ "$")
+
+(define subexpr (f-list #:sub
+ (f-seq (f-tag "(") f-start ee f-end (f-tag ")"))))
+
+(define f-back
+ (f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwS]")))
+ (mk-token (f-reg "."))))
+
+(define (ch not)
+ (f-list #:ch
+ (f-or! (f-seq (f-char #\\) f-back)
+ (mk-token (f-not! not)))))
+
+(define bbody (f-cons (ch "[\\]") (ff* (ch "[]\\]"))))
+
+(define choice
+ (f-cons #:bracket
+ (f-or!
+ (f-seq "[^]" (f-out (list #:ch "^")))
+ (f-cons*
+ (f-tag "[")
+ (f? (f-seq (f-tag "^") (f-out #t)))
+ bbody))))
+
+(define-syntax-rule (mk-post q* str tag)
+ (define q*
+ (<p-lambda> (c)
+ (.. c2 ((f-tag str) c))
+ (<p-cc> (cons (list tag (car c)) (cdr c))))))
+
+(mk-post q* "*" #:*)
+(mk-post q? "?" #:?)
+(mk-post q+ "+" #:+)
+(mk-post q* "*?" #:*?)
+(mk-post q? "??" #:??)
+(mk-post q+ "+?" #:+?)
+
+(define q-or
+ (<p-lambda> (c)
+ (.. (c2) ((f-seq (f-tag "|") e) '()))
+ (<p-cc> (list #:or c c2))))
+
+(define q?
+ (<p-lambda> (c)
+ (.. c2 ((f-tag "*") c))
+ (<p-cc> (cons (list #:* (car c)) (cdr c)))))
+
+(define group
+ (lambda (f)
+ (<p-lambda> (c1)
+ (.. c2 (f '()))
+ (with ((L (cons (cons I c2) L))
+ (I (+ i 1)))
+ (<p-cc> (list #:list (#:append c1 c2)))))))
+
+(define group-name
+ (lambda (f name)
+ (<p-lambda> (c1)
+ (.. c2 (f '()))
+ (with ((L (cons* (cons name c2) (cons I c2) L))
+ (I (+ i 1)))
+ (<p-cc> (list #:list (#:append c1 c2)))))))
+
+(define (incant name)
+ (<p-lambda> (c)
+ (let ((r (assoc name L)))
+ (if r
+ (<and> (.. (f-tag (cdr r))))
+ (<code> (error "group is not existing in the history"))))))
+
+(define (incant-rev name)
+ (<p-lambda> (c)
+ (let ((r (assoc name L)))
+ (if r
+ (<and> (.. (f-tag (reverse (cdr r)))))
+ (<code> (error "group is not existing in the history"))))))
+
+(define (reverse-form x)
+ (match x
+ ((#:or x y)
+ (list #:or (reverse-form x) (reverse-form y)))
+ ((#:group 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 (compile x)
+ (match x
+ ((#:or x y)
+ (f-or (compile x) (compile y)))
+ ((#:group f)
+ (group (compile f)))
+ ((#:?P< f n)
+ (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))
+ ((#:* x ) (g* (compile x) ))
+ ((#:+ x ) (g+ (compile x) ))
+ ((#:mn x m n) (gmn (commile x) m n))
+ ((#:? x ) (g? (compile x) ))
+ ((#:*? x ) (ng* (compile x) ))
+ ((#:+? x ) (ng+ (compile x) ))
+ ((#:?? x ) (ng? (compile x) ))
+ ((:mn? x m n) (ngmn (compile x) m n))
+ ((#:ch (#:class x))
+ (get-class ch))
+ ((#:ch x)
+ (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 (id c) c)
+(define (e-match e)
+ (f-seq (f-or! (f-mute e) (f-return #f))
+ (f-retfkn id)))
+
+(define (e-fullmatch e)
+ (f-or! (f-seq (f-mute e) f-eof (f-retfkn id))
+ (f-return #f)))
+
+(define (e-search e)
+ (f-or! (f-seq (f-mute e) (f-retfkn id))
+ (f-seq (f-take 1) (Ds (e-search e)))
+ (f-return None)))
+
+
+(define (e-sub e str)
+ (f-or! (f-seq (f-subst (f-mute e) str) (Ds (e-sub e str)))
+ (f-seq (f-take 1) (Ds (e-search e)))
+ (f-out-written)))
+
+(define (e-subn e str)
+ (let lp ((i 0))
+ (f-or! (f-seq (f-subst (f-mute e) str) (Ds (lp (+ i 1))))
+ (f-seq (f-take 1) (Ds (e-search e)))
+ (f-seq (f-out-written) (f-retfkn (lambda (c) (values c i)))))))
+
+(define (e-split e)
+ (f-or! (f-cons (f-seq (mk-token f-out-written) (f-mute e)) (e-split e))
+ (f-cons (f-out-remaining) (f-out '()))))
+
+(define* (findall x s (#:flags 0))
+ (call-with-values (lambda () (parse e-search x s flags))
+ (lambda (m cont)
+ (let lp ((m m) (cont cont))
+ (if (eq? m None)
+ '()
+ (cons m (call-with-values cont lp)))))))
+
+(define* (finditer x s (#:flags 0))
+ ((make-generator ()
+ (lambda (yield)
+ (call-with-values (lambda () (parse e-search x s flags))
+ (lambda (m cont)
+ (let lp ((m m) (cont cont))
+ (if (eq? m None)
+ #f
+ (begin
+ (yield m)
+ (call-with-values cont lp))))))))))
+
+
+
+
+
+
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 04:34:11 +0000