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
19 : lookup-rule ( rule parser -- rule' )
\r
20 2dup rule [ 2nip ] [ no-rule ] if* ;
\r
22 TUPLE: tokenizer any one many ;
\r
24 : default-tokenizer ( -- tokenizer )
\r
28 [ [ = ] curry any-char swap semantic ]
\r
31 : parser-tokenizer ( parser -- tokenizer )
\r
33 [ swap [ = ] curry semantic ] curry dup \ tokenizer boa ;
\r
35 : rule-tokenizer ( name word -- tokenizer )
\r
36 rule parser-tokenizer ;
\r
38 : tokenizer ( -- word )
\r
39 \ tokenizer get-global [ default-tokenizer ] unless* ;
\r
41 : reset-tokenizer ( -- )
\r
42 default-tokenizer \ tokenizer set-global ;
\r
44 ERROR: no-tokenizer name ;
\r
46 M: no-tokenizer summary
\r
47 drop "Tokenizer not found" ;
\r
50 scan dup search [ nip ] [ no-tokenizer ] if*
\r
51 execute( -- tokenizer ) \ tokenizer set-global ;
\r
53 TUPLE: ebnf-non-terminal symbol ;
\r
54 TUPLE: ebnf-terminal symbol ;
\r
55 TUPLE: ebnf-foreign word rule ;
\r
56 TUPLE: ebnf-any-character ;
\r
57 TUPLE: ebnf-range pattern ;
\r
58 TUPLE: ebnf-ensure group ;
\r
59 TUPLE: ebnf-ensure-not group ;
\r
60 TUPLE: ebnf-choice options ;
\r
61 TUPLE: ebnf-sequence elements ;
\r
62 TUPLE: ebnf-repeat0 group ;
\r
63 TUPLE: ebnf-repeat1 group ;
\r
64 TUPLE: ebnf-optional group ;
\r
65 TUPLE: ebnf-whitespace group ;
\r
66 TUPLE: ebnf-tokenizer elements ;
\r
67 TUPLE: ebnf-rule symbol elements ;
\r
68 TUPLE: ebnf-action parser code ;
\r
69 TUPLE: ebnf-var parser name ;
\r
70 TUPLE: ebnf-semantic parser code ;
\r
73 C: <ebnf-non-terminal> ebnf-non-terminal
\r
74 C: <ebnf-terminal> ebnf-terminal
\r
75 C: <ebnf-foreign> ebnf-foreign
\r
76 C: <ebnf-any-character> ebnf-any-character
\r
77 C: <ebnf-range> ebnf-range
\r
78 C: <ebnf-ensure> ebnf-ensure
\r
79 C: <ebnf-ensure-not> ebnf-ensure-not
\r
80 C: <ebnf-choice> ebnf-choice
\r
81 C: <ebnf-sequence> ebnf-sequence
\r
82 C: <ebnf-repeat0> ebnf-repeat0
\r
83 C: <ebnf-repeat1> ebnf-repeat1
\r
84 C: <ebnf-optional> ebnf-optional
\r
85 C: <ebnf-whitespace> ebnf-whitespace
\r
86 C: <ebnf-tokenizer> ebnf-tokenizer
\r
87 C: <ebnf-rule> ebnf-rule
\r
88 C: <ebnf-action> ebnf-action
\r
89 C: <ebnf-var> ebnf-var
\r
90 C: <ebnf-semantic> ebnf-semantic
\r
93 : filter-hidden ( seq -- seq )
\r
94 #! Remove elements that produce no AST from sequence
\r
95 [ ebnf-ensure-not? not ] filter [ ebnf-ensure? not ] filter ;
\r
97 : syntax ( string -- parser )
\r
98 #! Parses the string, ignoring white space, and
\r
99 #! does not put the result in the AST.
\r
102 : syntax-pack ( begin parser end -- parser )
\r
103 #! Parse 'parser' surrounded by syntax elements
\r
105 [ syntax ] 2dip syntax pack ;
\r
107 #! Don't want to use 'replace' in an action since replace doesn't infer.
\r
108 #! Do the compilation of the peg at parse time and call (replace).
\r
109 PEG: escaper ( string -- ast )
\r
111 "\\t" token [ drop "\t" ] action ,
\r
112 "\\n" token [ drop "\n" ] action ,
\r
113 "\\r" token [ drop "\r" ] action ,
\r
114 "\\\\" token [ drop "\\" ] action ,
\r
115 ] choice* any-char-parser 2array choice repeat0 ;
\r
117 : replace-escapes ( string -- string )
\r
118 escaper sift [ [ tree-write ] each ] with-string-writer ;
\r
120 : insert-escapes ( string -- string )
\r
122 "\t" token [ drop "\\t" ] action ,
\r
123 "\n" token [ drop "\\n" ] action ,
\r
124 "\r" token [ drop "\\r" ] action ,
\r
125 ] choice* replace ;
\r
127 : 'identifier' ( -- parser )
\r
128 #! Return a parser that parses an identifer delimited by
\r
129 #! a quotation character. The quotation can be single
\r
130 #! or double quotes. The AST produced is the identifier
\r
131 #! between the quotes.
\r
133 [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
\r
134 [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
\r
135 ] choice* [ >string replace-escapes ] action ;
\r
137 : 'non-terminal' ( -- parser )
\r
138 #! A non-terminal is the name of another rule. It can
\r
139 #! be any non-blank character except for characters used
\r
140 #! in the EBNF syntax itself.
\r
165 ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
\r
167 : 'terminal' ( -- parser )
\r
168 #! A terminal is an identifier enclosed in quotations
\r
169 #! and it represents the literal value of the identifier.
\r
170 'identifier' [ <ebnf-terminal> ] action ;
\r
172 : 'foreign-name' ( -- parser )
\r
173 #! Parse a valid foreign parser name
\r
179 ] satisfy repeat1 [ >string ] action ;
\r
181 : 'foreign' ( -- parser )
\r
182 #! A foreign call is a call to a rule in another ebnf grammar
\r
184 "<foreign" syntax ,
\r
185 'foreign-name' sp ,
\r
186 'foreign-name' sp optional ,
\r
188 ] seq* [ first2 <ebnf-foreign> ] action ;
\r
190 : 'any-character' ( -- parser )
\r
191 #! A parser to match the symbol for any character match.
\r
192 [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
\r
194 : 'range-parser' ( -- parser )
\r
195 #! Match the syntax for declaring character ranges
\r
197 [ "[" syntax , "[" token ensure-not , ] seq* hide ,
\r
198 [ CHAR: ] = not ] satisfy repeat1 ,
\r
200 ] seq* [ first >string <ebnf-range> ] action ;
\r
202 : ('element') ( -- parser )
\r
203 #! An element of a rule. It can be a terminal or a
\r
204 #! non-terminal but must not be followed by a "=".
\r
205 #! The latter indicates that it is the beginning of a
\r
216 [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,
\r
217 [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,
\r
218 [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,
\r
222 "=" syntax ensure-not ,
\r
223 "=>" syntax ensure ,
\r
225 ] seq* [ first ] action ;
\r
229 : 'element' ( -- parser )
\r
231 [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
\r
237 : grouped ( quot suffix -- parser )
\r
238 #! Parse a group of choices, with a suffix indicating
\r
239 #! the type of group (repeat0, repeat1, etc) and
\r
240 #! an quot that is the action that produces the AST.
\r
243 "(" [ 'choice' sp ] delay ")" syntax-pack
\r
245 [ first ] rot compose action ,
\r
246 "{" [ 'choice' sp ] delay "}" syntax-pack
\r
248 [ first <ebnf-whitespace> ] rot compose action ,
\r
251 : 'group' ( -- parser )
\r
252 #! A grouping with no suffix. Used for precedence.
\r
254 "*" token sp ensure-not ,
\r
255 "+" token sp ensure-not ,
\r
256 "?" token sp ensure-not ,
\r
257 ] seq* hide grouped ;
\r
259 : 'repeat0' ( -- parser )
\r
260 [ <ebnf-repeat0> ] "*" syntax grouped ;
\r
262 : 'repeat1' ( -- parser )
\r
263 [ <ebnf-repeat1> ] "+" syntax grouped ;
\r
265 : 'optional' ( -- parser )
\r
266 [ <ebnf-optional> ] "?" syntax grouped ;
\r
268 : 'factor-code' ( -- parser )
\r
270 "]]" token ensure-not ,
\r
271 "]?" token ensure-not ,
\r
272 [ drop t ] satisfy ,
\r
273 ] seq* repeat0 [ concat >string ] action ;
\r
275 : 'ensure-not' ( -- parser )
\r
276 #! Parses the '!' syntax to ensure that
\r
277 #! something that matches the following elements do
\r
278 #! not exist in the parse stream.
\r
282 ] seq* [ first <ebnf-ensure-not> ] action ;
\r
284 : 'ensure' ( -- parser )
\r
285 #! Parses the '&' syntax to ensure that
\r
286 #! something that matches the following elements does
\r
287 #! exist in the parse stream.
\r
291 ] seq* [ first <ebnf-ensure> ] action ;
\r
293 : ('sequence') ( -- parser )
\r
294 #! A sequence of terminals and non-terminals, including
\r
295 #! groupings of those.
\r
306 [ dup , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
\r
310 : 'action' ( -- parser )
\r
311 "[[" 'factor-code' "]]" syntax-pack ;
\r
313 : 'semantic' ( -- parser )
\r
314 "?[" 'factor-code' "]?" syntax-pack ;
\r
316 : 'sequence' ( -- parser )
\r
317 #! A sequence of terminals and non-terminals, including
\r
318 #! groupings of those.
\r
320 [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
\r
321 [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
\r
323 ] choice* repeat1 [
\r
324 dup length 1 = [ first ] [ <ebnf-sequence> ] if
\r
327 : 'actioned-sequence' ( -- parser )
\r
329 [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
\r
333 : 'choice' ( -- parser )
\r
334 'actioned-sequence' sp repeat1 [ dup length 1 = [ first ] [ <ebnf-sequence> ] if ] action "|" token sp list-of [
\r
335 dup length 1 = [ first ] [ <ebnf-choice> ] if
\r
338 : 'tokenizer' ( -- parser )
\r
340 "tokenizer" syntax ,
\r
342 ">" token ensure-not ,
\r
343 [ "default" token sp , 'choice' , ] choice* ,
\r
344 ] seq* [ first <ebnf-tokenizer> ] action ;
\r
346 : 'rule' ( -- parser )
\r
348 "tokenizer" token ensure-not ,
\r
349 'non-terminal' [ symbol>> ] action ,
\r
351 ">" token ensure-not ,
\r
353 ] seq* [ first2 <ebnf-rule> ] action ;
\r
355 : 'ebnf' ( -- parser )
\r
356 [ 'tokenizer' sp , 'rule' sp , ] choice* repeat1 [ <ebnf> ] action ;
\r
358 GENERIC: (transform) ( ast -- parser )
\r
364 : transform ( ast -- object )
\r
365 H{ } clone dup dup [
\r
372 M: ebnf (transform) ( ast -- parser )
\r
373 rules>> [ (transform) ] map peek ;
\r
375 M: ebnf-tokenizer (transform) ( ast -- parser )
\r
376 elements>> dup "default" = [
\r
377 drop default-tokenizer \ tokenizer set-global any-char
\r
380 dup parser-tokenizer \ tokenizer set-global
\r
383 ERROR: redefined-rule name ;
\r
385 M: redefined-rule summary
\r
386 name>> "Rule '" "' defined more than once" surround ;
\r
388 M: ebnf-rule (transform) ( ast -- parser )
\r
391 swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
\r
394 M: ebnf-sequence (transform) ( ast -- parser )
\r
395 #! If ignore-ws is set then each element of the sequence
\r
396 #! ignores leading whitespace. This is not inherited by
\r
397 #! subelements of the sequence.
\r
399 f ignore-ws [ (transform) ] with-variable
\r
400 ignore-ws get [ sp ] when
\r
401 ] map seq [ dup length 1 = [ first ] when ] action ;
\r
403 M: ebnf-choice (transform) ( ast -- parser )
\r
404 options>> [ (transform) ] map choice ;
\r
406 M: ebnf-any-character (transform) ( ast -- parser )
\r
407 drop tokenizer any>> call( -- parser ) ;
\r
409 M: ebnf-range (transform) ( ast -- parser )
\r
410 pattern>> range-pattern ;
\r
412 : transform-group ( ast -- parser )
\r
413 #! convert a ast node with groups to a parser for that group
\r
414 group>> (transform) ;
\r
416 M: ebnf-ensure (transform) ( ast -- parser )
\r
417 transform-group ensure ;
\r
419 M: ebnf-ensure-not (transform) ( ast -- parser )
\r
420 transform-group ensure-not ;
\r
422 M: ebnf-repeat0 (transform) ( ast -- parser )
\r
423 transform-group repeat0 ;
\r
425 M: ebnf-repeat1 (transform) ( ast -- parser )
\r
426 transform-group repeat1 ;
\r
428 M: ebnf-optional (transform) ( ast -- parser )
\r
429 transform-group optional ;
\r
431 M: ebnf-whitespace (transform) ( ast -- parser )
\r
432 t ignore-ws [ transform-group ] with-variable ;
\r
434 GENERIC: build-locals ( code ast -- code )
\r
436 M: ebnf-sequence build-locals ( code ast -- code )
\r
437 #! Note the need to filter out this ebnf items that
\r
438 #! leave nothing in the AST
\r
439 elements>> filter-hidden dup length 1 = [
\r
440 first build-locals
\r
442 dup [ ebnf-var? ] filter empty? [
\r
446 "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %
\r
450 " [ " % # " over nth ] " %
\r
462 M: ebnf-var build-locals ( code ast -- )
\r
464 "USING: locals kernel ; [let* | " %
\r
465 name>> % " [ dup ] " %
\r
471 M: object build-locals ( code ast -- )
\r
474 ERROR: bad-effect quot effect ;
\r
476 : check-action-effect ( quot -- quot )
\r
478 { [ dup (( a -- b )) effect<= ] [ drop ] }
\r
479 { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
\r
483 : ebnf-transform ( ast -- parser quot )
\r
484 [ parser>> (transform) ]
\r
485 [ code>> insert-escapes ]
\r
486 [ parser>> ] tri build-locals
\r
487 [ string-lines parse-lines ] call( string -- quot ) ;
\r
489 M: ebnf-action (transform) ( ast -- parser )
\r
490 ebnf-transform check-action-effect action ;
\r
492 M: ebnf-semantic (transform) ( ast -- parser )
\r
493 ebnf-transform semantic ;
\r
495 M: ebnf-var (transform) ( ast -- parser )
\r
496 parser>> (transform) ;
\r
498 M: ebnf-terminal (transform) ( ast -- parser )
\r
499 symbol>> tokenizer one>> call( symbol -- parser ) ;
\r
501 ERROR: ebnf-foreign-not-found name ;
\r
503 M: ebnf-foreign-not-found summary
\r
504 name>> "Foreign word '" "' not found" surround ;
\r
506 M: ebnf-foreign (transform) ( ast -- parser )
\r
507 dup word>> search [ word>> ebnf-foreign-not-found ] unless*
\r
508 swap rule>> [ main ] unless* over rule [
\r
511 execute( -- parser )
\r
514 ERROR: parser-not-found name ;
\r
516 M: ebnf-non-terminal (transform) ( ast -- parser )
\r
518 , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip ,
\r
521 : transform-ebnf ( string -- object )
\r
522 'ebnf' parse transform ;
\r
524 : check-parse-result ( result -- result )
\r
526 dup remaining>> [ blank? ] trim [
\r
528 "Unable to fully parse EBNF. Left to parse was: " %
\r
533 "Could not parse EBNF" throw
\r
536 : parse-ebnf ( string -- hashtable )
\r
537 'ebnf' (parse) check-parse-result ast>> transform ;
\r
539 : ebnf>quot ( string -- hashtable quot )
\r
540 parse-ebnf dup dup parser [ main swap at compile ] with-variable
\r
541 [ compiled-parse ] curry [ with-scope ast>> ] curry ;
\r
545 reset-tokenizer parse-multiline-string parse-ebnf main swap at
\r
546 parsed reset-tokenizer ;
\r
550 reset-tokenizer parse-multiline-string ebnf>quot nip
\r
551 parsed \ call parsed reset-tokenizer ;
\r
554 reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
\r
556 (( input -- ast )) define-declared "ebnf-parser" set-word-prop
\r