source: project/release/4/lexgen/branches/lexgen-typeclass/tests/run.scm @ 18684

Last change on this file since 18684 was 18684, checked in by Ivan Raikov, 10 years ago

yet another improved approach to parametric lexgen

File size: 8.7 KB
Line 
1
2(require-extension typeclass lexgen srfi-1 srfi-14 test)
3
4
5(define char-list-<Input>
6  (make-<Input> null? car cdr))
7
8(define char-list-<Token>
9  (Input->Token char-list-<Input>))
10
11(define char-list-<CharLex>
12  (Token->CharLex char-list-<Token>))
13
14(import-instance (<Token> char-list-<Token> char-list/)
15                 (<CharLex> char-list-<CharLex> char-list/))
16
17(define a-pat (char-list/tok #\a (try char=?)))
18(define b-pat (char-list/tok #\b (try char=?)))
19(define a-then-b-pat (seq a-pat b-pat))
20(define a-or-b-pat (bar a-pat b-pat))
21(define redo-b-a-pat (redo b-pat a-pat pass))
22(define a-star-pat (star a-pat))
23(define a-star*-pat (star* a-pat))
24(define a-star-or-b-pat (bar (star a-pat) b-pat))
25(define a-or-b-star-pat (star a-or-b-pat))
26(define a-b-opt-pat (seq a-pat (opt b-pat)))
27(define b-opt-a-pat (seq (opt b-pat) a-pat))
28(define a-b-opt-a-pat (seq a-pat (seq (opt b-pat) a-pat)))
29(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
30(define aabac-pat (char-list/lit "aabac"))
31(define aa-pat (char-list/lit "aa"))
32(define n4-pat (lst (list-tabulate 4 (lambda (i) (char-list/range #\0 #\9)))))
33
34(define abc-stream      (list `(() ,(string->list "abc"))))
35(define bac-stream      (list `(() ,(string->list "bac"))))
36(define aabac-stream    (list `(() ,(string->list "aabac"))))
37(define aaaabac-stream  (list `(() ,(string->list "aaaabac"))))
38(define num-stream      (list `(() ,(string->list "1234"))))
39
40
41(define (err s)
42  (print "lexical error on stream: " s)
43  (list))
44
45(test-group "lexgen test"
46            (test (sprintf "match [a] on ~S" "abc") 
47                   `(((#\a) (#\b #\c))) (a-pat identity abc-stream))
48
49            (test (sprintf "match [b] on ~S" "abc") 
50                   `() (b-pat identity abc-stream))
51
52            (test (sprintf "match redo [b] [a] on ~S" "abc") 
53                   `(((#\a) (#\b #\c)))  (redo-b-a-pat identity abc-stream))
54
55            (test (sprintf "match ab on ~S" "abc") 
56                   `(((#\b #\a ) ( #\c))) 
57                   (a-then-b-pat identity abc-stream))
58
59            (test (sprintf "match a|b on ~S" "abc") 
60                   `(((#\a) (#\b #\c))) 
61                   (a-or-b-pat identity abc-stream))
62
63            (test (sprintf "match a|b on ~S" "bac") 
64                   `(((#\b) (#\a #\c))) 
65                   (a-or-b-pat identity bac-stream))
66
67            (test (sprintf "match a* on ~S" "abc") 
68                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
69                   (a-star-pat identity abc-stream))
70
71            (test (sprintf "match greedy a* on ~S" "abc") 
72                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
73                   (a-star-pat identity abc-stream))
74
75            (test (sprintf "match a* on ~S" "aabac") 
76                  `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
77                  (a-star-pat identity  aabac-stream))
78
79            (test (sprintf "match greedy a* on ~S" "aabac") 
80                  `(((#\a #\a) (#\b #\a #\c)))
81                  (a-star*-pat identity aabac-stream))
82
83            (test (sprintf "match (a*|b) on ~S" "aabac") 
84                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
85                   (a-star-or-b-pat identity  aabac-stream))
86
87            (test (sprintf "match (a|b)* on ~S" "abc") 
88                   `((() (#\a #\b #\c))  ((#\a) (#\b #\c)) ((#\b #\a) (#\c)))
89                   (a-or-b-star-pat identity  abc-stream))
90
91            (test (sprintf "match (a|b)* on ~S" "aabac") 
92                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)) 
93                     ((#\b #\a #\a) (#\a #\c)) ((#\a #\b #\a #\a) (#\c)))
94                   (a-or-b-star-pat identity  aabac-stream))
95
96            (test (sprintf "match ab? on ~S" "abc") 
97                   `(((#\b #\a) (#\c)) )
98                   (a-b-opt-pat identity  abc-stream))
99
100            (test (sprintf "match ab? on ~S" "aabac") 
101                   `(((#\a) (#\a #\b #\a #\c)) )
102                   (a-b-opt-pat identity  aabac-stream))
103
104            (test (sprintf "match b?a on ~S" "abc") 
105                   `(((#\a) (#\b #\c)) )
106                   (b-opt-a-pat identity  abc-stream))
107
108            (test (sprintf "match ab?a on ~S" "aabac") 
109                   `(((#\a #\a) (#\b #\a #\c)) )
110                   (a-b-opt-a-pat identity  aabac-stream))
111
112            (test (sprintf "match a*b? on ~S" "aabac") 
113                   `(((#\b #\a #\a) (#\a #\c)))
114                   (a-star-b-opt-pat identity aabac-stream))
115
116            (test (sprintf "match literal string ~S" "aabac") 
117                   `(((#\c #\a #\b #\a #\a) ()) )
118                   (aabac-pat identity aabac-stream))
119
120            (test (sprintf "match n4 on  ~S" "1234") 
121                   `(((#\4 #\3 #\2 #\1) ()) )
122                   (n4-pat identity num-stream))
123
124            )
125
126;; A pattern to match floating point numbers.
127;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
128
129(define numpat
130  (let* ((digit        (char-list/range #\0 #\9))
131         (digits       (pos digit))
132         (fraction     (seq (char-list/char #\.) digits))
133         (significand  (bar (seq digits (opt fraction)) fraction))
134         (exp          (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
135         (sign         (opt (char-list/char #\-))))
136    (seq sign (seq significand (opt exp)))))
137
138(test-group "lexgen numpat test"
139            (test (sprintf "match numpat on ~S" "-123.45e-6")
140                   `((#\- #\1 #\2 #\3 #\. #\4 #\5 #\e #\- #\6) ()) 
141                   (lex numpat err "-123.45e-6"))
142            (test (sprintf "match numpat on ~S" "hi there")
143                  #f (lex numpat err "hi there")))
144
145(define (->char-list s)
146  (if (string? s) (string->list s) s))
147
148(define (collect cs) 
149  (let loop ((cs cs) (ax (list)))
150    (cond ((null? cs)         `(,(list->string ax)))
151          ((atom? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
152          (else               (cons (list->string ax) cs)))))
153
154(define (make-exp x)
155  (or (and (pair? x) 
156           (let ((x1 (collect x)))
157             (list `(exp . ,x1)))) x))
158
159(define (make-significand x)
160  (or (and (pair? x) 
161           (let ((x1 (collect x)))
162             (cons `(significand ,(car x1)) (cdr x1)))) x))
163
164(define (make-sign x)
165  (or (and (pair? x) 
166           (let ((x1 (collect x)))
167             (cons `(sign ,(car x1)) (cdr x1)))) x))
168
169(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
170
171(define bnumpat 
172  (let* ((digit        (char-list/range #\0 #\9))
173         (digits       (star digit))
174         (fraction     (seq (char-list/char #\.) digits))
175         (significand  (bar (seq digits (opt fraction)) fraction))
176         (exp          (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
177         (sign         (opt (char-list/char #\-)) )
178         (pat          (seq (bind make-sign sign) 
179                            (seq (bind make-significand (longest significand))
180                                 (bind make-exp (longest (opt exp)))))))
181    pat))
182
183(define (num-parser s) (car (lex bnumpat err s)))
184
185
186(test-group "lexgen num-parser test"
187            (test (sprintf "match num-parser on ~S" "-123.45e-6")
188                   `((sign "-") (significand "123.45") (exp "e-6"))
189                   (num-parser "-123.45e-6"))
190            )
191
192
193;; Tokens with position information
194
195       
196(define-record-type postok
197  (make-postok pos token)
198  postok?
199  (pos        postok-pos )
200  (token      postok-token )
201  )
202
203(define pos? pair?)
204(define pos-row car)
205(define pos-col cdr)
206(define make-pos cons)
207
208(define-record-printer (postok x out)
209  (fprintf out "#<token ~A: ~A>" 
210           (postok-pos x)
211           (postok-token x)))
212         
213(define (getpos p)
214  (let ((f (lambda (in) (print "getpos: in = " in) 
215                   (and (pair? in) (postok-pos (car in)))))
216        (g (lambda (i s) (list (make-postok i (car s))))))
217    (rebind f g p)))
218
219(define pos-<Input>
220  (let ((pos-tail
221         (lambda (strm)
222           (cond ((null? strm)   strm)
223                 (else
224                  (let* ((curtok  (car strm))
225                         (dd      (print "curtok = " curtok))
226                         (pos0    (postok-pos curtok))
227                         (dd      (print "pos0 = " pos0))
228                         (pos1    (let ((row0 (pos-row pos0))
229                                        (col0 (pos-col pos0)))
230                                    (case (cadr strm)
231                                      ((#\newline)  (make-pos (+ 1 row0) 1))
232                                      ((#\return)   (make-pos row0 1))
233                                      (else         (make-pos row0 (+ 1 col0))))))
234                         (res (cons (make-postok pos1 (cadr strm)) (cddr strm))))
235                    (print "res = " res)
236                    res)))))
237        (pos-null? null?)
238        (pos-head  (compose postok-token car)))
239    (make-<Input> pos-null? pos-head pos-tail)))
240
241(define pos-<Token>
242  (Input->Token pos-<Input>))
243
244(define pos-<CharLex>
245  (Token->CharLex pos-<Token>))
246
247(import-instance (<Token> pos-<Token> pos/)
248                 (<CharLex> pos-<CharLex> pos/))
249
250(define (make-pos-stream strm)
251  (let ((begpos (make-pos 1 1)))
252    (list `(() ,(cons (make-postok begpos (car strm)) (cdr strm))))))
253 
254(define pos-numpat-stream
255  (make-pos-stream (string->list "-123.45e-6")))
256
257(define pbnumpat 
258  (let* ((digit        (pos/range #\0 #\9))
259         (digits       (star digit))
260         (fraction     (seq (pos/char #\.) digits))
261         (significand  (bar (seq digits (opt fraction)) fraction))
262         (exp          (seq (pos/set "eE") (seq (opt (pos/set "+-")) digits)))
263         (sign         (opt (pos/char #\-)) )
264         (pat          (seq (getpos (bind make-sign sign))
265                            (seq (getpos (bind make-significand (longest significand)))
266                                 (getpos (bind make-exp (longest (opt exp))))))))
267    pat))
268
269(define (pos-num-parser s)  (car (lex pbnumpat err s)))
270
271(test-group "lexgen pos-num-parser test"
272            (test (sprintf "match pos-num-parser on ~S" "-123.45e-6")
273                   `(,(make-postok (make-pos 1 1) `(sign "-"))
274                     ,(make-postok (make-pos 1 2) `(significand "123.45"))
275                     ,(make-postok (make-pos 1 8) `(exp "e-6")))
276                   (pos-num-parser pos-numpat-stream))
277            )
278
Note: See TracBrowser for help on using the repository browser.