1 ! Copyright (C) 2007, 2008 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes combinators
4 combinators.short-circuit compiler.units effects.parser fry
5 generalizations kernel locals make math math.order namespaces
6 quotations sequences sets splitting unicode.categories vectors
10 TUPLE: parse-result remaining ast ;
11 TUPLE: parse-error position got messages ;
12 TUPLE: parser peg compiled id ;
14 M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
15 M: parser hashcode* id>> hashcode* ;
17 C: <parse-result> parse-result
18 C: <parse-error> parse-error
22 : merge-overlapping-errors ( a b -- c )
23 dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip
26 : (merge-errors) ( a b -- c )
28 { [ over position>> not ] [ nip ] }
29 { [ dup position>> not ] [ drop ] }
31 2dup [ position>> ] compare {
34 { +eq+ [ merge-overlapping-errors ] }
40 error-stack get dup length 1 > [
41 dup pop over pop swap (merge-errors) swap push
46 : add-error ( position got message -- )
47 <parse-error> error-stack get push ;
51 : packrat ( id -- cache )
52 #! The packrat cache is a mapping of parser-id->cache.
53 #! For each parser it maps to a cache holding a mapping
54 #! of position->result. The packrat cache therefore keeps
55 #! track of all parses that have occurred at each position
56 #! of the input string and the results obtained from that
58 \ packrat get [ drop H{ } clone ] cache ;
66 #! A mapping from position->peg-head. It maps a
67 #! position in the input string being parsed to
68 #! the head of the left recursion which is currently
69 #! being grown. It is 'f' at any position where
70 #! left recursion growth is not underway.
73 : failed? ( obj -- ? )
76 : peg-cache ( -- cache )
77 #! Holds a hashtable mapping a peg tuple to
78 #! the parser tuple for that peg. The parser tuple
79 #! holds a unique id and the compiled form of that peg.
80 \ peg-cache get-global [
81 H{ } clone dup \ peg-cache set-global
85 H{ } clone \ peg-cache set-global ;
89 #! An entry in the table of memoized parse results
90 #! ast = an AST produced from the parse
91 #! or the symbol 'fail'
92 #! or a left-recursion object
93 #! pos = the position in the input string of this entry
94 TUPLE: memo-entry ans pos ;
96 TUPLE: left-recursion seed rule-id head next ;
97 TUPLE: peg-head rule-id involved-set eval-set ;
99 : rule-id ( word -- id )
100 #! A rule is the parser compiled down to a word. It has
101 #! a "peg-id" property containing the id of the original parser.
104 : input-slice ( -- slice )
105 #! Return a slice of the input from the current parse position
106 input get pos get tail-slice ;
108 : input-from ( input -- n )
109 #! Return the index from the original string that the
110 #! input slice is based on.
111 dup slice? [ from>> ] [ drop 0 ] if ;
113 : process-rule-result ( p result -- result )
115 nip [ ast>> ] [ remaining>> ] bi input-from pos set
120 : eval-rule ( rule -- ast )
121 #! Evaluate a rule, return an ast resulting from it.
122 #! Return fail if the rule failed. The rule has
123 #! stack effect ( -- parse-result )
124 pos get swap execute( -- parse-result ) process-rule-result ; inline
126 : memo ( pos id -- memo-entry )
127 #! Return the result from the memo cache.
130 : set-memo ( memo-entry pos id -- )
131 #! Store an entry in the cache
134 : update-m ( ast m -- )
135 swap >>ans pos get >>pos drop ;
137 : stop-growth? ( ast m -- ? )
138 [ failed? pos get ] dip
141 : setup-growth ( h p -- )
142 pos set dup involved-set>> clone >>eval-set drop ;
144 : (grow-lr) ( h p r: ( -- result ) m -- )
145 [ [ setup-growth ] 2keep ] 2dip
146 [ dup eval-rule ] dip swap
147 dup pick stop-growth? [
152 ] if ; inline recursive
154 : grow-lr ( h p r m -- ast )
155 [ [ heads set-at ] 2keep ] 2dip
156 pick over [ (grow-lr) ] 2dip
158 dup pos>> pos set ans>>
161 :: (setup-lr) ( l s -- )
163 s left-recursion? [ s throw ] unless
164 s head>> l head>> eq? [
166 l head>> [ s rule-id>> suffix ] change-involved-set drop
167 l s next>> (setup-lr)
171 :: setup-lr ( r l -- )
173 r rule-id V{ } clone V{ } clone peg-head boa l head<<
175 l lrstack get (setup-lr) ;
177 :: lr-answer ( r p m -- ast )
179 h rule-id>> r rule-id eq? [
180 m ans>> seed>> m ans<<
190 :: recall ( r p -- memo-entry )
191 p r rule-id memo :> m
194 m r rule-id h involved-set>> h rule-id>> suffix member? not and [
195 fail p memo-entry boa
197 r rule-id h eval-set>> member? [
198 h [ r rule-id swap remove ] change-eval-set drop
210 :: apply-non-memo-rule ( r p -- ast )
211 fail r rule-id f lrstack get left-recursion boa :> lr
212 lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
214 lrstack get next>> lrstack set
217 m ans>> left-recursion? [
226 : apply-memo-rule ( r m -- ast )
227 [ ans>> ] [ pos>> ] bi pos set
228 dup left-recursion? [
229 [ setup-lr ] keep seed>>
234 : apply-rule ( r p -- ast )
241 : with-packrat ( input quot -- result )
242 #! Run the quotation with a packrat cache active.
247 V{ } clone error-stack ,,
248 H{ } clone \ heads ,,
249 H{ } clone \ packrat ,,
250 ] H{ } make swap with-variables ; inline
252 GENERIC: (compile) ( peg -- quot )
254 : process-parser-result ( result -- result )
258 input-slice swap <parse-result>
261 : execute-parser ( word -- result )
262 pos get apply-rule process-parser-result ;
264 : preset-parser-word ( parser -- parser word )
265 gensym [ >>compiled ] keep ;
267 : define-parser-word ( parser word -- )
268 #! Return the body of the word that is the compiled version
270 2dup swap peg>> (compile) ( -- result ) define-declared
271 swap id>> "peg-id" set-word-prop ;
273 : compile-parser ( parser -- word )
274 #! Look to see if the given parser has been compiled.
275 #! If not, compile it to a temporary word, cache it,
276 #! and return it. Otherwise return the existing one.
277 #! Circular parsers are supported by getting the word
278 #! name and storing it in the cache, before compiling,
279 #! so it is picked up when re-entered.
283 preset-parser-word [ define-parser-word ] keep
286 : compile-parser-quot ( parser -- quot )
287 compile-parser [ execute-parser ] curry ;
291 : fixup-delayed ( -- )
292 #! Work through all delayed parsers and recompile their
293 #! words to have the correct bodies.
295 call( -- parser ) compile-parser-quot ( -- result ) define-declared
298 : compile ( parser -- word )
301 compile-parser-quot ( -- result ) define-temp fixup-delayed
303 ] with-compilation-unit ;
305 : compiled-parse ( state word -- result )
306 swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
308 : (parse) ( input parser -- result )
309 dup word? [ compile ] unless compiled-parse ;
311 : parse ( input parser -- ast )
319 #! Return the next unique id for a parser
321 dup 1 + id set-global
326 : wrap-peg ( peg -- parser )
327 #! Wrap a parser tuple around the peg object.
328 #! Look for an existing parser tuple for that
334 TUPLE: token-parser symbol ;
336 : parse-token ( input string -- result )
337 #! Parse the string, returning a parse result
338 [ ?head-slice ] keep swap [
339 <parse-result> f f f add-error
341 [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
344 M: token-parser (compile) ( peg -- quot )
345 symbol>> '[ input-slice _ parse-token ] ;
347 TUPLE: satisfy-parser quot ;
349 : parse-satisfy ( input quot -- result )
353 unclip-slice rot dupd call [
361 M: satisfy-parser (compile) ( peg -- quot )
362 quot>> '[ input-slice _ parse-satisfy ] ;
364 TUPLE: range-parser min max ;
366 : parse-range ( input min max -- result )
370 [ dup first ] 2dip between? [
371 unclip-slice <parse-result>
377 M: range-parser (compile) ( peg -- quot )
378 [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
380 TUPLE: seq-parser parsers ;
382 : ignore? ( ast -- bool )
385 : calc-seq-result ( prev-result current-result -- next-result )
387 [ remaining>> swap remaining<< ] 2keep
391 swap [ ast>> push ] keep
397 : parse-seq-element ( result quot -- result )
404 M: seq-parser (compile) ( peg -- quot )
406 [ input-slice V{ } clone <parse-result> ] %
408 parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
409 [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
413 TUPLE: choice-parser parsers ;
415 M: choice-parser (compile) ( peg -- quot )
418 parsers>> [ compile-parser-quot ] map
419 unclip , [ [ merge-errors ] compose , ] each
423 TUPLE: repeat0-parser p1 ;
425 : (repeat) ( quot: ( -- result ) result -- result )
427 [ remaining>> swap remaining<< ] 2keep
428 ast>> swap [ ast>> push ] keep
432 ] if* ; inline recursive
434 M: repeat0-parser (compile) ( peg -- quot )
435 p1>> compile-parser-quot '[
436 input-slice V{ } clone <parse-result> _ swap (repeat)
439 TUPLE: repeat1-parser p1 ;
441 : repeat1-empty-check ( result -- result )
443 dup ast>> empty? [ drop f ] when
448 M: repeat1-parser (compile) ( peg -- quot )
449 p1>> compile-parser-quot '[
450 input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
453 TUPLE: optional-parser p1 ;
455 : check-optional ( result -- result )
456 [ input-slice f <parse-result> ] unless* ;
458 M: optional-parser (compile) ( peg -- quot )
459 p1>> compile-parser-quot '[ @ check-optional ] ;
461 TUPLE: semantic-parser p1 quot ;
463 : check-semantic ( result quot -- result )
465 over ast>> swap call [ drop f ] unless
470 M: semantic-parser (compile) ( peg -- quot )
471 [ p1>> compile-parser-quot ] [ quot>> ] bi
472 '[ @ _ check-semantic ] ;
474 TUPLE: ensure-parser p1 ;
476 : check-ensure ( old-input result -- result )
477 [ ignore <parse-result> ] [ drop f ] if ;
479 M: ensure-parser (compile) ( peg -- quot )
480 p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
482 TUPLE: ensure-not-parser p1 ;
484 : check-ensure-not ( old-input result -- result )
485 [ drop f ] [ ignore <parse-result> ] if ;
487 M: ensure-not-parser (compile) ( peg -- quot )
488 p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
490 TUPLE: action-parser p1 quot ;
492 : check-action ( result quot -- result )
494 over ast>> swap call( ast -- ast ) >>ast
499 M: action-parser (compile) ( peg -- quot )
500 [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
502 TUPLE: sp-parser p1 ;
504 M: sp-parser (compile) ( peg -- quot )
505 p1>> compile-parser-quot '[
506 input-slice [ blank? ] trim-head-slice input-from pos set @
509 TUPLE: delay-parser quot ;
511 M: delay-parser (compile) ( peg -- quot )
512 #! For efficiency we memoize the quotation.
513 #! This way it is run only once and the
514 #! parser constructed once at run time.
515 quot>> gensym [ delayed get set-at ] keep 1quotation ;
517 TUPLE: box-parser quot ;
519 M: box-parser (compile) ( peg -- quot )
520 #! Calls the quotation at compile time
521 #! to produce the parser to be compiled.
522 #! This differs from 'delay' which calls
524 quot>> call( -- parser ) compile-parser-quot ;
528 : token ( string -- parser )
529 token-parser boa wrap-peg ;
531 : satisfy ( quot -- parser )
532 satisfy-parser boa wrap-peg ;
534 : range ( min max -- parser )
535 range-parser boa wrap-peg ;
537 : seq ( seq -- parser )
538 seq-parser boa wrap-peg ;
540 : 2seq ( parser1 parser2 -- parser )
543 : 3seq ( parser1 parser2 parser3 -- parser )
546 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
549 : seq* ( quot -- paser )
550 { } make seq ; inline
552 : choice ( seq -- parser )
553 choice-parser boa wrap-peg ;
555 : 2choice ( parser1 parser2 -- parser )
558 : 3choice ( parser1 parser2 parser3 -- parser )
561 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
564 : choice* ( quot -- paser )
565 { } make choice ; inline
567 : repeat0 ( parser -- parser )
568 repeat0-parser boa wrap-peg ;
570 : repeat1 ( parser -- parser )
571 repeat1-parser boa wrap-peg ;
573 : optional ( parser -- parser )
574 optional-parser boa wrap-peg ;
576 : semantic ( parser quot -- parser )
577 semantic-parser boa wrap-peg ;
579 : ensure ( parser -- parser )
580 ensure-parser boa wrap-peg ;
582 : ensure-not ( parser -- parser )
583 ensure-not-parser boa wrap-peg ;
585 : action ( parser quot -- parser )
586 action-parser boa wrap-peg ;
588 : sp ( parser -- parser )
589 sp-parser boa wrap-peg ;
591 : hide ( parser -- parser )
592 [ drop ignore ] action ;
594 : delay ( quot -- parser )
595 delay-parser boa wrap-peg ;
597 : box ( quot -- parser )
598 #! because a box has its quotation run at compile time
599 #! it must always have a new parser wrapper created,
600 #! not a cached one. This is because the same box,
601 #! compiled twice can have a different compiled word
602 #! due to running at compile time.
603 #! Why the [ ] action at the end? Box parsers don't get
604 #! memoized during parsing due to all box parsers being
605 #! unique. This breaks left recursion detection during the
606 #! parse. The action adds an indirection with a parser type
607 #! that gets memoized and fixes this. Need to rethink how
608 #! to fix boxes so this isn't needed...
609 box-parser boa f next-id parser boa [ ] action ;
611 ERROR: parse-failed input word ;
615 (:) :> ( word def effect )
618 def call compile :> compiled-def
620 dup compiled-def compiled-parse
621 [ ast>> ] [ word throw-parse-failed ] ?if
623 word swap effect define-declared
624 ] with-compilation-unit
630 { "debugger" "peg" } "peg.debugger" require-when