missing files
[software/python-on-guile.git] / modules / language / python / module / re / compile.scm
1 (define-module (language python module re compile)
2 #:use-module (language python module re parser)
3 #:use-module (language python list)
4 #:use-module (language python string)
5 #:use-module ((parser stis-parser) #:select
6 ((parse . stisparse) <p-lambda> <p-cc> .. f-nl! f-nl
7 f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+ ngmn
8 g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev *whitespace*
9 f-nm f-pos))
10
11 #:use-module (parser stis-parser macros)
12 #:use-module (ice-9 match)
13 #:export (compile-reg test-reg parse))
14
15 (define-syntax-rule (<pp-lambda> (a b) . code)
16 (<p-lambda> (d)
17 (let ((a (car d))
18 (b (cadr d)))
19 . code)))
20
21 (define wrap list)
22
23 (define (fw f)
24 (<pp-lambda> (L c)
25 (.. c2 (f c))
26 (<p-cc> (wrap L c2))))
27
28 (define-syntax-rule (group f)
29 (let ()
30 (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
31 (let ((I (new-group))
32 (ff f))
33 (<pp-lambda> (L c)
34 (let ((e -1)
35 (s -1))
36 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e)))(list L c)))
37 (let* ((L (car c2))
38 (L (cons (cons I (list (strit c (cadr c2)) s e)) L)))
39 (<p-cc> (wrap L (cadr c2)))))))))
40
41 (define-syntax-rule (group-name f name)
42 (let ()
43 (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
44 (let* ((n (new-name name))
45 (ff f))
46 (<pp-lambda> (L c)
47 (let ((e -1)
48 (s -1))
49 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e))) (list L c)))
50 (let* ((L (car c2))
51 (c2 (cadr c2))
52 (L (cons (cons n (list (strit c c2) s e)) L)))
53 (<p-cc> (wrap L c2))))))))
54
55 (define (strit u v)
56 (let lp ((v v) (r '()))
57 (if (eq? u v)
58 (list->string r)
59 (lp (cdr v) (cons (car v) r)))))
60
61 (define (incant name)
62 (<p-lambda> (c)
63 (let* ((L (cadr c))
64 (r (if (number? name)
65 (let lp ((l L))
66 (define (f x u l)
67 (if (= x name)
68 u
69 (lp l)))
70
71 (match l
72 (((x . u) . l)
73 (if (pair? x)
74 (f (cdr x) (car u) l)
75 (f x (car u) l)))
76 (() (error (+ "could not incant " name)))))
77 (let lp ((l L))
78 (define (f x u l)
79 (if (equal? x name)
80 u
81 (lp l)))
82
83 (match l
84 (((x . u) . l)
85 (if (pair? x)
86 (f (car x) u l)
87 (f x u l)))
88 (() (error (+ "could not incant " name))))))))
89
90
91
92 (if r
93 (<and> (.. ((fw (f-tag! r)) c)))
94 (<code> (error "group is not existing in the history"))))))
95
96 (define (incant-rev name)
97 (<p-lambda> (c)
98 (let* ((L (cadr c))
99 (r (assoc name L)))
100 (if r
101 (<and> (.. ((f-tag (reverse (cdr r))) c)))
102 (<code> (error "group is not existing in the history"))))))
103
104 (define (reverse-form x)
105 (match x
106 ((#:or x)
107 (reverse-form x))
108 ((#:or . l)
109 (cons #:or (map reverse-form l)))
110 ((#:sub f)
111 (list #:group (reverse-form f)))
112 ((#:?P< f n)
113 (list #:?P< (reverse-form f) n))
114 ((#:?: f)
115 (reverse-form f))
116 ((#:?P= name)
117 (#:?P=-rev name))
118 ((#:?P=-rev name)
119 (#:?P= name))
120 ((#:?if name yes no)
121 (list #:?if-rev name (reverse-form yes) (reverse-form no)))
122 ((#:?if-rev name yes no)
123 (list #:?if name (reverse-form yes) (reverse-form no)))
124 ((#:?= f ) (list #:?= (reverse-form f)))
125 ((#:?! f ) (list #:?! (reverse-form f)))
126 ((#:?<= f ) (list #:?<= f))
127 ((#:?<! f ) (list #:?<! f))
128 ((#:* x ) (list #:* (reverse-form x)))
129 ((#:+ x ) (list #:+ (reverse-form x)))
130 ((#:mn x m n) (list #:mn (reverse-form x) m n))
131 ((#:? x ) (list #:? (reverse-form x)))
132 ((#:*? x ) (list #:*? (reverse-form x)))
133 ((#:+? x ) (list #:+? (reverse-form x)))
134 ((#:?? x ) (list #:?? (reverse-form x)))
135 ((:mn? x m n) (list #:mn? (reverse-form x) m n))
136 ((#:ch x ) (list #:ch x))
137 ((#:bracket . l) (cons #:bracket l))
138 ((x . l) (map reverse-form (cons x l)))
139 (x x)))
140
141 (define f-w (f-test! (lambda (x) (or (char-numeric? x) (char-alphabetic? x) (eq? x #\_)))))
142 (define f-d (f-test! (lambda (x) (or (char-numeric? x)))))
143 (define f-s (f-test! (lambda (x) (or (char-whitespace? x)))))
144 (define (get-class tag)
145 (match tag
146 ("n" f-nl!)
147 ("t" (f-tag! "\t"))
148 ("r" (f-tag! "\r"))
149 ("a" (f-tag! "\a"))
150 ("v" (f-tag! "\v"))
151 ("f" (f-tag! "\f"))
152 ("A" (f-nm 0 1))
153 ("b" (f-or! (f-and (f-prev 1 (f-not f-w)) f-w f-true)
154 (f-and (f-prev 1 f-w) (f-not f-w) f-true)))
155 ("B" (f-or! (f-and (f-prev 1 (f-not f-w)) (f-not f-w) f-true)
156 (f-and (f-prev 1 f-w) f-w f-true)))
157 ("d" f-d)
158 ("D" (f-not! f-d))
159 ("w" f-w)
160 ("W" (f-not! f-w))
161 ("s" f-s)
162 ("S" (f-not! f-s))
163 ("Z" f-eof)
164 (x (f-tag! x))))
165
166 (define groups (make-fluid 0))
167 (define groupindex (make-fluid 0))
168 (define (init)
169 (fluid-set! groups 1)
170 (fluid-set! groupindex (make-hash-table)))
171 (define (new-group)
172 (let ((i (fluid-ref groups)))
173 (fluid-set! groups (+ i 1))
174 i))
175 (define (new-name n)
176 (let ((i (fluid-ref groups)))
177 (hash-set! (fluid-ref groupindex) n i)
178 (fluid-set! groups (+ i 1))
179 (cons n i)))
180
181 (define (compile x)
182 (match x
183 ((#:or x)
184 (compile x))
185 ((#:or . l)
186 (apply f-or (map compile l)))
187 ((#:seq x)
188 (compile x))
189 ((#:seq . l)
190 (apply f-seq (map compile l)))
191 ((#:sub f)
192 (group (compile f)))
193 ((#:?P< n f)
194 (group-name (compile f) n))
195 ((#:?: f)
196 (compile f))
197 ((#:?P= name)
198 (incant name))
199 ((#:?P=-rev name)
200 (incant-rev name))
201 ((#:?= f) (f-and (compile f) f-true))
202 ((#:?! f) (f-and (f-not (compile f)) f-true))
203 ((#:?<= f) (f-and (f-seq f-rev (compile (reverse-form f))) f-true))
204 ((#:?<! f) (f-and (f-seq f-rev (f-not (compile (reverse-form f)))) f-true))
205 ((#:?if name yes no)
206 (f-or (f-seq (incant name) yes)
207 no))
208 ((#:?if-rev name yes no)
209 (f-or (f-seq yes (incant-rev name))
210 no))
211 (#:$ f-eof)
212 (#:^ (f-nm 0 1))
213 ((#:op x #:* ) (g* (compile x) ))
214 ((#:op x #:+ ) (g+ (compile x) ))
215 ((#:op x (#:rep m n)) (gmn (compile x) m n))
216 ((#:op x (#:rep m )) (gmn (compile x) m m))
217 ((#:op x (#:rep? m n)) (ngmn (compile x) m n))
218 ((#:op x (#:rep? m )) (ngmn (compile x) m m))
219 ((#:op x #:? ) (g? (compile x) ))
220 ((#:op x #:*?) (ng* (compile x) ))
221 ((#:op x #:+?) (ng+ (compile x) ))
222 ((#:op x #:??) (ng? (compile x) ))
223 ((#:ch (#:class x))
224 (fw (get-class x)))
225 ((#:ch x)
226 (fw (f-tag! x)))
227 ((#:bracket not ch ...)
228 (let ((f (apply f-or!
229 (map (lambda (x)
230 (match x
231 ((#:ch (#:class ch))
232 (get-class ch))
233 ((#:ch ch)
234 (f-tag! ch)))) ch))))
235
236 (if not
237 (f-not! f)
238 f)))))
239
240 (define (maybe-add-nk x)
241 (if (equal? (pylist-ref x (- (len x) 1)) "\n")
242 (+ x "\n")
243 x))
244
245 (define (compile-reg x)
246 (init)
247 (let ((p (f-seq (f-out '(() ())) (compile (parse-reg x)))))
248 (list p (fluid-ref groups) (fluid-ref groupindex))))
249
250 (define (test-reg y x)
251 (with-fluids ((*whitespace* f-true))
252 (stisparse (maybe-add-nk y) (car (compile-reg x)))))
253
254 (define (parse y x)
255 (with-fluids ((*whitespace* f-true))
256 (stisparse (maybe-add-nk y) x)))
257