From 67b8025ea15e5df03671bef9ebe48c00e121983a Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Tue, 26 Sep 2017 22:47:12 +0200
Subject: big commit

---
 modules/language/python/module/re.scm | 225 ++++++++++++++++++++++++++++++++++
 1 file changed, 225 insertions(+)
 create mode 100644 modules/language/python/module/re.scm

(limited to 'modules/language/python/module')

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))))))))))
+                    
+            
+          
+
+
+  
+  
-- 
cgit v1.2.3