1 ! Copyright (C) 2007 Chris Double.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: kernel 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 summary ;
\r
9 FROM: compiler.units => with-compilation-unit ;
\r
10 FROM: vocabs.parser => search ;
\r
13 : rule ( name word -- parser )
\r
14 #! Given an EBNF word produced from EBNF: return the EBNF rule
\r
15 "ebnf-parser" word-prop at ;
\r
17 ERROR: no-rule rule parser ;
\r
21 : lookup-rule ( rule parser -- rule' )
\r
22 2dup rule [ 2nip ] [ no-rule ] if* ;
\r
24 TUPLE: tokenizer any one many ;
\r
26 : default-tokenizer ( -- tokenizer )
\r
30 [ [ = ] curry any-char swap semantic ]
\r
33 : parser-tokenizer ( parser -- tokenizer )
\r
35 [ swap [ = ] curry semantic ] curry dup \ tokenizer boa ;
\r
37 : rule-tokenizer ( name word -- tokenizer )
\r
38 rule parser-tokenizer ;
\r
40 : tokenizer ( -- word )
\r
41 \ tokenizer get-global [ default-tokenizer ] unless* ;
\r
43 : reset-tokenizer ( -- )
\r
44 default-tokenizer \ tokenizer set-global ;
\r
46 ERROR: no-tokenizer name ;
\r
48 M: no-tokenizer summary
\r
49 drop "Tokenizer not found" ;
\r
52 scan dup search [ nip ] [ no-tokenizer ] if*
\r
53 execute( -- tokenizer ) \ tokenizer set-global ;
\r
55 TUPLE: ebnf-non-terminal symbol ;
\r
56 TUPLE: ebnf-terminal symbol ;
\r
57 TUPLE: ebnf-foreign word rule ;
\r
58 TUPLE: ebnf-any-character ;
\r
59 TUPLE: ebnf-range pattern ;
\r
60 TUPLE: ebnf-ensure group ;
\r
61 TUPLE: ebnf-ensure-not group ;
\r
62 TUPLE: ebnf-choice options ;
\r
63 TUPLE: ebnf-sequence elements ;
\r
64 TUPLE: ebnf-repeat0 group ;
\r
65 TUPLE: ebnf-repeat1 group ;
\r
66 TUPLE: ebnf-optional group ;
\r
67 TUPLE: ebnf-whitespace group ;
\r
68 TUPLE: ebnf-tokenizer elements ;
\r
69 TUPLE: ebnf-rule symbol elements ;
\r
70 TUPLE: ebnf-action parser code ;
\r
71 TUPLE: ebnf-var parser name ;
\r
72 TUPLE: ebnf-semantic parser code ;
\r
75 C: <ebnf-non-terminal> ebnf-non-terminal
\r
76 C: <ebnf-terminal> ebnf-terminal
\r
77 C: <ebnf-foreign> ebnf-foreign
\r
78 C: <ebnf-any-character> ebnf-any-character
\r
79 C: <ebnf-range> ebnf-range
\r
80 C: <ebnf-ensure> ebnf-ensure
\r
81 C: <ebnf-ensure-not> ebnf-ensure-not
\r
82 C: <ebnf-choice> ebnf-choice
\r
83 C: <ebnf-sequence> ebnf-sequence
\r
84 C: <ebnf-repeat0> ebnf-repeat0
\r
85 C: <ebnf-repeat1> ebnf-repeat1
\r
86 C: <ebnf-optional> ebnf-optional
\r
87 C: <ebnf-whitespace> ebnf-whitespace
\r
88 C: <ebnf-tokenizer> ebnf-tokenizer
\r
89 C: <ebnf-rule> ebnf-rule
\r
90 C: <ebnf-action> ebnf-action
\r
91 C: <ebnf-var> ebnf-var
\r
92 C: <ebnf-semantic> ebnf-semantic
\r
95 : filter-hidden ( seq -- seq )
\r
96 #! Remove elements that produce no AST from sequence
\r
97 [ ebnf-ensure-not? not ] filter [ ebnf-ensure? not ] filter ;
\r
99 : syntax ( string -- parser )
\r
100 #! Parses the string, ignoring white space, and
\r
101 #! does not put the result in the AST.
\r
104 : syntax-pack ( begin parser end -- parser )
\r
105 #! Parse 'parser' surrounded by syntax elements
\r
107 [ syntax ] 2dip syntax pack ;
\r
109 #! Don't want to use 'replace' in an action since replace doesn't infer.
\r
110 #! Do the compilation of the peg at parse time and call (replace).
\r
111 PEG: escaper ( string -- ast )
\r
113 "\\t" token [ drop "\t" ] action ,
\r
114 "\\n" token [ drop "\n" ] action ,
\r
115 "\\r" token [ drop "\r" ] action ,
\r
116 "\\\\" token [ drop "\\" ] action ,
\r
117 ] choice* any-char-parser 2array choice repeat0 ;
\r
119 : replace-escapes ( string -- string )
\r
120 escaper sift [ [ tree-write ] each ] with-string-writer ;
\r
122 : insert-escapes ( string -- string )
\r
124 "\t" token [ drop "\\t" ] action ,
\r
125 "\n" token [ drop "\\n" ] action ,
\r
126 "\r" token [ drop "\\r" ] action ,
\r
127 ] choice* replace ;
\r
129 : 'identifier' ( -- parser )
\r
130 #! Return a parser that parses an identifer delimited by
\r
131 #! a quotation character. The quotation can be single
\r
132 #! or double quotes. The AST produced is the identifier
\r
133 #! between the quotes.
\r
135 [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
\r
136 [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
\r
137 ] choice* [ >string replace-escapes ] action ;
\r
139 : 'non-terminal' ( -- parser )
\r
140 #! A non-terminal is the name of another rule. It can
\r
141 #! be any non-blank character except for characters used
\r
142 #! in the EBNF syntax itself.
\r
167 ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
\r
169 : 'terminal' ( -- parser )
\r
170 #! A terminal is an identifier enclosed in quotations
\r
171 #! and it represents the literal value of the identifier.
\r
172 'identifier' [ <ebnf-terminal> ] action ;
\r
174 : 'foreign-name' ( -- parser )
\r
175 #! Parse a valid foreign parser name
\r
181 ] satisfy repeat1 [ >string ] action ;
\r
183 : 'foreign' ( -- parser )
\r
184 #! A foreign call is a call to a rule in another ebnf grammar
\r
186 "<foreign" syntax ,
\r
187 'foreign-name' sp ,
\r
188 'foreign-name' sp optional ,
\r
190 ] seq* [ first2 <ebnf-foreign> ] action ;
\r
192 : 'any-character' ( -- parser )
\r
193 #! A parser to match the symbol for any character match.
\r
194 [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
\r
196 : 'range-parser' ( -- parser )
\r
197 #! Match the syntax for declaring character ranges
\r
199 [ "[" syntax , "[" token ensure-not , ] seq* hide ,
\r
200 [ CHAR: ] = not ] satisfy repeat1 ,
\r
202 ] seq* [ first >string <ebnf-range> ] action ;
\r
204 : ('element') ( -- parser )
\r
205 #! An element of a rule. It can be a terminal or a
\r
206 #! non-terminal but must not be followed by a "=".
\r
207 #! The latter indicates that it is the beginning of a
\r
218 [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,
\r
219 [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,
\r
220 [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,
\r
224 "=" syntax ensure-not ,
\r
225 "=>" syntax ensure ,
\r
227 ] seq* [ first ] action ;
\r
231 : 'element' ( -- parser )
\r
233 [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
\r
239 : grouped ( quot suffix -- parser )
\r
240 #! Parse a group of choices, with a suffix indicating
\r
241 #! the type of group (repeat0, repeat1, etc) and
\r
242 #! an quot that is the action that produces the AST.
\r
245 "(" [ 'choice' sp ] delay ")" syntax-pack
\r
247 [ first ] rot compose action ,
\r
248 "{" [ 'choice' sp ] delay "}" syntax-pack
\r
250 [ first <ebnf-whitespace> ] rot compose action ,
\r
253 : 'group' ( -- parser )
\r
254 #! A grouping with no suffix. Used for precedence.
\r
256 "*" token sp ensure-not ,
\r
257 "+" token sp ensure-not ,
\r
258 "?" token sp ensure-not ,
\r
259 ] seq* hide grouped ;
\r
261 : 'repeat0' ( -- parser )
\r
262 [ <ebnf-repeat0> ] "*" syntax grouped ;
\r
264 : 'repeat1' ( -- parser )
\r
265 [ <ebnf-repeat1> ] "+" syntax grouped ;
\r
267 : 'optional' ( -- parser )
\r
268 [ <ebnf-optional> ] "?" syntax grouped ;
\r
270 : 'factor-code' ( -- parser )
\r
272 "]]" token ensure-not ,
\r
273 "]?" token ensure-not ,
\r
274 [ drop t ] satisfy ,
\r
275 ] seq* repeat0 [ concat >string ] action ;
\r
277 : 'ensure-not' ( -- parser )
\r
278 #! Parses the '!' syntax to ensure that
\r
279 #! something that matches the following elements do
\r
280 #! not exist in the parse stream.
\r
284 ] seq* [ first <ebnf-ensure-not> ] action ;
\r
286 : 'ensure' ( -- parser )
\r
287 #! Parses the '&' syntax to ensure that
\r
288 #! something that matches the following elements does
\r
289 #! exist in the parse stream.
\r
293 ] seq* [ first <ebnf-ensure> ] action ;
\r
295 : ('sequence') ( -- parser )
\r
296 #! A sequence of terminals and non-terminals, including
\r
297 #! groupings of those.
\r
308 [ dup , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
\r
312 : 'action' ( -- parser )
\r
313 "[[" 'factor-code' "]]" syntax-pack ;
\r
315 : 'semantic' ( -- parser )
\r
316 "?[" 'factor-code' "]?" syntax-pack ;
\r
318 : 'sequence' ( -- parser )
\r
319 #! A sequence of terminals and non-terminals, including
\r
320 #! groupings of those.
\r
322 [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
\r
323 [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
\r
325 ] choice* repeat1 [
\r
326 dup length 1 = [ first ] [ <ebnf-sequence> ] if
\r
329 : 'actioned-sequence' ( -- parser )
\r
331 [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
\r
335 : 'choice' ( -- parser )
\r
336 'actioned-sequence' sp repeat1 [ dup length 1 = [ first ] [ <ebnf-sequence> ] if ] action "|" token sp list-of [
\r
337 dup length 1 = [ first ] [ <ebnf-choice> ] if
\r
340 : 'tokenizer' ( -- parser )
\r
342 "tokenizer" syntax ,
\r
344 ">" token ensure-not ,
\r
345 [ "default" token sp , 'choice' , ] choice* ,
\r
346 ] seq* [ first <ebnf-tokenizer> ] action ;
\r
348 : 'rule' ( -- parser )
\r
350 "tokenizer" token ensure-not ,
\r
351 'non-terminal' [ symbol>> ] action ,
\r
353 ">" token ensure-not ,
\r
355 ] seq* [ first2 <ebnf-rule> ] action ;
\r
357 : 'ebnf' ( -- parser )
\r
358 [ 'tokenizer' sp , 'rule' sp , ] choice* repeat1 [ <ebnf> ] action ;
\r
360 GENERIC: (transform) ( ast -- parser )
\r
366 : transform ( ast -- object )
\r
367 H{ } clone dup dup [
\r
374 M: ebnf (transform) ( ast -- parser )
\r
375 rules>> [ (transform) ] map last ;
\r
377 M: ebnf-tokenizer (transform) ( ast -- parser )
\r
378 elements>> dup "default" = [
\r
379 drop default-tokenizer \ tokenizer set-global any-char
\r
382 dup parser-tokenizer \ tokenizer set-global
\r
385 ERROR: redefined-rule name ;
\r
387 M: redefined-rule summary
\r
388 name>> "Rule '" "' defined more than once" surround ;
\r
390 M: ebnf-rule (transform) ( ast -- parser )
\r
393 swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
\r
396 M: ebnf-sequence (transform) ( ast -- parser )
\r
397 #! If ignore-ws is set then each element of the sequence
\r
398 #! ignores leading whitespace. This is not inherited by
\r
399 #! subelements of the sequence.
\r
401 f ignore-ws [ (transform) ] with-variable
\r
402 ignore-ws get [ sp ] when
\r
403 ] map seq [ dup length 1 = [ first ] when ] action ;
\r
405 M: ebnf-choice (transform) ( ast -- parser )
\r
406 options>> [ (transform) ] map choice ;
\r
408 M: ebnf-any-character (transform) ( ast -- parser )
\r
409 drop tokenizer any>> call( -- parser ) ;
\r
411 M: ebnf-range (transform) ( ast -- parser )
\r
412 pattern>> range-pattern ;
\r
414 : transform-group ( ast -- parser )
\r
415 #! convert a ast node with groups to a parser for that group
\r
416 group>> (transform) ;
\r
418 M: ebnf-ensure (transform) ( ast -- parser )
\r
419 transform-group ensure ;
\r
421 M: ebnf-ensure-not (transform) ( ast -- parser )
\r
422 transform-group ensure-not ;
\r
424 M: ebnf-repeat0 (transform) ( ast -- parser )
\r
425 transform-group repeat0 ;
\r
427 M: ebnf-repeat1 (transform) ( ast -- parser )
\r
428 transform-group repeat1 ;
\r
430 M: ebnf-optional (transform) ( ast -- parser )
\r
431 transform-group optional ;
\r
433 M: ebnf-whitespace (transform) ( ast -- parser )
\r
434 t ignore-ws [ transform-group ] with-variable ;
\r
436 GENERIC: build-locals ( code ast -- code )
\r
438 M: ebnf-sequence build-locals ( code ast -- code )
\r
439 #! Note the need to filter out this ebnf items that
\r
440 #! leave nothing in the AST
\r
441 elements>> filter-hidden dup length 1 = [
\r
442 first build-locals
\r
444 dup [ ebnf-var? ] filter empty? [
\r
448 "FROM: locals => [let :> ; FROM: sequences => nth ; [let " %
\r
451 " " % # " over nth :> " %
\r
464 M: ebnf-var build-locals ( code ast -- )
\r
466 "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %
\r
467 " dup :> " % name>> %
\r
473 M: object build-locals ( code ast -- )
\r
476 ERROR: bad-effect quot effect ;
\r
478 : check-action-effect ( quot -- quot )
\r
480 { [ dup (( a -- b )) effect<= ] [ drop ] }
\r
481 { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
\r
485 : ebnf-transform ( ast -- parser quot )
\r
486 [ parser>> (transform) ]
\r
487 [ code>> insert-escapes ]
\r
488 [ parser>> ] tri build-locals
\r
489 [ string-lines parse-lines ] call( string -- quot ) ;
\r
491 M: ebnf-action (transform) ( ast -- parser )
\r
492 ebnf-transform check-action-effect action ;
\r
494 M: ebnf-semantic (transform) ( ast -- parser )
\r
495 ebnf-transform semantic ;
\r
497 M: ebnf-var (transform) ( ast -- parser )
\r
498 parser>> (transform) ;
\r
500 M: ebnf-terminal (transform) ( ast -- parser )
\r
501 symbol>> tokenizer one>> call( symbol -- parser ) ;
\r
503 ERROR: ebnf-foreign-not-found name ;
\r
505 M: ebnf-foreign-not-found summary
\r
506 name>> "Foreign word '" "' not found" surround ;
\r
508 M: ebnf-foreign (transform) ( ast -- parser )
\r
509 dup word>> search [ word>> ebnf-foreign-not-found ] unless*
\r
510 swap rule>> [ main ] unless* over rule [
\r
513 execute( -- parser )
\r
516 ERROR: parser-not-found name ;
\r
518 M: ebnf-non-terminal (transform) ( ast -- parser )
\r
520 , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip ,
\r
523 : transform-ebnf ( string -- object )
\r
524 'ebnf' parse transform ;
\r
526 : check-parse-result ( result -- result )
\r
528 dup remaining>> [ blank? ] trim [
\r
530 "Unable to fully parse EBNF. Left to parse was: " %
\r
535 "Could not parse EBNF" throw
\r
538 : parse-ebnf ( string -- hashtable )
\r
539 'ebnf' (parse) check-parse-result ast>> transform ;
\r
541 : ebnf>quot ( string -- hashtable quot )
\r
542 parse-ebnf dup dup parser [ main swap at compile ] with-variable
\r
543 [ compiled-parse ] curry [ with-scope ast>> ] curry ;
\r
549 reset-tokenizer parse-multiline-string parse-ebnf main swap at
\r
550 suffix! reset-tokenizer ;
\r
554 reset-tokenizer parse-multiline-string ebnf>quot nip
\r
555 suffix! \ call suffix! reset-tokenizer ;
\r
558 reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
\r
560 (( input -- ast )) define-declared "ebnf-parser" set-word-prop
\r