peg.test 9.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;; PEG test suite.
  3. ;; Tests the parsing capabilities of (ice-9 peg). Could use more
  4. ;; tests for edge cases.
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. (define-module (test-suite test-peg)
  7. :use-module (test-suite lib)
  8. :use-module (ice-9 peg)
  9. :use-module (ice-9 pretty-print)
  10. :use-module (srfi srfi-1))
  11. ;; Doubled up for pasting into REPL.
  12. (use-modules (test-suite lib))
  13. (use-modules (ice-9 peg))
  14. (use-modules (ice-9 pretty-print))
  15. (use-modules (srfi srfi-1))
  16. ;; Evaluates an expression at the toplevel. Not the prettiest
  17. ;; solution to runtime issues ever, but m3h. Runs at toplevel so that
  18. ;; symbols are bound globally instead of in the scope of the pass-if
  19. ;; expression.
  20. (define (eeval exp)
  21. (eval exp (interaction-environment)))
  22. (define make-prec (@@ (ice-9 peg) make-prec))
  23. ;; Maps the nonterminals defined in the PEG parser written as a PEG to
  24. ;; the nonterminals defined in the PEG parser written with
  25. ;; S-expressions.
  26. (define grammar-mapping
  27. '((grammar peg-grammar)
  28. (pattern peg-pattern)
  29. (alternative peg-alternative)
  30. (suffix peg-suffix)
  31. (primary peg-primary)
  32. (literal peg-literal)
  33. (charclass peg-charclass)
  34. (CCrange charclass-range)
  35. (CCsingle charclass-single)
  36. (nonterminal peg-nonterminal)
  37. (sp peg-sp)))
  38. ;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
  39. (define (grammar-transform x)
  40. (let ((res (assoc x grammar-mapping)))
  41. (if res (cadr res) x)))
  42. ;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms).
  43. (define (tree-map fn lst)
  44. (if (list? lst)
  45. (if (null? lst)
  46. lst
  47. (cons (tree-map fn (car lst))
  48. (tree-map fn (cdr lst))))
  49. (fn lst)))
  50. ;; Tests to make sure that we can parse a PEG defining a grammar for
  51. ;; PEGs, then uses that grammar to parse the same PEG again to make
  52. ;; sure we get the same result (i.e. make sure our PEG grammar
  53. ;; expressed as a PEG is equivalent to our PEG grammar expressed with
  54. ;; S-expressions).
  55. (with-test-prefix "PEG Grammar"
  56. (pass-if
  57. "defining PEGs with PEG"
  58. (and (eeval `(define-peg-string-patterns ,(@@ (ice-9 peg) peg-as-peg))) #t))
  59. (pass-if
  60. "equivalence of definitions"
  61. (equal?
  62. (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
  63. (tree-map
  64. grammar-transform
  65. (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
  66. ;; A grammar for pascal-style comments from Wikipedia.
  67. (define comment-grammar
  68. "Begin <-- '(*'
  69. End <-- '*)'
  70. C <- Begin N* End
  71. N <- C / (!Begin !End Z)
  72. Z <- .")
  73. ;; A short /etc/passwd file.
  74. (define *etc-passwd*
  75. "root:x:0:0:root:/root:/bin/bash
  76. daemon:x:1:1:daemon:/usr/sbin:/bin/sh
  77. bin:x:2:2:bin:/bin:/bin/sh
  78. sys:x:3:3:sys:/dev:/bin/sh
  79. nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
  80. messagebus:x:103:107::/var/run/dbus:/bin/false
  81. ")
  82. ;; A grammar for parsing /etc/passwd files.
  83. (define-peg-string-patterns
  84. "passwd <-- entry* !.
  85. entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL*
  86. login <-- text
  87. pass <-- text
  88. uid <-- [0-9]*
  89. gid <-- [0-9]*
  90. nameORcomment <-- text
  91. homedir <-- path
  92. shell <-- path
  93. path <-- (SLASH pathELEMENT)*
  94. pathELEMENT <-- (!NL !CO !'/' .)*
  95. text <- (!NL !CO .)*
  96. CO < ':'
  97. NL < '\n'
  98. SLASH < '/'")
  99. ;; Tests some actual parsing using PEGs.
  100. (with-test-prefix "Parsing"
  101. (eeval `(define-peg-string-patterns ,comment-grammar))
  102. (pass-if
  103. ;; Pascal-style comment parsing
  104. "simple comment"
  105. (equal?
  106. (match-pattern C "(*blah*)")
  107. (make-prec 0 8 "(*blah*)"
  108. '((Begin "(*") "blah" (End "*)")))))
  109. (pass-if
  110. "simple comment padded"
  111. (equal?
  112. (match-pattern C "(*blah*)abc")
  113. (make-prec 0 8 "(*blah*)abc"
  114. '((Begin "(*") "blah" (End "*)")))))
  115. (pass-if
  116. "nested comment"
  117. (equal?
  118. (match-pattern C "(*1(*2*)*)")
  119. (make-prec 0 10 "(*1(*2*)*)"
  120. '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)")))))
  121. (pass-if
  122. "early termination"
  123. (not (match-pattern C "(*blah")))
  124. (pass-if
  125. "never starts"
  126. (not (match-pattern C "blah")))
  127. ;; /etc/passwd parsing
  128. (pass-if
  129. "/etc/passwd"
  130. (equal?
  131. (match-pattern passwd *etc-passwd*)
  132. (make-prec 0 220 *etc-passwd*
  133. '(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")))))))))
  134. ;; Tests the functions for pulling data out of PEG Match Records.
  135. (with-test-prefix "PEG Match Records"
  136. (define-peg-pattern bs all (peg "'b'+"))
  137. (pass-if
  138. "basic parameter extraction"
  139. (equal?
  140. (let ((pm (search-for-pattern bs "aabbcc")))
  141. `((string ,(peg:string pm))
  142. (start ,(peg:start pm))
  143. (end ,(peg:end pm))
  144. (substring ,(peg:substring pm))
  145. (tree ,(peg:tree pm))
  146. (record? ,(peg-record? pm))))
  147. '((string "aabbcc")
  148. (start 2)
  149. (end 4)
  150. (substring "bb")
  151. (tree (bs "bb"))
  152. (record? #t)))))
  153. ;; PEG for parsing right-associative equations.
  154. (define-peg-string-patterns
  155. "expr <- sum
  156. sum <-- (product ('+' / '-') sum) / product
  157. product <-- (value ('*' / '/') product) / value
  158. value <-- number / '(' expr ')'
  159. number <-- [0-9]+")
  160. ;; Functions to actually evaluate the equations parsed with the PEG.
  161. (define (parse-sum sum left . rest)
  162. (if (null? rest)
  163. (apply parse-product left)
  164. (list (string->symbol (car rest))
  165. (apply parse-product left)
  166. (apply parse-sum (cadr rest)))))
  167. (define (parse-product product left . rest)
  168. (if (null? rest)
  169. (apply parse-value left)
  170. (list (string->symbol (car rest))
  171. (apply parse-value left)
  172. (apply parse-product (cadr rest)))))
  173. (define (parse-value value first . rest)
  174. (if (null? rest)
  175. (string->number (cadr first))
  176. (apply parse-sum (car rest))))
  177. (define parse-expr parse-sum)
  178. (define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
  179. (with-test-prefix "Parsing right-associative equations"
  180. (pass-if
  181. "1"
  182. (equal? (eq-parse "1") 1))
  183. (pass-if
  184. "1+2"
  185. (equal? (eq-parse "1+2") '(+ 1 2)))
  186. (pass-if
  187. "1+2+3"
  188. (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3))))
  189. (pass-if
  190. "1+2*3+4"
  191. (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4))))
  192. (pass-if
  193. "1+2/3*(4+5)/6-7-8"
  194. (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
  195. '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8)))))
  196. (pass-if
  197. "1+1/2*3+(1+1)/2"
  198. (equal? (eq-parse "1+1/2*3+(1+1)/2")
  199. '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2))))))
  200. ;; PEG for parsing left-associative equations (normal ones).
  201. (define-peg-string-patterns
  202. "expr <- sum
  203. sum <-- (product ('+' / '-'))* product
  204. product <-- (value ('*' / '/'))* value
  205. value <-- number / '(' expr ')'
  206. number <-- [0-9]+")
  207. ;; Functions to actually evaluate the equations parsed with the PEG.
  208. (define (make-left-parser next-func)
  209. (lambda (sum first . rest)
  210. (if (null? rest)
  211. (apply next-func first)
  212. (if (string? (cadr first))
  213. (list (string->symbol (cadr first))
  214. (apply next-func (car first))
  215. (apply next-func (car rest)))
  216. (car
  217. (reduce
  218. (lambda (l r)
  219. (list (list (cadr r) (car r) (apply next-func (car l)))
  220. (string->symbol (cadr l))))
  221. 'ignore
  222. (append
  223. (list (list (apply next-func (caar first))
  224. (string->symbol (cadar first))))
  225. (cdr first)
  226. (list (append rest '("done"))))))))))
  227. (define (parse-value value first . rest)
  228. (if (null? rest)
  229. (string->number (cadr first))
  230. (apply parse-sum (car rest))))
  231. (define parse-product (make-left-parser parse-value))
  232. (define parse-sum (make-left-parser parse-product))
  233. (define parse-expr parse-sum)
  234. (define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
  235. (with-test-prefix "Parsing left-associative equations"
  236. (pass-if
  237. "1"
  238. (equal? (eq-parse "1") 1))
  239. (pass-if
  240. "1+2"
  241. (equal? (eq-parse "1+2") '(+ 1 2)))
  242. (pass-if
  243. "1+2+3"
  244. (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3)))
  245. (pass-if
  246. "1+2*3+4"
  247. (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4)))
  248. (pass-if
  249. "1+2/3*(4+5)/6-7-8"
  250. (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
  251. '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8)))
  252. (pass-if
  253. "1+1/2*3+(1+1)/2"
  254. (equal? (eq-parse "1+1/2*3+(1+1)/2")
  255. '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))