reverse forms implemented
[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 module re flags)
4 #:use-module (language python list)
5 #:use-module (language python string)
6 #:use-module ((parser stis-parser) #:select
7 ((parse . stisparse) <p-lambda> <p-cc> .. f-nl! f-nl
8 f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+
9 ngmn f-reg! f-and!
10 g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev
11 *whitespace*
12 f-nm f-pos))
13
14 #:use-module (parser stis-parser macros)
15 #:use-module (ice-9 match)
16 #:export (compile-reg test-reg parse))
17
18 (define-syntax-rule (<pp-lambda> (a b) . code)
19 (<p-lambda> (d)
20 (let ((a (car d))
21 (b (cadr d)))
22 . code)))
23
24 (define wrap list)
25
26 (define (fw f)
27 (<pp-lambda> (L c)
28 (.. c2 (f c))
29 (<p-cc> (wrap L c2))))
30
31 (define (gt f)
32 (<pp-lambda> (L c)
33 (let ((x #f))
34 (<or>
35 (<and>
36 (.. c* (f-rev '()))
37 (.. c2 (f (list L '())))
38 (<code> (set! x c2))
39 <fail>)
40 (when x
41 (<p-cc> (wrap (car x) c)))))))
42
43
44 (define-syntax-rule (group f)
45 (let ()
46 (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
47 (let ((I (new-group))
48 (ff f))
49 (<pp-lambda> (L c)
50 (let ((e -1)
51 (s -1))
52 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e)))(list L c)))
53 (let* ((L (car c2))
54 (L (cons (cons I (list (strit c (cadr c2)) s e)) L)))
55 (<p-cc> (wrap L (cadr c2)))))))))
56
57 (define-syntax-rule (group-name f name)
58 (let ()
59 (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
60 (let* ((n (new-name name))
61 (ff f))
62 (<pp-lambda> (L c)
63 (let ((e -1)
64 (s -1))
65 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e))) (list L c)))
66 (let* ((L (car c2))
67 (c2 (cadr c2))
68 (L (cons (cons n (list (strit c c2) s e)) L)))
69 (<p-cc> (wrap L c2))))))))
70
71 (define (strit u v)
72 (let lp ((v v) (r '()))
73 (if (eq? u v)
74 (list->string r)
75 (lp (cdr v) (cons (car v) r)))))
76
77 (define (incant name)
78 (<p-lambda> (c)
79 (let* ((L (cadr c))
80 (r (if (number? name)
81 (let lp ((l L))
82 (define (f x u l)
83 (if (= x name)
84 u
85 (lp l)))
86
87 (match l
88 (((x . u) . l)
89 (if (pair? x)
90 (f (cdr x) (car u) l)
91 (f x (car u) l)))
92 (() (error (+ "could not incant " name)))))
93 (let lp ((l L))
94 (define (f x u l)
95 (if (equal? x name)
96 u
97 (lp l)))
98
99 (match l
100 (((x . u) . l)
101 (if (pair? x)
102 (f (car x) u l)
103 (f x u l)))
104 (() (error (+ "could not incant " name))))))))
105
106
107
108 (if r
109 (<and> (.. ((fw (f-tag! r)) c)))
110 (<code> (error "group is not existing in the history"))))))
111
112 (define (incant-rev name)
113 (<p-lambda> (c)
114 (let* ((L (cadr c))
115 (r (assoc name L)))
116 (if r
117 (<and> (.. ((f-tag (reverse (cdr r))) c)))
118 (<code> (error "group is not existing in the history"))))))
119
120 (define (reverse-form x)
121 (match x
122 ((#:or x)
123 (reverse-form x))
124 ((#:or . l)
125 (cons #:or (map reverse-form l)))
126 ((#:seq x)
127 (reverse-form x))
128 ((#:seq . l)
129 (cons #:seq (reverse (map reverse-form l))))
130 ((#:sub f)
131 (list #:group (reverse-form f)))
132 ((#:?P< n f)
133 (list #:?P< n (reverse-form f)))
134 ((#:?: f)
135 (reverse-form f))
136 ((#:?P= name)
137 (#:?P=-rev name))
138 ((#:?P=-rev name)
139 (#:?P= name))
140 ((#:?if name yes no)
141 (list #:if name (reverse-form yes) (reverse-form no)))
142 ((#:?= f) (list #:?= (reverse-form f)))
143 ((#:?! f) (list #:?= (reverse-form f)))
144 ((#:?<= f) f)
145 ((#:?<! f) (#:not f))
146 ((#:not f) (list #:not (reverse-form f)))
147 (#:$ #:^)
148 (#:^ #:$)
149 ((#:op x #:* ) (list #:op (reverse-form x) #:*))
150 ((#:op x #:+ ) (list #:op (reverse-form x) #:+))
151 ((#:op x (#:rep m n)) (list #:op (reverse-form x) (#:rep m n)))
152 ((#:op x (#:rep m )) (list #:op (reverse-form x) (#:rep m)))
153 ((#:op x (#:rep? m n)) (list #:op (reverse-form x) (#:rep? m n)))
154 ((#:op x (#:rep? m )) (list #:op (reverse-form x) (#:rep? m)))
155 ((#:op x #:? ) (list #:op (reverse-form x) #:?))
156 ((#:op x #:*?) (list #:op (reverse-form x) #:*?))
157 ((#:op x #:+?) (list #:op (reverse-form x) #:+?))
158 ((#:op x #:??) (list #:op (reverse-form x) #:??))
159 ((and a (#:ch (#:class x))) a)
160 ((and a (#:ch x)) a)
161 ((and a (#:bracket not ch ...)) a)))
162
163
164 (define f-w
165 (f-or! (f-test! (lambda (x)
166 (let ((x (fluid-ref *flags*)))
167 (and
168 (= (logand x ASCII) 0)
169 (or (char-numeric? x)
170 (char-alphabetic? x))))))
171
172 (f-tag "_")
173 (f-reg! "a-zA-Z0-9")))
174
175 (define f-d
176 (f-or!
177 (f-test! (lambda (x)
178 (let ((x (fluid-ref *flags*)))
179 (and
180 (= (logand x ASCII) 0)
181 (char-numeric? x)))))
182 (f-reg! "0-9")))
183
184 (define f-s
185 (f-or!
186 (f-test!
187 (lambda (x)
188 (let ((fl (fluid-ref *flags*)))
189 (and
190 (= (logand fl ASCII) 0)
191 (char-whitespace? x)))))
192 (f-reg! "[\n\r \t\f\v]")))
193
194 (define (get-class tag)
195 (match tag
196 ("n" f-nl!)
197 ("t" (f-tag! "\t"))
198 ("r" (f-tag! "\r"))
199 ("a" (f-tag! "\a"))
200 ("v" (f-tag! "\v"))
201 ("f" (f-tag! "\f"))
202 ("A" (f-nm 0 1))
203 ("b" (f-or! (f-and (f-or! (f-nm 0 1) (f-prev 1 (f-not f-w)))
204 (f-or! f-eof f-w)
205 f-true)
206 (f-and (f-or! (f-nm 0 1) (f-prev 1 f-w))
207 (f-or! f-eof (f-not f-w))
208 f-true)))
209 ("B" (f-or! (f-and (f-or! (f-nm 0 1) (f-prev 1 (f-not f-w)))
210 (f-or! f-eof (f-not f-w))
211 f-true)
212 (f-and (f-or! (f-nm 0 1) (f-prev 1 f-w))
213 (f-or! f-eof f-w)
214 f-true)))
215 ("d" f-d)
216 ("D" (f-not! f-d))
217 ("w" f-w)
218 ("W" (f-not! f-w))
219 ("s" f-s)
220 ("S" (f-not! f-s))
221 ("Z" f-eof)
222 (x (f-tag! x))))
223
224 (define groups (make-fluid 0))
225 (define groupindex (make-fluid 0))
226 (define (init)
227 (fluid-set! groups 1)
228 (fluid-set! groupindex (make-hash-table)))
229 (define (new-group)
230 (let ((i (fluid-ref groups)))
231 (fluid-set! groups (+ i 1))
232 i))
233 (define (new-name n)
234 (let ((i (fluid-ref groups)))
235 (hash-set! (fluid-ref groupindex) n i)
236 (fluid-set! groups (+ i 1))
237 (cons n i)))
238
239 (define (compile x)
240 (match x
241 ((#:or x)
242 (compile x))
243 ((#:or . l)
244 (apply f-or (map compile l)))
245 ((#:seq x)
246 (compile x))
247 ((#:seq . l)
248 (apply f-seq (map compile l)))
249 ((#:sub f)
250 (group (compile f)))
251 ((#:?P< n f)
252 (group-name (compile f) n))
253 ((#:?: f)
254 (compile f))
255 ((#:?P= name)
256 (incant name))
257 ((#:?P=-rev name)
258 (incant-rev name))
259 ((#:?= f) (f-and (compile f) f-true))
260 ((#:?! f) (f-and (f-not (compile f)) f-true))
261 ((#:?<= f) (gt (compile (reverse-form f))))
262 ((#:?<! f) (f-seq (f-not (f-seq f-rev (compile (reverse-form f))))
263 f-true))
264 ((#:not f) (f-and (f-not (compile f)) f-true))
265 ((#:?if name yes no)
266 (f-or (f-seq (incant name) yes)
267 no))
268 ((#:?if-rev name yes no)
269 (f-or (f-seq yes (incant-rev name))
270 no))
271 (#:$ f-eof)
272 (#:^ (f-nm 0 1))
273 ((#:op x #:* ) (g* (compile x) ))
274 ((#:op x #:+ ) (g+ (compile x) ))
275 ((#:op x (#:rep m n)) (gmn (compile x) m n))
276 ((#:op x (#:rep m )) (gmn (compile x) m m))
277 ((#:op x (#:rep? m n)) (ngmn (compile x) m n))
278 ((#:op x (#:rep? m )) (ngmn (compile x) m m))
279 ((#:op x #:? ) (g? (compile x) ))
280 ((#:op x #:*?) (ng* (compile x) ))
281 ((#:op x #:+?) (ng+ (compile x) ))
282 ((#:op x #:??) (ng? (compile x) ))
283 ((#:ch (#:class x))
284 (fw (get-class x)))
285 ((#:ch x)
286 (let ((chx (string-ref x 0)))
287 (fw
288 (f-test! (lambda (ch)
289 (let ((y (fluid-ref *flags*)))
290 (if (= 0 (logand y IGNORECASE))
291 (eq? ch chx)
292 (if (= 0 (logand y ASCII))
293 (eq? (char-upcase chx) (char-upcase ch))
294 (if (and (< (char->integer ch) 128)
295 (< (char->integer chx) 128))
296 (eq? (char-upcase chx) (char-upcase ch))
297 (eq? chx ch))))))))))
298 ((#:bracket not ch ...)
299 (let ((f (apply f-or!
300 (map (lambda (x)
301 (match x
302 ((#:ch (#:class ch))
303 (get-class ch))
304 ((#:ch ch)
305 (compile (list #:ch ch)))))
306 ch))))
307
308 (if not
309 (f-not! f)
310 f)))))
311
312 (define (maybe-add-nk x)
313 (if (equal? (pylist-ref x (- (len x) 1)) "\n")
314 (+ x "\n")
315 x))
316
317 (define (compile-reg x)
318 (init)
319 (let ((p (f-seq (f-out '(() ())) (compile (parse-reg x)))))
320 (list p (fluid-ref groups) (fluid-ref groupindex))))
321
322 (define (test-reg y x)
323 (with-fluids ((*whitespace* f-true))
324 (stisparse (maybe-add-nk y) (car (compile-reg x)))))
325
326 (define (parse y x)
327 (with-fluids ((*whitespace* f-true))
328 (stisparse (maybe-add-nk y) x)))
329