1 ! Copyright (C) 2007, 2008 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
4 vectors arrays math.parser math.order vectors combinators
5 classes sets unicode.categories compiler.units parser
6 words quotations effects memoize accessors locals effects splitting
7 combinators.short-circuit combinators.short-circuit.smart
13 TUPLE: parse-result remaining ast ;
14 TUPLE: parse-error position messages ;
15 TUPLE: parser peg compiled id ;
17 M: parser equal? { [ [ class ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
18 M: parser hashcode* id>> hashcode* ;
20 C: <parse-result> parse-result
21 C: <parse-error> parse-error
24 "Peg parsing error at character position " write dup position>> number>string write
25 "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ;
29 : (merge-errors) ( a b -- c )
31 { [ over position>> not ] [ nip ] }
32 { [ dup position>> not ] [ drop ] }
33 [ 2dup [ position>> ] bi@ <=> {
36 { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
42 error-stack get dup length 1 > [
43 dup pop over pop swap (merge-errors) swap push
48 : add-error ( remaining message -- )
49 <parse-error> error-stack get push ;
53 : packrat ( id -- cache )
54 #! The packrat cache is a mapping of parser-id->cache.
55 #! For each parser it maps to a cache holding a mapping
56 #! of position->result. The packrat cache therefore keeps
57 #! track of all parses that have occurred at each position
58 #! of the input string and the results obtained from that
60 \ packrat get [ drop H{ } clone ] cache ;
68 #! A mapping from position->peg-head. It maps a
69 #! position in the input string being parsed to
70 #! the head of the left recursion which is currently
71 #! being grown. It is 'f' at any position where
72 #! left recursion growth is not underway.
75 : failed? ( obj -- ? )
78 : peg-cache ( -- cache )
79 #! Holds a hashtable mapping a peg tuple to
80 #! the parser tuple for that peg. The parser tuple
81 #! holds a unique id and the compiled form of that peg.
82 \ peg-cache get-global [
83 H{ } clone dup \ peg-cache set-global
87 H{ } clone \ peg-cache set-global ;
91 #! An entry in the table of memoized parse results
92 #! ast = an AST produced from the parse
93 #! or the symbol 'fail'
94 #! or a left-recursion object
95 #! pos = the position in the input string of this entry
96 TUPLE: memo-entry ans pos ;
98 TUPLE: left-recursion seed rule-id head next ;
99 TUPLE: peg-head rule-id involved-set eval-set ;
101 : rule-id ( word -- id )
102 #! A rule is the parser compiled down to a word. It has
103 #! a "peg-id" property containing the id of the original parser.
106 : input-slice ( -- slice )
107 #! Return a slice of the input from the current parse position
108 input get pos get tail-slice ;
110 : input-from ( input -- n )
111 #! Return the index from the original string that the
112 #! input slice is based on.
113 dup slice? [ from>> ] [ drop 0 ] if ;
115 : process-rule-result ( p result -- result )
117 nip [ ast>> ] [ remaining>> ] bi input-from pos set
122 : eval-rule ( rule -- ast )
123 #! Evaluate a rule, return an ast resulting from it.
124 #! Return fail if the rule failed. The rule has
125 #! stack effect ( -- parse-result )
126 pos get swap execute process-rule-result ; inline
128 : memo ( pos id -- memo-entry )
129 #! Return the result from the memo cache.
131 ! " memo result " write dup .
134 : set-memo ( memo-entry pos id -- )
135 #! Store an entry in the cache
138 : update-m ( ast m -- )
139 swap >>ans pos get >>pos drop ;
141 : stop-growth? ( ast m -- ? )
142 [ failed? pos get ] dip
145 : setup-growth ( h p -- )
146 pos set dup involved-set>> clone >>eval-set drop ;
148 : (grow-lr) ( h p r: ( -- result ) m -- )
149 >r >r [ setup-growth ] 2keep r> r>
150 >r dup eval-rule r> swap
151 dup pick stop-growth? [
156 ] if ; inline recursive
158 : grow-lr ( h p r m -- ast )
159 >r >r [ heads set-at ] 2keep r> r>
160 pick over >r >r (grow-lr) r> r>
162 dup pos>> pos set ans>>
165 :: (setup-lr) ( r l s -- )
166 s head>> l head>> eq? [
168 l head>> [ s rule-id>> suffix ] change-involved-set drop
169 r l s next>> (setup-lr)
172 :: setup-lr ( r l -- )
174 r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
176 r l lrstack get (setup-lr) ;
178 :: lr-answer ( r p m -- ast )
182 h rule-id>> r rule-id eq? [
183 m ans>> seed>> m (>>ans)
194 :: recall ( r p -- memo-entry )
196 m [ p r rule-id memo ]
200 m r rule-id h involved-set>> h rule-id>> suffix member? not and [
201 fail p memo-entry boa
203 r rule-id h eval-set>> member? [
204 h [ r rule-id swap remove ] change-eval-set drop
217 :: apply-non-memo-rule ( r p -- ast )
219 lr [ fail r rule-id f lrstack get left-recursion boa ]
220 m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
223 lrstack get next>> lrstack set
234 : apply-memo-rule ( r m -- ast )
235 [ ans>> ] [ pos>> ] bi pos set
236 dup left-recursion? [
237 [ setup-lr ] keep seed>>
244 : apply-rule ( r p -- ast )
245 ! 2dup [ rule-id ] dip 2array "apply-rule: " write .
250 ! " not memoed" print
254 : with-packrat ( input quot -- result )
255 #! Run the quotation with a packrat cache active.
260 V{ } clone error-stack set
261 H{ } clone \ heads set
262 H{ } clone \ packrat set
263 ] H{ } make-assoc swap bind ; inline
266 GENERIC: (compile) ( peg -- quot )
268 : process-parser-result ( result -- result )
272 input-slice swap <parse-result>
275 : execute-parser ( word -- result )
276 pos get apply-rule process-parser-result ; inline
278 : parser-body ( parser -- quot )
279 #! Return the body of the word that is the compiled version
281 gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
282 [ execute-parser ] curry ;
284 : preset-parser-word ( parser -- parser word )
285 gensym [ >>compiled ] keep ;
287 : define-parser-word ( parser word -- )
288 swap parser-body (( -- result )) define-declared ;
290 : compile-parser ( parser -- word )
291 #! Look to see if the given parser has been compiled.
292 #! If not, compile it to a temporary word, cache it,
293 #! and return it. Otherwise return the existing one.
294 #! Circular parsers are supported by getting the word
295 #! name and storing it in the cache, before compiling,
296 #! so it is picked up when re-entered.
300 preset-parser-word [ define-parser-word ] keep
305 : fixup-delayed ( -- )
306 #! Work through all delayed parsers and recompile their
307 #! words to have the correct bodies.
309 call compile-parser 1quotation 0 1 <effect> define-declared
312 : compile ( parser -- word )
315 compile-parser fixup-delayed
317 ] with-compilation-unit ;
319 : compiled-parse ( state word -- result )
320 swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline
322 : (parse) ( input parser -- result )
323 dup word? [ compile ] unless compiled-parse ;
325 : parse ( input parser -- ast )
333 #! Return the next unique id for a parser
340 : wrap-peg ( peg -- parser )
341 #! Wrap a parser tuple around the peg object.
342 #! Look for an existing parser tuple for that
348 TUPLE: token-parser symbol ;
350 : parse-token ( input string -- result )
351 #! Parse the string, returning a parse result
352 [ ?head-slice ] keep swap [
353 <parse-result> f f add-error
355 >r drop pos get "token '" r> append "'" append 1vector add-error f
358 M: token-parser (compile) ( peg -- quot )
359 symbol>> '[ input-slice , parse-token ] ;
361 TUPLE: satisfy-parser quot ;
363 : parse-satisfy ( input quot -- result )
367 unclip-slice rot dupd call [
375 M: satisfy-parser (compile) ( peg -- quot )
376 quot>> '[ input-slice , parse-satisfy ] ;
378 TUPLE: range-parser min max ;
380 : parse-range ( input min max -- result )
384 pick first -rot between? [
385 unclip-slice <parse-result>
391 M: range-parser (compile) ( peg -- quot )
392 [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
394 TUPLE: seq-parser parsers ;
396 : ignore? ( ast -- bool )
399 : calc-seq-result ( prev-result current-result -- next-result )
401 [ remaining>> swap (>>remaining) ] 2keep
405 swap [ ast>> push ] keep
411 : parse-seq-element ( result quot -- result )
418 M: seq-parser (compile) ( peg -- quot )
420 [ input-slice V{ } clone <parse-result> ] %
422 parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
423 [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
427 TUPLE: choice-parser parsers ;
429 M: choice-parser (compile) ( peg -- quot )
432 parsers>> [ compile-parser ] map
433 unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
437 TUPLE: repeat0-parser p1 ;
439 : (repeat) ( quot: ( -- result ) result -- result )
441 [ remaining>> swap (>>remaining) ] 2keep
442 ast>> swap [ ast>> push ] keep
446 ] if* ; inline recursive
448 M: repeat0-parser (compile) ( peg -- quot )
449 p1>> compile-parser 1quotation '[
450 input-slice V{ } clone <parse-result> , swap (repeat)
453 TUPLE: repeat1-parser p1 ;
455 : repeat1-empty-check ( result -- result )
457 dup ast>> empty? [ drop f ] when
462 M: repeat1-parser (compile) ( peg -- quot )
463 p1>> compile-parser 1quotation '[
464 input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
467 TUPLE: optional-parser p1 ;
469 : check-optional ( result -- result )
470 [ input-slice f <parse-result> ] unless* ;
472 M: optional-parser (compile) ( peg -- quot )
473 p1>> compile-parser 1quotation '[ @ check-optional ] ;
475 TUPLE: semantic-parser p1 quot ;
477 : check-semantic ( result quot -- result )
479 over ast>> swap call [ drop f ] unless
484 M: semantic-parser (compile) ( peg -- quot )
485 [ p1>> compile-parser 1quotation ] [ quot>> ] bi
486 '[ @ , check-semantic ] ;
488 TUPLE: ensure-parser p1 ;
490 : check-ensure ( old-input result -- result )
491 [ ignore <parse-result> ] [ drop f ] if ;
493 M: ensure-parser (compile) ( peg -- quot )
494 p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
496 TUPLE: ensure-not-parser p1 ;
498 : check-ensure-not ( old-input result -- result )
499 [ drop f ] [ ignore <parse-result> ] if ;
501 M: ensure-not-parser (compile) ( peg -- quot )
502 p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
504 TUPLE: action-parser p1 quot ;
506 : check-action ( result quot -- result )
508 over ast>> swap call >>ast
513 M: action-parser (compile) ( peg -- quot )
514 [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
516 : left-trim-slice ( string -- string )
517 #! Return a new string without any leading whitespace
518 #! from the original string.
520 dup first blank? [ rest-slice left-trim-slice ] when
523 TUPLE: sp-parser p1 ;
525 M: sp-parser (compile) ( peg -- quot )
526 p1>> compile-parser 1quotation '[
527 input-slice left-trim-slice input-from pos set @
530 TUPLE: delay-parser quot ;
532 M: delay-parser (compile) ( peg -- quot )
533 #! For efficiency we memoize the quotation.
534 #! This way it is run only once and the
535 #! parser constructed once at run time.
536 quot>> gensym [ delayed get set-at ] keep 1quotation ;
538 TUPLE: box-parser quot ;
540 M: box-parser (compile) ( peg -- quot )
541 #! Calls the quotation at compile time
542 #! to produce the parser to be compiled.
543 #! This differs from 'delay' which calls
545 quot>> call compile-parser 1quotation ;
549 : token ( string -- parser )
550 token-parser boa wrap-peg ;
552 : satisfy ( quot -- parser )
553 satisfy-parser boa wrap-peg ;
555 : range ( min max -- parser )
556 range-parser boa wrap-peg ;
558 : seq ( seq -- parser )
559 seq-parser boa wrap-peg ;
561 : 2seq ( parser1 parser2 -- parser )
564 : 3seq ( parser1 parser2 parser3 -- parser )
567 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
570 : seq* ( quot -- paser )
571 { } make seq ; inline
573 : choice ( seq -- parser )
574 choice-parser boa wrap-peg ;
576 : 2choice ( parser1 parser2 -- parser )
579 : 3choice ( parser1 parser2 parser3 -- parser )
582 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
585 : choice* ( quot -- paser )
586 { } make choice ; inline
588 : repeat0 ( parser -- parser )
589 repeat0-parser boa wrap-peg ;
591 : repeat1 ( parser -- parser )
592 repeat1-parser boa wrap-peg ;
594 : optional ( parser -- parser )
595 optional-parser boa wrap-peg ;
597 : semantic ( parser quot -- parser )
598 semantic-parser boa wrap-peg ;
600 : ensure ( parser -- parser )
601 ensure-parser boa wrap-peg ;
603 : ensure-not ( parser -- parser )
604 ensure-not-parser boa wrap-peg ;
606 : action ( parser quot -- parser )
607 action-parser boa wrap-peg ;
609 : sp ( parser -- parser )
610 sp-parser boa wrap-peg ;
612 : hide ( parser -- parser )
613 [ drop ignore ] action ;
615 : delay ( quot -- parser )
616 delay-parser boa wrap-peg ;
618 : box ( quot -- parser )
619 #! because a box has its quotation run at compile time
620 #! it must always have a new parser wrapper created,
621 #! not a cached one. This is because the same box,
622 #! compiled twice can have a different compiled word
623 #! due to running at compile time.
624 #! Why the [ ] action at the end? Box parsers don't get
625 #! memoized during parsing due to all box parsers being
626 #! unique. This breaks left recursion detection during the
627 #! parse. The action adds an indirection with a parser type
628 #! that gets memoized and fixes this. Need to rethink how
629 #! to fix boxes so this isn't needed...
630 box-parser boa f next-id parser boa [ ] action ;
632 ERROR: parse-failed input word ;
634 M: parse-failed error.
635 "The " write dup word>> pprint " word could not parse the following input:" print nl
640 [let | def [ ] word [ ] |
643 [let | compiled-def [ def call compile ] |
645 dup compiled-def compiled-parse
646 [ ast>> ] [ word parse-failed ] ?if
650 ] with-compilation-unit