1 ! Copyright (C) 2007, 2008 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences strings fry namespaces make math assocs
4 io vectors arrays math.parser math.order combinators classes
5 sets unicode.categories compiler.units parser effects.parser
6 words quotations memoize accessors locals splitting
7 combinators.short-circuit generalizations ;
10 TUPLE: parse-result remaining ast ;
11 TUPLE: parse-error position messages ;
12 TUPLE: parser peg compiled id ;
14 M: parser equal? { [ [ class ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
15 M: parser hashcode* id>> hashcode* ;
17 C: <parse-result> parse-result
18 C: <parse-error> parse-error
22 : (merge-errors) ( a b -- c )
24 { [ over position>> not ] [ nip ] }
25 { [ dup position>> not ] [ drop ] }
26 [ 2dup [ position>> ] bi@ <=> {
29 { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
35 error-stack get dup length 1 > [
36 dup pop over pop swap (merge-errors) swap push
41 : add-error ( remaining message -- )
42 <parse-error> error-stack get push ;
46 : packrat ( id -- cache )
47 #! The packrat cache is a mapping of parser-id->cache.
48 #! For each parser it maps to a cache holding a mapping
49 #! of position->result. The packrat cache therefore keeps
50 #! track of all parses that have occurred at each position
51 #! of the input string and the results obtained from that
53 \ packrat get [ drop H{ } clone ] cache ;
61 #! A mapping from position->peg-head. It maps a
62 #! position in the input string being parsed to
63 #! the head of the left recursion which is currently
64 #! being grown. It is 'f' at any position where
65 #! left recursion growth is not underway.
68 : failed? ( obj -- ? )
71 : peg-cache ( -- cache )
72 #! Holds a hashtable mapping a peg tuple to
73 #! the parser tuple for that peg. The parser tuple
74 #! holds a unique id and the compiled form of that peg.
75 \ peg-cache get-global [
76 H{ } clone dup \ peg-cache set-global
80 H{ } clone \ peg-cache set-global ;
84 #! An entry in the table of memoized parse results
85 #! ast = an AST produced from the parse
86 #! or the symbol 'fail'
87 #! or a left-recursion object
88 #! pos = the position in the input string of this entry
89 TUPLE: memo-entry ans pos ;
91 TUPLE: left-recursion seed rule-id head next ;
92 TUPLE: peg-head rule-id involved-set eval-set ;
94 : rule-id ( word -- id )
95 #! A rule is the parser compiled down to a word. It has
96 #! a "peg-id" property containing the id of the original parser.
99 : input-slice ( -- slice )
100 #! Return a slice of the input from the current parse position
101 input get pos get tail-slice ;
103 : input-from ( input -- n )
104 #! Return the index from the original string that the
105 #! input slice is based on.
106 dup slice? [ from>> ] [ drop 0 ] if ;
108 : process-rule-result ( p result -- result )
110 nip [ ast>> ] [ remaining>> ] bi input-from pos set
115 : eval-rule ( rule -- ast )
116 #! Evaluate a rule, return an ast resulting from it.
117 #! Return fail if the rule failed. The rule has
118 #! stack effect ( -- parse-result )
119 pos get swap execute( -- parse-result ) process-rule-result ; inline
121 : memo ( pos id -- memo-entry )
122 #! Return the result from the memo cache.
124 ! " memo result " write dup .
127 : set-memo ( memo-entry pos id -- )
128 #! Store an entry in the cache
131 : update-m ( ast m -- )
132 swap >>ans pos get >>pos drop ;
134 : stop-growth? ( ast m -- ? )
135 [ failed? pos get ] dip
138 : setup-growth ( h p -- )
139 pos set dup involved-set>> clone >>eval-set drop ;
141 : (grow-lr) ( h p r: ( -- result ) m -- )
142 [ [ setup-growth ] 2keep ] 2dip
143 [ dup eval-rule ] dip swap
144 dup pick stop-growth? [
149 ] if ; inline recursive
151 : grow-lr ( h p r m -- ast )
152 [ [ heads set-at ] 2keep ] 2dip
153 pick over [ (grow-lr) ] 2dip
155 dup pos>> pos set ans>>
158 :: (setup-lr) ( l s -- )
160 s left-recursion? [ s throw ] unless
161 s head>> l head>> eq? [
163 l head>> [ s rule-id>> suffix ] change-involved-set drop
164 l s next>> (setup-lr)
168 :: setup-lr ( r l -- )
170 r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
172 l lrstack get (setup-lr) ;
174 :: lr-answer ( r p m -- ast )
176 h rule-id>> r rule-id eq? [
177 m ans>> seed>> m (>>ans)
187 :: recall ( r p -- memo-entry )
188 p r rule-id memo :> m
191 m r rule-id h involved-set>> h rule-id>> suffix member? not and [
192 fail p memo-entry boa
194 r rule-id h eval-set>> member? [
195 h [ r rule-id swap remove ] change-eval-set drop
207 :: apply-non-memo-rule ( r p -- ast )
208 fail r rule-id f lrstack get left-recursion boa :> lr
209 lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
211 lrstack get next>> lrstack set
214 m ans>> left-recursion? [
223 : apply-memo-rule ( r m -- ast )
224 [ ans>> ] [ pos>> ] bi pos set
225 dup left-recursion? [
226 [ setup-lr ] keep seed>>
231 : apply-rule ( r p -- ast )
232 ! 2dup [ rule-id ] dip 2array "apply-rule: " write .
237 ! " not memoed" print
241 : with-packrat ( input quot -- result )
242 #! Run the quotation with a packrat cache active.
247 V{ } clone error-stack set
248 H{ } clone \ heads set
249 H{ } clone \ packrat set
251 ] with-scope ; inline
254 GENERIC: (compile) ( peg -- quot )
256 : process-parser-result ( result -- result )
260 input-slice swap <parse-result>
263 : execute-parser ( word -- result )
264 pos get apply-rule process-parser-result ;
266 : preset-parser-word ( parser -- parser word )
267 gensym [ >>compiled ] keep ;
269 : define-parser-word ( parser word -- )
270 #! Return the body of the word that is the compiled version
272 2dup swap peg>> (compile) (( -- result )) define-declared
273 swap id>> "peg-id" set-word-prop ;
275 : compile-parser ( parser -- word )
276 #! Look to see if the given parser has been compiled.
277 #! If not, compile it to a temporary word, cache it,
278 #! and return it. Otherwise return the existing one.
279 #! Circular parsers are supported by getting the word
280 #! name and storing it in the cache, before compiling,
281 #! so it is picked up when re-entered.
285 preset-parser-word [ define-parser-word ] keep
288 : compile-parser-quot ( parser -- quot )
289 compile-parser [ execute-parser ] curry ;
293 : fixup-delayed ( -- )
294 #! Work through all delayed parsers and recompile their
295 #! words to have the correct bodies.
297 call( -- parser ) compile-parser-quot (( -- result )) define-declared
300 : compile ( parser -- word )
303 compile-parser-quot (( -- result )) define-temp fixup-delayed
305 ] with-compilation-unit ;
307 : compiled-parse ( state word -- result )
308 swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
310 : (parse) ( input parser -- result )
311 dup word? [ compile ] unless compiled-parse ;
313 : parse ( input parser -- ast )
321 #! Return the next unique id for a parser
323 dup 1 + id set-global
328 : wrap-peg ( peg -- parser )
329 #! Wrap a parser tuple around the peg object.
330 #! Look for an existing parser tuple for that
336 TUPLE: token-parser symbol ;
338 : parse-token ( input string -- result )
339 #! Parse the string, returning a parse result
340 [ ?head-slice ] keep swap [
341 <parse-result> f f add-error
343 [ drop pos get "token '" ] dip append "'" append 1vector add-error f
346 M: token-parser (compile) ( peg -- quot )
347 symbol>> '[ input-slice _ parse-token ] ;
349 TUPLE: satisfy-parser quot ;
351 : parse-satisfy ( input quot -- result )
355 unclip-slice rot dupd call [
363 M: satisfy-parser (compile) ( peg -- quot )
364 quot>> '[ input-slice _ parse-satisfy ] ;
366 TUPLE: range-parser min max ;
368 : parse-range ( input min max -- result )
372 [ dup first ] 2dip between? [
373 unclip-slice <parse-result>
379 M: range-parser (compile) ( peg -- quot )
380 [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
382 TUPLE: seq-parser parsers ;
384 : ignore? ( ast -- bool )
387 : calc-seq-result ( prev-result current-result -- next-result )
389 [ remaining>> swap (>>remaining) ] 2keep
393 swap [ ast>> push ] keep
399 : parse-seq-element ( result quot -- result )
406 M: seq-parser (compile) ( peg -- quot )
408 [ input-slice V{ } clone <parse-result> ] %
410 parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
411 [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
415 TUPLE: choice-parser parsers ;
417 M: choice-parser (compile) ( peg -- quot )
420 parsers>> [ compile-parser-quot ] map
421 unclip , [ [ merge-errors ] compose , ] each
425 TUPLE: repeat0-parser p1 ;
427 : (repeat) ( quot: ( -- result ) result -- result )
429 [ remaining>> swap (>>remaining) ] 2keep
430 ast>> swap [ ast>> push ] keep
434 ] if* ; inline recursive
436 M: repeat0-parser (compile) ( peg -- quot )
437 p1>> compile-parser-quot '[
438 input-slice V{ } clone <parse-result> _ swap (repeat)
441 TUPLE: repeat1-parser p1 ;
443 : repeat1-empty-check ( result -- result )
445 dup ast>> empty? [ drop f ] when
450 M: repeat1-parser (compile) ( peg -- quot )
451 p1>> compile-parser-quot '[
452 input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
455 TUPLE: optional-parser p1 ;
457 : check-optional ( result -- result )
458 [ input-slice f <parse-result> ] unless* ;
460 M: optional-parser (compile) ( peg -- quot )
461 p1>> compile-parser-quot '[ @ check-optional ] ;
463 TUPLE: semantic-parser p1 quot ;
465 : check-semantic ( result quot -- result )
467 over ast>> swap call [ drop f ] unless
472 M: semantic-parser (compile) ( peg -- quot )
473 [ p1>> compile-parser-quot ] [ quot>> ] bi
474 '[ @ _ check-semantic ] ;
476 TUPLE: ensure-parser p1 ;
478 : check-ensure ( old-input result -- result )
479 [ ignore <parse-result> ] [ drop f ] if ;
481 M: ensure-parser (compile) ( peg -- quot )
482 p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
484 TUPLE: ensure-not-parser p1 ;
486 : check-ensure-not ( old-input result -- result )
487 [ drop f ] [ ignore <parse-result> ] if ;
489 M: ensure-not-parser (compile) ( peg -- quot )
490 p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
492 TUPLE: action-parser p1 quot ;
494 : check-action ( result quot -- result )
496 over ast>> swap call( ast -- ast ) >>ast
501 M: action-parser (compile) ( peg -- quot )
502 [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
504 TUPLE: sp-parser p1 ;
506 M: sp-parser (compile) ( peg -- quot )
507 p1>> compile-parser-quot '[
508 input-slice [ blank? ] trim-head-slice input-from pos set @
511 TUPLE: delay-parser quot ;
513 M: delay-parser (compile) ( peg -- quot )
514 #! For efficiency we memoize the quotation.
515 #! This way it is run only once and the
516 #! parser constructed once at run time.
517 quot>> gensym [ delayed get set-at ] keep 1quotation ;
519 TUPLE: box-parser quot ;
521 M: box-parser (compile) ( peg -- quot )
522 #! Calls the quotation at compile time
523 #! to produce the parser to be compiled.
524 #! This differs from 'delay' which calls
526 quot>> call( -- parser ) compile-parser-quot ;
530 : token ( string -- parser )
531 token-parser boa wrap-peg ;
533 : satisfy ( quot -- parser )
534 satisfy-parser boa wrap-peg ;
536 : range ( min max -- parser )
537 range-parser boa wrap-peg ;
539 : seq ( seq -- parser )
540 seq-parser boa wrap-peg ;
542 : 2seq ( parser1 parser2 -- parser )
545 : 3seq ( parser1 parser2 parser3 -- parser )
548 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
551 : seq* ( quot -- paser )
552 { } make seq ; inline
554 : choice ( seq -- parser )
555 choice-parser boa wrap-peg ;
557 : 2choice ( parser1 parser2 -- parser )
560 : 3choice ( parser1 parser2 parser3 -- parser )
563 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
566 : choice* ( quot -- paser )
567 { } make choice ; inline
569 : repeat0 ( parser -- parser )
570 repeat0-parser boa wrap-peg ;
572 : repeat1 ( parser -- parser )
573 repeat1-parser boa wrap-peg ;
575 : optional ( parser -- parser )
576 optional-parser boa wrap-peg ;
578 : semantic ( parser quot -- parser )
579 semantic-parser boa wrap-peg ;
581 : ensure ( parser -- parser )
582 ensure-parser boa wrap-peg ;
584 : ensure-not ( parser -- parser )
585 ensure-not-parser boa wrap-peg ;
587 : action ( parser quot -- parser )
588 action-parser boa wrap-peg ;
590 : sp ( parser -- parser )
591 sp-parser boa wrap-peg ;
593 : hide ( parser -- parser )
594 [ drop ignore ] action ;
596 : delay ( quot -- parser )
597 delay-parser boa wrap-peg ;
599 : box ( quot -- parser )
600 #! because a box has its quotation run at compile time
601 #! it must always have a new parser wrapper created,
602 #! not a cached one. This is because the same box,
603 #! compiled twice can have a different compiled word
604 #! due to running at compile time.
605 #! Why the [ ] action at the end? Box parsers don't get
606 #! memoized during parsing due to all box parsers being
607 #! unique. This breaks left recursion detection during the
608 #! parse. The action adds an indirection with a parser type
609 #! that gets memoized and fixes this. Need to rethink how
610 #! to fix boxes so this isn't needed...
611 box-parser boa f next-id parser boa [ ] action ;
613 ERROR: parse-failed input word ;
617 (:) :> ( word def effect )
620 def call compile :> compiled-def
622 dup compiled-def compiled-parse
623 [ ast>> ] [ word parse-failed ] ?if
625 word swap effect define-declared
626 ] with-compilation-unit
630 USING: vocabs vocabs.loader ;
633 "peg.debugger" require