1 ! Copyright (C) 2007, 2008 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs classes combinators
5 combinators.short-circuit compiler.units effects.parser fry
6 generalizations kernel locals make math math.order namespaces
7 quotations sequences sets splitting unicode vectors
12 TUPLE: parse-result remaining ast ;
13 TUPLE: parse-error position got messages ;
14 TUPLE: parser peg compiled id ;
16 M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
17 M: parser hashcode* id>> hashcode* ;
19 C: <parse-result> parse-result
20 C: <parse-error> parse-error
24 : merge-overlapping-errors ( a b -- c )
25 dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip
28 : (merge-errors) ( a b -- c )
30 { [ over position>> not ] [ nip ] }
31 { [ dup position>> not ] [ drop ] }
33 2dup [ position>> ] compare {
36 { +eq+ [ merge-overlapping-errors ] }
42 error-stack get dup length 1 > [
43 [ pop ] [ pop swap (merge-errors) ] [ ] tri push
48 : add-error ( position got message -- )
49 <parse-error> error-stack get push ;
53 : ignore? ( obj -- ? )
56 : packrat ( id -- cache )
57 ! The packrat cache is a mapping of parser-id->cache.
58 ! For each parser it maps to a cache holding a mapping
59 ! of position->result. The packrat cache therefore keeps
60 ! track of all parses that have occurred at each position
61 ! of the input string and the results obtained from that
63 \ packrat get [ drop H{ } clone ] cache ;
71 ! A mapping from position->peg-head. It maps a
72 ! position in the input string being parsed to
73 ! the head of the left recursion which is currently
74 ! being grown. It is 'f' at any position where
75 ! left recursion growth is not underway.
78 : failed? ( obj -- ? )
81 : peg-cache ( -- cache )
82 ! Holds a hashtable mapping a peg tuple to
83 ! the parser tuple for that peg. The parser tuple
84 ! holds a unique id and the compiled form of that peg.
85 \ peg-cache get-global [
86 H{ } clone dup \ peg-cache set-global
90 H{ } clone \ peg-cache set-global ;
94 ! An entry in the table of memoized parse results
95 ! ast = an AST produced from the parse
96 ! or the symbol 'fail'
97 ! or a left-recursion object
98 ! pos = the position in the input string of this entry
99 TUPLE: memo-entry ans pos ;
101 TUPLE: left-recursion seed rule-id head next ;
102 TUPLE: peg-head rule-id involved-set eval-set ;
104 : rule-id ( word -- id )
105 ! A rule is the parser compiled down to a word. It has
106 ! a "peg-id" property containing the id of the original parser.
109 : input-slice ( -- slice )
110 ! Return a slice of the input from the current parse position
111 input get pos get tail-slice ;
113 : input-from ( input -- n )
114 ! Return the index from the original string that the
115 ! input slice is based on.
116 dup slice? [ from>> ] [ drop 0 ] if ;
118 : process-rule-result ( p result -- result )
120 nip [ ast>> ] [ remaining>> ] bi input-from pos namespaces:set
122 pos namespaces:set fail
125 : eval-rule ( rule -- ast )
126 ! Evaluate a rule, return an ast resulting from it.
127 ! Return fail if the rule failed. The rule has
128 ! stack effect ( -- parse-result )
129 pos get swap execute( -- parse-result ) process-rule-result ; inline
131 : memo ( pos id -- memo-entry )
132 ! Return the result from the memo cache.
135 : set-memo ( memo-entry pos id -- )
136 ! Store an entry in the cache
139 : update-m ( ast m -- )
140 swap >>ans pos get >>pos drop ;
142 : stop-growth? ( ast m -- ? )
143 [ failed? pos get ] dip pos>> <= or ;
145 : setup-growth ( h p -- )
146 pos namespaces:set dup involved-set>> clone >>eval-set drop ;
148 : (grow-lr) ( h p r: ( -- result ) m -- )
149 [ [ setup-growth ] 2keep ] 2dip
150 [ dup eval-rule ] dip swap
151 dup pick stop-growth? [
156 ] if ; inline recursive
158 : grow-lr ( h p r m -- ast )
159 [ [ heads set-at ] 2keep ] 2dip
160 pick over [ (grow-lr) ] 2dip
162 dup pos>> pos namespaces:set ans>>
165 :: (setup-lr) ( l s -- )
167 s left-recursion? [ s throw ] unless
168 s head>> l head>> eq? [
170 l head>> [ s rule-id>> suffix ] change-involved-set drop
171 l s next>> (setup-lr)
175 :: setup-lr ( r l -- )
177 r rule-id V{ } clone V{ } clone peg-head boa l head<<
179 l lrstack get (setup-lr) ;
181 :: lr-answer ( r p m -- ast )
183 h rule-id>> r rule-id eq? [
184 m ans>> seed>> m ans<<
194 :: recall ( r p -- memo-entry )
195 p r rule-id memo :> m
198 m r rule-id h involved-set>> h rule-id>> suffix member? not and [
199 fail p memo-entry boa
201 r rule-id h eval-set>> member? [
202 h [ r rule-id swap remove ] change-eval-set drop
214 :: apply-non-memo-rule ( r p -- ast )
215 fail r rule-id f lrstack get left-recursion boa :> lr
216 lr lrstack namespaces:set lr p memo-entry boa dup p r rule-id set-memo :> m
218 lrstack get next>> lrstack namespaces:set
221 m ans>> left-recursion? [
230 : apply-memo-rule ( r m -- ast )
231 [ ans>> ] [ pos>> ] bi pos namespaces:set
232 dup left-recursion? [
233 [ setup-lr ] keep seed>>
238 : apply-rule ( r p -- ast )
245 : with-packrat ( input quot -- result )
246 ! Run the quotation with a packrat cache active.
251 V{ } clone error-stack ,,
252 H{ } clone \ heads ,,
253 H{ } clone \ packrat ,,
254 ] H{ } make swap with-variables ; inline
256 GENERIC: (compile) ( peg -- quot )
258 : process-parser-result ( result -- result )
262 input-slice swap <parse-result>
265 : execute-parser ( word -- result )
266 pos get apply-rule process-parser-result ;
268 : preset-parser-word ( parser -- parser word )
269 gensym [ >>compiled ] keep ;
271 : define-parser-word ( parser word -- )
272 ! Return the body of the word that is the compiled version
275 2dup swap peg>> (compile) ( -- result ) define-declared
276 swap id>> "peg-id" set-word-prop ;
278 : compile-parser ( parser -- word )
279 ! Look to see if the given parser has been compiled.
280 ! If not, compile it to a temporary word, cache it,
281 ! and return it. Otherwise return the existing one.
282 ! Circular parsers are supported by getting the word
283 ! name and storing it in the cache, before compiling,
284 ! so it is picked up when re-entered.
288 preset-parser-word [ define-parser-word ] keep
291 : compile-parser-quot ( parser -- quot )
292 compile-parser '[ _ execute-parser ] ;
294 : compile-parsers-quots ( parsers -- quots )
295 [ compile-parser-quot ] map dup rest-slice
296 [ '[ @ merge-errors ] ] map! drop ;
300 : fixup-delayed ( -- )
301 ! Work through all delayed parsers and recompile their
302 ! words to have the correct bodies.
304 call( -- parser ) compile-parser-quot ( -- result ) define-declared
307 : compile ( parser -- word )
310 compile-parser-quot ( -- result ) define-temp fixup-delayed
312 ] with-compilation-unit ;
314 : compiled-parse ( state word -- result )
317 [ error-stack get ?first [ throw ]
318 [ pos get input get f <parse-error> throw ] if* ] unless*
321 : (parse) ( input parser -- result )
322 dup word? [ compile ] unless compiled-parse ;
324 : parse ( input parser -- ast )
330 ! Return the next unique id for a parser
333 : wrap-peg ( peg -- parser )
334 ! Wrap a parser tuple around the peg object.
335 ! Look for an existing parser tuple for that
337 peg-cache [ f next-id parser boa ] cache ;
339 TUPLE: token-parser symbol ;
341 : parse-token ( input string -- result )
342 ! Parse the string, returning a parse result
343 [ ?head-slice ] keep swap [
346 [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
349 M: token-parser (compile) ( peg -- quot )
350 symbol>> '[ input-slice _ parse-token ] ;
352 TUPLE: satisfy-parser quot ;
354 :: parse-satisfy ( input quot -- result/f )
356 unclip-slice dup quot call [
363 M: satisfy-parser (compile)
364 quot>> '[ input-slice _ parse-satisfy ] ;
366 TUPLE: range-parser min max ;
368 :: parse-range ( input min max -- result/f )
370 dup first min max between? [
371 unclip-slice <parse-result>
377 M: range-parser (compile)
378 [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
380 TUPLE: seq-parser parsers ;
382 : calc-seq-result ( prev-result current-result -- next-result )
384 [ remaining>> >>remaining ] [ ast>> ] bi
385 dup ignore? [ drop ] [ over ast>> push ] if
390 : parse-seq-element ( result quot -- result )
391 '[ @ calc-seq-result ] [ f ] if* ; inline
393 M: seq-parser (compile)
394 parsers>> compile-parsers-quots
395 [ '[ _ parse-seq-element ] ] map
396 '[ input-slice V{ } clone <parse-result> _ 1&& ] ;
398 TUPLE: choice-parser parsers ;
400 M: choice-parser (compile)
401 parsers>> compile-parsers-quots '[ _ 0|| ] ;
403 TUPLE: repeat0-parser parser ;
405 : (repeat) ( quot: ( -- result ) result -- result )
407 [ remaining>> >>remaining ] [ ast>> ] bi
408 over ast>> push (repeat)
411 ] if* ; inline recursive
413 M: repeat0-parser (compile)
414 parser>> compile-parser-quot '[
415 input-slice V{ } clone <parse-result> _ swap (repeat)
418 TUPLE: repeat1-parser parser ;
420 : repeat1-empty-check ( result -- result )
421 [ dup ast>> empty? [ drop f ] when ] [ f ] if* ;
423 M: repeat1-parser (compile)
424 parser>> compile-parser-quot '[
425 input-slice V{ } clone <parse-result> _ swap (repeat)
429 TUPLE: optional-parser parser ;
431 : check-optional ( result -- result )
432 [ input-slice f <parse-result> ] unless* ;
434 M: optional-parser (compile)
435 parser>> compile-parser-quot '[ @ check-optional ] ;
437 TUPLE: semantic-parser parser quot ;
439 : check-semantic ( result quot -- result )
440 dupd '[ dup ast>> @ [ drop f ] unless ] when ; inline
442 M: semantic-parser (compile)
443 [ parser>> compile-parser-quot ] [ quot>> ] bi
444 '[ @ _ check-semantic ] ;
446 TUPLE: ensure-parser parser ;
448 : check-ensure ( old-input result -- result )
449 [ ignore <parse-result> ] [ drop f ] if ;
451 M: ensure-parser (compile)
452 parser>> compile-parser-quot '[ input-slice @ check-ensure ] ;
454 TUPLE: ensure-not-parser parser ;
456 : check-ensure-not ( old-input result -- result )
457 [ drop f ] [ ignore <parse-result> ] if ;
459 M: ensure-not-parser (compile)
460 parser>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
462 TUPLE: action-parser parser quot ;
464 : check-action ( result quot -- result )
465 dupd '[ [ _ call( ast -- ast ) ] change-ast ] when ;
467 M: action-parser (compile)
468 [ parser>> compile-parser-quot ] [ quot>> ] bi
469 '[ @ _ check-action ] ;
471 TUPLE: sp-parser parser ;
473 M: sp-parser (compile)
474 parser>> compile-parser-quot '[
475 input-slice [ blank? ] trim-head-slice input-from pos namespaces:set @
478 TUPLE: delay-parser quot ;
480 M: delay-parser (compile)
481 ! For efficiency we memoize the quotation.
482 ! This way it is run only once and the
483 ! parser constructed once at run time.
484 quot>> gensym [ delayed get set-at ] keep 1quotation ;
486 TUPLE: box-parser quot ;
488 M: box-parser (compile)
489 ! Calls the quotation at compile time
490 ! to produce the parser to be compiled.
491 ! This differs from 'delay' which calls
493 quot>> call( -- parser ) compile-parser-quot ;
497 : token ( string -- parser )
498 token-parser boa wrap-peg ;
500 : satisfy ( quot -- parser )
501 satisfy-parser boa wrap-peg ;
503 : range ( min max -- parser )
504 range-parser boa wrap-peg ;
506 : seq ( seq -- parser )
507 seq-parser boa wrap-peg ;
509 : 2seq ( parser1 parser2 -- parser )
512 : 3seq ( parser1 parser2 parser3 -- parser )
515 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
518 : seq* ( quot -- paser )
519 { } make seq ; inline
521 : choice ( seq -- parser )
522 choice-parser boa wrap-peg ;
524 : 2choice ( parser1 parser2 -- parser )
527 : 3choice ( parser1 parser2 parser3 -- parser )
530 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
533 : choice* ( quot -- paser )
534 { } make choice ; inline
536 : repeat0 ( parser -- parser )
537 repeat0-parser boa wrap-peg ;
539 : repeat1 ( parser -- parser )
540 repeat1-parser boa wrap-peg ;
542 : optional ( parser -- parser )
543 optional-parser boa wrap-peg ;
545 : semantic ( parser quot -- parser )
546 semantic-parser boa wrap-peg ;
548 : ensure ( parser -- parser )
549 ensure-parser boa wrap-peg ;
551 : ensure-not ( parser -- parser )
552 ensure-not-parser boa wrap-peg ;
554 : action ( parser quot -- parser )
555 action-parser boa wrap-peg ;
557 : sp ( parser -- parser )
558 sp-parser boa wrap-peg ;
560 : hide ( parser -- parser )
561 [ drop ignore ] action ;
563 : delay ( quot -- parser )
564 delay-parser boa wrap-peg ;
566 : box ( quot -- parser )
567 ! because a box has its quotation run at compile time
568 ! it must always have a new parser wrapper created,
569 ! not a cached one. This is because the same box,
570 ! compiled twice can have a different compiled word
571 ! due to running at compile time.
572 ! Why the [ ] action at the end? Box parsers don't get
573 ! memoized during parsing due to all box parsers being
574 ! unique. This breaks left recursion detection during the
575 ! parse. The action adds an indirection with a parser type
576 ! that gets memoized and fixes this. Need to rethink how
577 ! to fix boxes so this isn't needed...
578 box-parser boa f next-id parser boa [ ] action ;
580 ERROR: parse-failed input word ;
584 (:) :> ( word def effect )
587 def call compile :> compiled-def
589 dup compiled-def compiled-parse
590 [ ast>> ] [ word parse-failed ] ?if
591 ] effect define-declared
592 ] with-compilation-unit
596 { "debugger" "peg" } "peg.debugger" require-when