| blob | ca978862353cddd32fd420868e649e529652f1b4 |
1 ! Copyright (C) 2007 Chris Double.\r
2 ! See http://factorcode.org/license.txt for BSD license.\r
3 USING: kernel compiler.units words arrays strings math.parser\r
4 sequences quotations vectors namespaces make math assocs\r
5 continuations peg peg.parsers unicode.categories multiline\r
6 splitting accessors effects sequences.deep peg.search\r
7 combinators.short-circuit lexer io.streams.string stack-checker\r
8 io combinators parser ;\r
9 IN: peg.ebnf\r
10 \r
11 : rule ( name word -- parser )\r
12 #! Given an EBNF word produced from EBNF: return the EBNF rule\r
13 "ebnf-parser" word-prop at ;\r
14 \r
15 TUPLE: tokenizer any one many ;\r
16 \r
17 : default-tokenizer ( -- tokenizer )\r
18 T{ tokenizer f \r
19 [ any-char ]\r
20 [ token ]\r
21 [ [ = ] curry any-char swap semantic ]\r
22 } ;\r
23 \r
24 : parser-tokenizer ( parser -- tokenizer )\r
25 [ 1quotation ] keep\r
26 [ swap [ = ] curry semantic ] curry dup \ tokenizer boa ;\r
27 \r
28 : rule-tokenizer ( name word -- tokenizer )\r
29 rule parser-tokenizer ;\r
30 \r
31 : tokenizer ( -- word )\r
32 \ tokenizer get-global [ default-tokenizer ] unless* ;\r
33 \r
34 : reset-tokenizer ( -- )\r
35 default-tokenizer \ tokenizer set-global ;\r
36 \r
37 : TOKENIZER: \r
38 scan search [ "Tokenizer not found" throw ] unless*\r
39 execute \ tokenizer set-global ; parsing\r
40 \r
41 TUPLE: ebnf-non-terminal symbol ;\r
42 TUPLE: ebnf-terminal symbol ;\r
43 TUPLE: ebnf-foreign word rule ;\r
44 TUPLE: ebnf-any-character ;\r
45 TUPLE: ebnf-range pattern ;\r
46 TUPLE: ebnf-ensure group ;\r
47 TUPLE: ebnf-ensure-not group ;\r
48 TUPLE: ebnf-choice options ;\r
49 TUPLE: ebnf-sequence elements ;\r
50 TUPLE: ebnf-repeat0 group ;\r
51 TUPLE: ebnf-repeat1 group ;\r
52 TUPLE: ebnf-optional group ;\r
53 TUPLE: ebnf-whitespace group ;\r
54 TUPLE: ebnf-tokenizer elements ;\r
55 TUPLE: ebnf-rule symbol elements ;\r
56 TUPLE: ebnf-action parser code ;\r
57 TUPLE: ebnf-var parser name ;\r
58 TUPLE: ebnf-semantic parser code ;\r
59 TUPLE: ebnf rules ;\r
60 \r
61 C: <ebnf-non-terminal> ebnf-non-terminal\r
62 C: <ebnf-terminal> ebnf-terminal\r
63 C: <ebnf-foreign> ebnf-foreign\r
64 C: <ebnf-any-character> ebnf-any-character\r
65 C: <ebnf-range> ebnf-range\r
66 C: <ebnf-ensure> ebnf-ensure\r
67 C: <ebnf-ensure-not> ebnf-ensure-not\r
68 C: <ebnf-choice> ebnf-choice\r
69 C: <ebnf-sequence> ebnf-sequence\r
70 C: <ebnf-repeat0> ebnf-repeat0\r
71 C: <ebnf-repeat1> ebnf-repeat1\r
72 C: <ebnf-optional> ebnf-optional\r
73 C: <ebnf-whitespace> ebnf-whitespace\r
74 C: <ebnf-tokenizer> ebnf-tokenizer\r
75 C: <ebnf-rule> ebnf-rule\r
76 C: <ebnf-action> ebnf-action\r
77 C: <ebnf-var> ebnf-var\r
78 C: <ebnf-semantic> ebnf-semantic\r
79 C: <ebnf> ebnf\r
80 \r
81 : filter-hidden ( seq -- seq )\r
82 #! Remove elements that produce no AST from sequence\r
83 [ ebnf-ensure-not? not ] filter [ ebnf-ensure? not ] filter ;\r
84 \r
85 : syntax ( string -- parser )\r
86 #! Parses the string, ignoring white space, and\r
87 #! does not put the result in the AST.\r
88 token sp hide ;\r
89 \r
90 : syntax-pack ( begin parser end -- parser )\r
91 #! Parse 'parser' surrounded by syntax elements\r
92 #! begin and end.\r
93 [ syntax ] 2dip syntax pack ;\r
94 \r
95 #! Don't want to use 'replace' in an action since replace doesn't infer.\r
96 #! Do the compilation of the peg at parse time and call (replace).\r
97 PEG: escaper ( string -- ast )\r
98 [\r
99 "\\t" token [ drop "\t" ] action ,\r
100 "\\n" token [ drop "\n" ] action ,\r
101 "\\r" token [ drop "\r" ] action ,\r
102 "\\\\" token [ drop "\\" ] action ,\r
103 ] choice* any-char-parser 2array choice repeat0 ;\r
104 \r
105 : replace-escapes ( string -- string )\r
106 escaper sift [ [ tree-write ] each ] with-string-writer ;\r
107 \r
108 : insert-escapes ( string -- string )\r
109 [\r
110 "\t" token [ drop "\\t" ] action ,\r
111 "\n" token [ drop "\\n" ] action ,\r
112 "\r" token [ drop "\\r" ] action ,\r
113 ] choice* replace ;\r
114 \r
115 : 'identifier' ( -- parser )\r
116 #! Return a parser that parses an identifer delimited by\r
117 #! a quotation character. The quotation can be single\r
118 #! or double quotes. The AST produced is the identifier\r
119 #! between the quotes.\r
120 [\r
121 [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,\r
122 [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,\r
123 ] choice* [ >string replace-escapes ] action ;\r
124 \r
125 : 'non-terminal' ( -- parser )\r
126 #! A non-terminal is the name of another rule. It can\r
127 #! be any non-blank character except for characters used\r
128 #! in the EBNF syntax itself.\r
129 [\r
130 {\r
131 [ dup blank? ]\r
132 [ dup CHAR: " = ]\r
133 [ dup CHAR: ' = ]\r
134 [ dup CHAR: | = ]\r
135 [ dup CHAR: { = ]\r
136 [ dup CHAR: } = ]\r
137 [ dup CHAR: = = ]\r
138 [ dup CHAR: ) = ]\r
139 [ dup CHAR: ( = ]\r
140 [ dup CHAR: ] = ]\r
141 [ dup CHAR: [ = ]\r
142 [ dup CHAR: . = ]\r
143 [ dup CHAR: ! = ]\r
144 [ dup CHAR: & = ]\r
145 [ dup CHAR: * = ]\r
146 [ dup CHAR: + = ]\r
147 [ dup CHAR: ? = ]\r
148 [ dup CHAR: : = ]\r
149 [ dup CHAR: ~ = ]\r
150 [ dup CHAR: < = ]\r
151 [ dup CHAR: > = ]\r
152 } 0|| not nip \r
153 ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;\r
154 \r
155 : 'terminal' ( -- parser )\r
156 #! A terminal is an identifier enclosed in quotations\r
157 #! and it represents the literal value of the identifier.\r
158 'identifier' [ <ebnf-terminal> ] action ;\r
159 \r
160 : 'foreign-name' ( -- parser )\r
161 #! Parse a valid foreign parser name\r
162 [\r
163 {\r
164 [ dup blank? ]\r
165 [ dup CHAR: > = ]\r
166 } 0|| not nip \r
167 ] satisfy repeat1 [ >string ] action ;\r
168 \r
169 : 'foreign' ( -- parser )\r
170 #! A foreign call is a call to a rule in another ebnf grammar\r
171 [\r
172 "<foreign" syntax ,\r
173 'foreign-name' sp ,\r
174 'foreign-name' sp optional ,\r
175 ">" syntax ,\r
176 ] seq* [ first2 <ebnf-foreign> ] action ;\r
177 \r
178 : 'any-character' ( -- parser )\r
179 #! A parser to match the symbol for any character match.\r
180 [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;\r
181 \r
182 : 'range-parser' ( -- parser )\r
183 #! Match the syntax for declaring character ranges\r
184 [\r
185 [ "[" syntax , "[" token ensure-not , ] seq* hide ,\r
186 [ CHAR: ] = not ] satisfy repeat1 , \r
187 "]" syntax ,\r
188 ] seq* [ first >string <ebnf-range> ] action ;\r
189 \r
190 : ('element') ( -- parser )\r
191 #! An element of a rule. It can be a terminal or a \r
192 #! non-terminal but must not be followed by a "=". \r
193 #! The latter indicates that it is the beginning of a\r
194 #! new rule.\r
195 [\r
196 [\r
197 [ \r
198 'non-terminal' ,\r
199 'terminal' ,\r
200 'foreign' ,\r
201 'range-parser' ,\r
202 'any-character' ,\r
203 ] choice* \r
204 [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,\r
205 [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,\r
206 [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,\r
207 ,\r
208 ] choice* ,\r
209 [\r
210 "=" syntax ensure-not ,\r
211 "=>" syntax ensure ,\r
212 ] choice* ,\r
213 ] seq* [ first ] action ;\r
214 \r
215 DEFER: 'action'\r
216 \r
217 : 'element' ( -- parser )\r
218 [\r
219 [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
220 ('element') ,\r
221 ] choice* ;\r
222 \r
223 DEFER: 'choice'\r
224 \r
225 : grouped ( quot suffix -- parser )\r
226 #! Parse a group of choices, with a suffix indicating\r
227 #! the type of group (repeat0, repeat1, etc) and\r
228 #! an quot that is the action that produces the AST.\r
229 2dup\r
230 [\r
231 "(" [ 'choice' sp ] delay ")" syntax-pack \r
232 swap 2seq \r
233 [ first ] rot compose action ,\r
234 "{" [ 'choice' sp ] delay "}" syntax-pack \r
235 swap 2seq \r
236 [ first <ebnf-whitespace> ] rot compose action ,\r
237 ] choice* ;\r
238 \r
239 : 'group' ( -- parser )\r
240 #! A grouping with no suffix. Used for precedence.\r
241 [ ] [\r
242 "*" token sp ensure-not ,\r
243 "+" token sp ensure-not ,\r
244 "?" token sp ensure-not ,\r
245 ] seq* hide grouped ; \r
246 \r
247 : 'repeat0' ( -- parser )\r
248 [ <ebnf-repeat0> ] "*" syntax grouped ;\r
249 \r
250 : 'repeat1' ( -- parser )\r
251 [ <ebnf-repeat1> ] "+" syntax grouped ;\r
252 \r
253 : 'optional' ( -- parser )\r
254 [ <ebnf-optional> ] "?" syntax grouped ;\r
255 \r
256 : 'factor-code' ( -- parser )\r
257 [\r
258 "]]" token ensure-not ,\r
259 "]?" token ensure-not ,\r
260 [ drop t ] satisfy ,\r
261 ] seq* [ first ] action repeat0 [ >string ] action ;\r
262 \r
263 : 'ensure-not' ( -- parser )\r
264 #! Parses the '!' syntax to ensure that \r
265 #! something that matches the following elements do\r
266 #! not exist in the parse stream.\r
267 [\r
268 "!" syntax ,\r
269 'group' sp ,\r
270 ] seq* [ first <ebnf-ensure-not> ] action ;\r
271 \r
272 : 'ensure' ( -- parser )\r
273 #! Parses the '&' syntax to ensure that \r
274 #! something that matches the following elements does\r
275 #! exist in the parse stream.\r
276 [\r
277 "&" syntax ,\r
278 'group' sp ,\r
279 ] seq* [ first <ebnf-ensure> ] action ;\r
280 \r
281 : ('sequence') ( -- parser )\r
282 #! A sequence of terminals and non-terminals, including\r
283 #! groupings of those. \r
284 [\r
285 [ \r
286 'ensure-not' sp ,\r
287 'ensure' sp ,\r
288 'element' sp ,\r
289 'group' sp , \r
290 'repeat0' sp ,\r
291 'repeat1' sp ,\r
292 'optional' sp , \r
293 ] choice* \r
294 [ dup , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
295 ,\r
296 ] choice* ;\r
297 \r
298 : 'action' ( -- parser )\r
299 "[[" 'factor-code' "]]" syntax-pack ;\r
300 \r
301 : 'semantic' ( -- parser )\r
302 "?[" 'factor-code' "]?" syntax-pack ;\r
303 \r
304 : 'sequence' ( -- parser )\r
305 #! A sequence of terminals and non-terminals, including\r
306 #! groupings of those. \r
307 [\r
308 [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,\r
309 [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,\r
310 ('sequence') ,\r
311 ] choice* repeat1 [ \r
312 dup length 1 = [ first ] [ <ebnf-sequence> ] if\r
313 ] action ;\r
314 \r
315 : 'actioned-sequence' ( -- parser )\r
316 [\r
317 [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,\r
318 'sequence' ,\r
319 ] choice* ;\r
320 \r
321 : 'choice' ( -- parser )\r
322 'actioned-sequence' sp repeat1 [ dup length 1 = [ first ] [ <ebnf-sequence> ] if ] action "|" token sp list-of [ \r
323 dup length 1 = [ first ] [ <ebnf-choice> ] if\r
324 ] action ;\r
325 \r
326 : 'tokenizer' ( -- parser )\r
327 [\r
328 "tokenizer" syntax ,\r
329 "=" syntax ,\r
330 ">" token ensure-not ,\r
331 [ "default" token sp , 'choice' , ] choice* ,\r
332 ] seq* [ first <ebnf-tokenizer> ] action ;\r
333 \r
334 : 'rule' ( -- parser )\r
335 [\r
336 "tokenizer" token ensure-not , \r
337 'non-terminal' [ symbol>> ] action ,\r
338 "=" syntax ,\r
339 ">" token ensure-not ,\r
340 'choice' ,\r
341 ] seq* [ first2 <ebnf-rule> ] action ;\r
342 \r
343 : 'ebnf' ( -- parser )\r
344 [ 'tokenizer' sp , 'rule' sp , ] choice* repeat1 [ <ebnf> ] action ;\r
345 \r
346 GENERIC: (transform) ( ast -- parser )\r
347 \r
348 SYMBOL: parser\r
349 SYMBOL: main\r
350 SYMBOL: ignore-ws\r
351 \r
352 : transform ( ast -- object )\r
353 H{ } clone dup dup [ \r
354 f ignore-ws set \r
355 parser set \r
356 swap (transform) \r
357 main set \r
358 ] bind ;\r
359 \r
360 M: ebnf (transform) ( ast -- parser )\r
361 rules>> [ (transform) ] map peek ;\r
362 \r
363 M: ebnf-tokenizer (transform) ( ast -- parser )\r
364 elements>> dup "default" = [\r
365 drop default-tokenizer \ tokenizer set-global any-char\r
366 ] [\r
367 (transform) \r
368 dup parser-tokenizer \ tokenizer set-global\r
369 ] if ;\r
370 \r
371 M: ebnf-rule (transform) ( ast -- parser )\r
372 dup elements>> \r
373 (transform) [\r
374 swap symbol>> dup get parser? [ \r
375 "Rule '" over append "' defined more than once" append throw \r
376 ] [ \r
377 set \r
378 ] if\r
379 ] keep ;\r
380 \r
381 M: ebnf-sequence (transform) ( ast -- parser )\r
382 #! If ignore-ws is set then each element of the sequence\r
383 #! ignores leading whitespace. This is not inherited by\r
384 #! subelements of the sequence.\r
385 elements>> [ \r
386 f ignore-ws [ (transform) ] with-variable\r
387 ignore-ws get [ sp ] when\r
388 ] map seq [ dup length 1 = [ first ] when ] action ;\r
389 \r
390 M: ebnf-choice (transform) ( ast -- parser )\r
391 options>> [ (transform) ] map choice ;\r
392 \r
393 M: ebnf-any-character (transform) ( ast -- parser )\r
394 drop tokenizer any>> call ;\r
395 \r
396 M: ebnf-range (transform) ( ast -- parser )\r
397 pattern>> range-pattern ;\r
398 \r
399 : transform-group ( ast -- parser ) \r
400 #! convert a ast node with groups to a parser for that group\r
401 group>> (transform) ;\r
402 \r
403 M: ebnf-ensure (transform) ( ast -- parser )\r
404 transform-group ensure ;\r
405 \r
406 M: ebnf-ensure-not (transform) ( ast -- parser )\r
407 transform-group ensure-not ;\r
408 \r
409 M: ebnf-repeat0 (transform) ( ast -- parser )\r
410 transform-group repeat0 ;\r
411 \r
412 M: ebnf-repeat1 (transform) ( ast -- parser )\r
413 transform-group repeat1 ;\r
414 \r
415 M: ebnf-optional (transform) ( ast -- parser )\r
416 transform-group optional ;\r
417 \r
418 M: ebnf-whitespace (transform) ( ast -- parser )\r
419 t ignore-ws [ transform-group ] with-variable ;\r
420 \r
421 GENERIC: build-locals ( code ast -- code )\r
422 \r
423 M: ebnf-sequence build-locals ( code ast -- code )\r
424 #! Note the need to filter out this ebnf items that\r
425 #! leave nothing in the AST\r
426 elements>> filter-hidden dup length 1 = [ \r
427 first build-locals \r
428 ] [\r
429 dup [ ebnf-var? ] filter empty? [\r
430 drop \r
431 ] [ \r
432 [\r
433 "USING: locals sequences ; [let* | " %\r
434 dup length swap [\r
435 dup ebnf-var? [\r
436 name>> % \r
437 " [ " % # " over nth ] " %\r
438 ] [\r
439 2drop\r
440 ] if\r
441 ] 2each\r
442 " | " %\r
443 % \r
444 " nip ]" % \r
445 ] "" make \r
446 ] if\r
447 ] if ;\r
448 \r
449 M: ebnf-var build-locals ( code ast -- )\r
450 [\r
451 "USING: locals kernel ; [let* | " %\r
452 name>> % " [ dup ] " %\r
453 " | " %\r
454 % \r
455 " nip ]" % \r
456 ] "" make ;\r
457 \r
458 M: object build-locals ( code ast -- )\r
459 drop ;\r
460 \r
461 ERROR: bad-effect quot effect ;\r
462 \r
463 : check-action-effect ( quot -- quot )\r
464 dup infer {\r
465 { [ dup (( a -- b )) effect<= ] [ drop ] }\r
466 { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }\r
467 [ bad-effect ]\r
468 } cond ;\r
469 \r
470 M: ebnf-action (transform) ( ast -- parser )\r
471 [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
472 string-lines parse-lines check-action-effect action ;\r
473 \r
474 M: ebnf-semantic (transform) ( ast -- parser )\r
475 [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
476 string-lines parse-lines semantic ;\r
477 \r
478 M: ebnf-var (transform) ( ast -- parser )\r
479 parser>> (transform) ;\r
480 \r
481 M: ebnf-terminal (transform) ( ast -- parser )\r
482 symbol>> tokenizer one>> call ;\r
483 \r
484 M: ebnf-foreign (transform) ( ast -- parser )\r
485 dup word>> search\r
486 [ "Foreign word '" swap word>> append "' not found" append throw ] unless*\r
487 swap rule>> [ main ] unless* over rule [\r
488 nip\r
489 ] [\r
490 execute\r
491 ] if* ;\r
492 \r
493 : parser-not-found ( name -- * )\r
494 [\r
495 "Parser '" % % "' not found." %\r
496 ] "" make throw ;\r
497 \r
498 M: ebnf-non-terminal (transform) ( ast -- parser )\r
499 symbol>> [\r
500 , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , \r
501 ] [ ] make box ;\r
502 \r
503 : transform-ebnf ( string -- object )\r
504 'ebnf' parse transform ;\r
505 \r
506 : check-parse-result ( result -- result )\r
507 dup [\r
508 dup remaining>> [ blank? ] trim empty? [\r
509 [ \r
510 "Unable to fully parse EBNF. Left to parse was: " %\r
511 remaining>> % \r
512 ] "" make throw\r
513 ] unless\r
514 ] [\r
515 "Could not parse EBNF" throw\r
516 ] if ;\r
517 \r
518 : parse-ebnf ( string -- hashtable )\r
519 'ebnf' (parse) check-parse-result ast>> transform ;\r
520 \r
521 : ebnf>quot ( string -- hashtable quot )\r
522 parse-ebnf dup dup parser [ main swap at compile ] with-variable\r
523 [ compiled-parse ] curry [ with-scope ast>> ] curry ;\r
524 \r
525 : <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
526 parsed reset-tokenizer ; parsing\r
527 \r
528 : [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip \r
529 parsed \ call parsed reset-tokenizer ; parsing\r
530 \r
531 : EBNF: \r
532 reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
533 ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop \r
534 reset-tokenizer ; parsing\r
535 \r
536 \r
537 \r