1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;; Tests the parsing capabilities of (ice-9 peg). Could use more
4 ;; tests for edge cases.
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 (define-module (test-suite test-peg)
8 :use-module (test-suite lib)
9 :use-module (ice-9 peg)
10 :use-module (ice-9 pretty-print)
11 :use-module (srfi srfi-1))
13 ;; Doubled up for pasting into REPL.
14 (use-modules (test-suite lib))
15 (use-modules (ice-9 peg))
16 (use-modules (ice-9 pretty-print))
17 (use-modules (srfi srfi-1))
19 ;; Evaluates an expression at the toplevel. Not the prettiest
20 ;; solution to runtime issues ever, but m3h. Runs at toplevel so that
21 ;; symbols are bound globally instead of in the scope of the pass-if
24 (eval exp (interaction-environment)))
25 (define make-prec (@@ (ice-9 peg) make-prec))
27 ;; Maps the nonterminals defined in the PEG parser written as a PEG to
28 ;; the nonterminals defined in the PEG parser written with
30 (define grammar-mapping
31 '((grammar peg-grammar)
33 (alternative peg-alternative)
37 (charclass peg-charclass)
38 (CCrange charclass-range)
39 (CCsingle charclass-single)
40 (nonterminal peg-nonterminal)
43 ;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
44 (define (grammar-transform x)
45 (let ((res (assoc x grammar-mapping)))
46 (if res (cadr res) x)))
48 ;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms).
49 (define (tree-map fn lst)
53 (cons (tree-map fn (car lst))
54 (tree-map fn (cdr lst))))
57 ;; Tests to make sure that we can parse a PEG defining a grammar for
58 ;; PEGs, then uses that grammar to parse the same PEG again to make
59 ;; sure we get the same result (i.e. make sure our PEG grammar
60 ;; expressed as a PEG is equivalent to our PEG grammar expressed with
62 (with-test-prefix "PEG Grammar"
64 "defining PEGs with PEG"
65 (and (eeval `(define-peg-string-patterns ,(@@ (ice-9 peg) peg-as-peg))) #t))
67 "equivalence of definitions"
69 (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
72 (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
74 ;; A grammar for pascal-style comments from Wikipedia.
75 (define comment-grammar
79 N <- C / (!Begin !End Z)
82 ;; A short /etc/passwd file.
84 "root:x:0:0:root:/root:/bin/bash
85 daemon:x:1:1:daemon:/usr/sbin:/bin/sh
86 bin:x:2:2:bin:/bin:/bin/sh
87 sys:x:3:3:sys:/dev:/bin/sh
88 nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
89 messagebus:x:103:107::/var/run/dbus:/bin/false
92 ;; A grammar for parsing /etc/passwd files.
93 (define-peg-string-patterns
95 entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL*
100 nameORcomment <-- text
103 path <-- (SLASH pathELEMENT)*
104 pathELEMENT <-- (!NL !CO !'/' .)*
110 ;; Tests some actual parsing using PEGs.
111 (with-test-prefix "Parsing"
112 (eeval `(define-peg-string-patterns ,comment-grammar))
114 ;; Pascal-style comment parsing
117 (match-pattern C "(*blah*)")
118 (make-prec 0 8 "(*blah*)"
119 '((Begin "(*") "blah" (End "*)")))))
121 "simple comment padded"
123 (match-pattern C "(*blah*)abc")
124 (make-prec 0 8 "(*blah*)abc"
125 '((Begin "(*") "blah" (End "*)")))))
129 (match-pattern C "(*1(*2*)*)")
130 (make-prec 0 10 "(*1(*2*)*)"
131 '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)")))))
134 (not (match-pattern C "(*blah")))
137 (not (match-pattern C "blah")))
138 ;; /etc/passwd parsing
142 (match-pattern passwd *etc-passwd*)
143 (make-prec 0 220 *etc-passwd*
144 '(passwd (entry (login "root") (pass "x") (uid "0") (gid "0") (nameORcomment "root") (homedir (path (pathELEMENT "root"))) (shell (path (pathELEMENT "bin") (pathELEMENT "bash")))) (entry (login "daemon") (pass "x") (uid "1") (gid "1") (nameORcomment "daemon") (homedir (path (pathELEMENT "usr") (pathELEMENT "sbin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "bin") (pass "x") (uid "2") (gid "2") (nameORcomment "bin") (homedir (path (pathELEMENT "bin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "sys") (pass "x") (uid "3") (gid "3") (nameORcomment "sys") (homedir (path (pathELEMENT "dev"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "nobody") (pass "x") (uid "65534") (gid "65534") (nameORcomment "nobody") (homedir (path (pathELEMENT "nonexistent"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "messagebus") (pass "x") (uid "103") (gid "107") nameORcomment (homedir (path (pathELEMENT "var") (pathELEMENT "run") (pathELEMENT "dbus"))) (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))))))
146 ;; Tests the functions for pulling data out of PEG Match Records.
147 (with-test-prefix "PEG Match Records"
148 (define-peg-pattern bs all (peg "'b'+"))
150 "basic parameter extraction"
152 (let ((pm (search-for-pattern bs "aabbcc")))
153 `((string ,(peg:string pm))
154 (start ,(peg:start pm))
156 (substring ,(peg:substring pm))
157 (tree ,(peg:tree pm))
158 (record? ,(peg-record? pm))))
166 ;; PEG for parsing right-associative equations.
167 (define-peg-string-patterns
169 sum <-- (product ('+' / '-') sum) / product
170 product <-- (value ('*' / '/') product) / value
171 value <-- number / '(' expr ')'
174 ;; Functions to actually evaluate the equations parsed with the PEG.
175 (define (parse-sum sum left . rest)
177 (apply parse-product left)
178 (list (string->symbol (car rest))
179 (apply parse-product left)
180 (apply parse-sum (cadr rest)))))
182 (define (parse-product product left . rest)
184 (apply parse-value left)
185 (list (string->symbol (car rest))
186 (apply parse-value left)
187 (apply parse-product (cadr rest)))))
189 (define (parse-value value first . rest)
191 (string->number (cadr first))
192 (apply parse-sum (car rest))))
194 (define parse-expr parse-sum)
195 (define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
197 (with-test-prefix "Parsing right-associative equations"
200 (equal? (eq-parse "1") 1))
203 (equal? (eq-parse "1+2") '(+ 1 2)))
206 (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3))))
209 (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4))))
212 (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
213 '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8)))))
216 (equal? (eq-parse "1+1/2*3+(1+1)/2")
217 '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2))))))
219 ;; PEG for parsing left-associative equations (normal ones).
220 (define-peg-string-patterns
222 sum <-- (product ('+' / '-'))* product
223 product <-- (value ('*' / '/'))* value
224 value <-- number / '(' expr ')'
227 ;; Functions to actually evaluate the equations parsed with the PEG.
228 (define (make-left-parser next-func)
229 (lambda (sum first . rest)
231 (apply next-func first)
232 (if (string? (cadr first))
233 (list (string->symbol (cadr first))
234 (apply next-func (car first))
235 (apply next-func (car rest)))
239 (list (list (cadr r) (car r) (apply next-func (car l)))
240 (string->symbol (cadr l))))
243 (list (list (apply next-func (caar first))
244 (string->symbol (cadar first))))
246 (list (append rest '("done"))))))))))
248 (define (parse-value value first . rest)
250 (string->number (cadr first))
251 (apply parse-sum (car rest))))
252 (define parse-product (make-left-parser parse-value))
253 (define parse-sum (make-left-parser parse-product))
254 (define parse-expr parse-sum)
255 (define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
257 (with-test-prefix "Parsing left-associative equations"
260 (equal? (eq-parse "1") 1))
263 (equal? (eq-parse "1+2") '(+ 1 2)))
266 (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3)))
269 (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4)))
272 (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
273 '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8)))
276 (equal? (eq-parse "1+1/2*3+(1+1)/2")
277 '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))