basis/peg/peg.factor

   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
   7 words ;
   8 IN: peg
   9
  10 TUPLE: parse-result remaining ast ;
  11 TUPLE: parse-error position got messages ;
  12 TUPLE: parser peg compiled id ;
  13
  14 M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
  15 M: parser hashcode* id>> hashcode* ;
  16
  17 C: <parse-result> parse-result
  18 C: <parse-error>  parse-error
  19
  20 SYMBOL: error-stack
  21
  22 : merge-overlapping-errors ( a b -- c )
  23     dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip
  24     <parse-error> ;
  25
  26 : (merge-errors) ( a b -- c )
  27     {
  28         { [ over position>> not ] [ nip ] }
  29         { [ dup  position>> not ] [ drop ] }
  30         [
  31             2dup [ position>> ] compare {
  32                 { +lt+ [ nip ] }
  33                 { +gt+ [ drop ] }
  34                 { +eq+ [ merge-overlapping-errors ] }
  35             } case
  36         ]
  37     } cond ;
  38
  39 : merge-errors ( -- )
  40     error-stack get dup length 1 >  [
  41         dup pop over pop swap (merge-errors) swap push
  42     ] [
  43         drop
  44     ] if ;
  45
  46 : add-error ( position got message -- )
  47     <parse-error> error-stack get push ;
  48
  49 SYMBOL: ignore
  50
  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
  57     #! parser.
  58     \ packrat get [ drop H{ } clone ] cache ;
  59
  60 SYMBOL: pos
  61 SYMBOL: input
  62 SYMBOL: fail
  63 SYMBOL: lrstack
  64
  65 : heads ( -- 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.
  71     \ heads get ;
  72
  73 : failed? ( obj -- ? )
  74     fail = ;
  75
  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
  82     ] unless* ;
  83
  84 : reset-pegs ( -- )
  85     H{ } clone \ peg-cache set-global ;
  86
  87 reset-pegs
  88
  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 ;
  95
  96 TUPLE: left-recursion seed rule-id head next ;
  97 TUPLE: peg-head rule-id involved-set eval-set ;
  98
  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.
 102     "peg-id" word-prop ;
 103
 104 : input-slice ( -- slice )
 105     #! Return a slice of the input from the current parse position
 106     input get pos get tail-slice ;
 107
 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 ;
 112
 113 : process-rule-result ( p result -- result )
 114     [
 115         nip [ ast>> ] [ remaining>> ] bi input-from pos set
 116     ] [
 117         pos set fail
 118     ] if* ;
 119
 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
 125
 126 : memo ( pos id -- memo-entry )
 127     #! Return the result from the memo cache.
 128     packrat at ;
 129
 130 : set-memo ( memo-entry pos id -- )
 131     #! Store an entry in the cache
 132     packrat set-at ;
 133
 134 : update-m ( ast m -- )
 135     swap >>ans pos get >>pos drop ;
 136
 137 : stop-growth? ( ast m -- ? )
 138     [ failed? pos get ] dip
 139     pos>> <= or ;
 140
 141 : setup-growth ( h p -- )
 142     pos set dup involved-set>> clone >>eval-set drop ;
 143
 144 : (grow-lr) ( h p r: ( -- result ) m -- )
 145     [ [ setup-growth ] 2keep ] 2dip
 146     [ dup eval-rule ] dip swap
 147         dup pick stop-growth? [
 148         5 ndrop
 149     ] [
 150         over update-m
 151         (grow-lr)
 152     ] if ; inline recursive
 153
 154 : grow-lr ( h p r m -- ast )
 155     [ [ heads set-at ] 2keep ] 2dip
 156     pick over [ (grow-lr) ] 2dip
 157     swap heads delete-at
 158     dup pos>> pos set ans>>
 159     ; inline
 160
 161 :: (setup-lr) ( l s -- )
 162     s [
 163         s left-recursion? [ s throw ] unless
 164         s head>> l head>> eq? [
 165             l head>> s head<<
 166             l head>> [ s rule-id>> suffix ] change-involved-set drop
 167             l s next>> (setup-lr)
 168         ] unless
 169     ] when ;
 170
 171 :: setup-lr ( r l -- )
 172     l head>> [
 173         r rule-id V{ } clone V{ } clone peg-head boa l head<<
 174     ] unless
 175     l lrstack get (setup-lr) ;
 176
 177 :: lr-answer ( r p m -- ast )
 178     m ans>> head>> :> h
 179     h rule-id>> r rule-id eq? [
 180         m ans>> seed>> m ans<<
 181         m ans>> failed? [
 182             fail
 183         ] [
 184             h p r m grow-lr
 185         ] if
 186     ] [
 187         m ans>> seed>>
 188     ] if ; inline
 189
 190 :: recall ( r p -- memo-entry )
 191     p r rule-id memo :> m
 192     p heads at :> h
 193     h [
 194         m r rule-id h involved-set>> h rule-id>> suffix member? not and [
 195             fail p memo-entry boa
 196         ] [
 197             r rule-id h eval-set>> member? [
 198                 h [ r rule-id swap remove ] change-eval-set drop
 199                 r eval-rule
 200                 m update-m
 201                 m
 202             ] [
 203                 m
 204             ] if
 205         ] if
 206     ] [
 207         m
 208     ] if ; inline
 209
 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
 213     r eval-rule :> ans
 214     lrstack get next>> lrstack set
 215     pos get m pos<<
 216     lr head>> [
 217         m ans>> left-recursion? [
 218             ans lr seed<<
 219             r p m lr-answer
 220         ] [ ans ] if
 221     ] [
 222         ans m ans<<
 223         ans
 224     ] if ; inline
 225
 226 : apply-memo-rule ( r m -- ast )
 227     [ ans>> ] [ pos>> ] bi pos set
 228     dup left-recursion? [
 229         [ setup-lr ] keep seed>>
 230     ] [
 231         nip
 232     ] if ;
 233
 234 : apply-rule ( r p -- ast )
 235     2dup recall [
 236         nip apply-memo-rule
 237     ] [
 238         apply-non-memo-rule
 239     ] if* ; inline
 240
 241 : with-packrat ( input quot -- result )
 242     #! Run the quotation with a packrat cache active.
 243     [
 244         swap input ,,
 245         0 pos ,,
 246         f lrstack ,,
 247         V{ } clone error-stack ,,
 248         H{ } clone \ heads ,,
 249         H{ } clone \ packrat ,,
 250     ] H{ } make swap with-variables ; inline
 251
 252 GENERIC: (compile) ( peg -- quot )
 253
 254 : process-parser-result ( result -- result )
 255     dup failed? [
 256         drop f
 257     ] [
 258         input-slice swap <parse-result>
 259     ] if ;
 260
 261 : execute-parser ( word -- result )
 262     pos get apply-rule process-parser-result ;
 263
 264 : preset-parser-word ( parser -- parser word )
 265     gensym [ >>compiled ] keep ;
 266
 267 : define-parser-word ( parser word -- )
 268     #! Return the body of the word that is the compiled version
 269     #! of the parser.
 270     2dup swap peg>> (compile) ( -- result ) define-declared
 271     swap id>> "peg-id" set-word-prop ;
 272
 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.
 280     dup compiled>> [
 281         nip
 282     ] [
 283         preset-parser-word [ define-parser-word ] keep
 284     ] if* ;
 285
 286 : compile-parser-quot ( parser -- quot )
 287     compile-parser [ execute-parser ] curry ;
 288
 289 SYMBOL: delayed
 290
 291 : fixup-delayed ( -- )
 292     #! Work through all delayed parsers and recompile their
 293     #! words to have the correct bodies.
 294     delayed get [
 295         call( -- parser ) compile-parser-quot ( -- result ) define-declared
 296     ] assoc-each ;
 297
 298 : compile ( parser -- word )
 299     [
 300         H{ } clone delayed [
 301             compile-parser-quot ( -- result ) define-temp fixup-delayed
 302         ] with-variable
 303     ] with-compilation-unit ;
 304
 305 : compiled-parse ( state word -- result )
 306     swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
 307
 308 : (parse) ( input parser -- result )
 309     dup word? [ compile ] unless compiled-parse ;
 310
 311 : parse ( input parser -- ast )
 312     (parse) ast>> ;
 313
 314 <PRIVATE
 315
 316 SYMBOL: id
 317
 318 : next-id ( -- n )
 319     #! Return the next unique id for a parser
 320     id get-global [
 321         dup 1 + id set-global
 322     ] [
 323         1 id set-global 0
 324     ] if* ;
 325
 326 : wrap-peg ( peg -- parser )
 327     #! Wrap a parser tuple around the peg object.
 328     #! Look for an existing parser tuple for that
 329     #! peg object.
 330     peg-cache [
 331         f next-id parser boa
 332     ] cache ;
 333
 334 TUPLE: token-parser symbol ;
 335
 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
 340     ] [
 341         [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
 342     ] if ;
 343
 344 M: token-parser (compile) ( peg -- quot )
 345     symbol>> '[ input-slice _ parse-token ] ;
 346
 347 TUPLE: satisfy-parser quot ;
 348
 349 : parse-satisfy ( input quot -- result )
 350     swap dup empty? [
 351         2drop f
 352     ] [
 353         unclip-slice rot dupd call [
 354             <parse-result>
 355         ] [
 356             2drop f
 357         ] if
 358     ] if ; inline
 359
 360
 361 M: satisfy-parser (compile) ( peg -- quot )
 362     quot>> '[ input-slice _ parse-satisfy ] ;
 363
 364 TUPLE: range-parser min max ;
 365
 366 : parse-range ( input min max -- result )
 367     pick empty? [
 368         3drop f
 369     ] [
 370         [ dup first ] 2dip between? [
 371             unclip-slice <parse-result>
 372         ] [
 373             drop f
 374         ] if
 375     ] if ;
 376
 377 M: range-parser (compile) ( peg -- quot )
 378     [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
 379
 380 TUPLE: seq-parser parsers ;
 381
 382 : ignore? ( ast -- bool )
 383     ignore = ;
 384
 385 : calc-seq-result ( prev-result current-result -- next-result )
 386     [
 387         [ remaining>> swap remaining<< ] 2keep
 388         ast>> dup ignore? [
 389             drop
 390         ] [
 391             swap [ ast>> push ] keep
 392         ] if
 393     ] [
 394         drop f
 395     ] if* ;
 396
 397 : parse-seq-element ( result quot -- result )
 398     over [
 399         call calc-seq-result
 400     ] [
 401         2drop f
 402     ] if ; inline
 403
 404 M: seq-parser (compile) ( peg -- quot )
 405     [
 406         [ input-slice V{ } clone <parse-result> ] %
 407         [
 408             parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
 409             [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
 410         ] { } make , \ 1&& ,
 411     ] [ ] make ;
 412
 413 TUPLE: choice-parser parsers ;
 414
 415 M: choice-parser (compile) ( peg -- quot )
 416     [
 417         [
 418             parsers>> [ compile-parser-quot ] map
 419             unclip , [ [ merge-errors ] compose , ] each
 420         ] { } make , \ 0|| ,
 421     ] [ ] make ;
 422
 423 TUPLE: repeat0-parser p1 ;
 424
 425 : (repeat) ( quot: ( -- result ) result -- result )
 426     over call [
 427         [ remaining>> swap remaining<< ] 2keep
 428         ast>> swap [ ast>> push ] keep
 429         (repeat)
 430     ] [
 431         nip
 432     ] if* ; inline recursive
 433
 434 M: repeat0-parser (compile) ( peg -- quot )
 435     p1>> compile-parser-quot '[
 436         input-slice V{ } clone <parse-result> _ swap (repeat)
 437     ] ;
 438
 439 TUPLE: repeat1-parser p1 ;
 440
 441 : repeat1-empty-check ( result -- result )
 442     [
 443         dup ast>> empty? [ drop f ] when
 444     ] [
 445         f
 446     ] if* ;
 447
 448 M: repeat1-parser (compile) ( peg -- quot )
 449     p1>> compile-parser-quot '[
 450         input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
 451     ] ;
 452
 453 TUPLE: optional-parser p1 ;
 454
 455 : check-optional ( result -- result )
 456       [ input-slice f <parse-result> ] unless* ;
 457
 458 M: optional-parser (compile) ( peg -- quot )
 459       p1>> compile-parser-quot '[ @ check-optional ] ;
 460
 461 TUPLE: semantic-parser p1 quot ;
 462
 463 : check-semantic ( result quot -- result )
 464     over [
 465         over ast>> swap call [ drop f ] unless
 466     ] [
 467         drop
 468     ] if ; inline
 469
 470 M: semantic-parser (compile) ( peg -- quot )
 471     [ p1>> compile-parser-quot ] [ quot>> ] bi
 472     '[ @ _ check-semantic ] ;
 473
 474 TUPLE: ensure-parser p1 ;
 475
 476 : check-ensure ( old-input result -- result )
 477     [ ignore <parse-result> ] [ drop f ] if ;
 478
 479 M: ensure-parser (compile) ( peg -- quot )
 480     p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
 481
 482 TUPLE: ensure-not-parser p1 ;
 483
 484 : check-ensure-not ( old-input result -- result )
 485     [ drop f ] [ ignore <parse-result> ] if ;
 486
 487 M: ensure-not-parser (compile) ( peg -- quot )
 488     p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
 489
 490 TUPLE: action-parser p1 quot ;
 491
 492 : check-action ( result quot -- result )
 493     over [
 494         over ast>> swap call( ast -- ast ) >>ast
 495     ] [
 496         drop
 497     ] if ;
 498
 499 M: action-parser (compile) ( peg -- quot )
 500     [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
 501
 502 TUPLE: sp-parser p1 ;
 503
 504 M: sp-parser (compile) ( peg -- quot )
 505     p1>> compile-parser-quot '[
 506         input-slice [ blank? ] trim-head-slice input-from pos set @
 507     ] ;
 508
 509 TUPLE: delay-parser quot ;
 510
 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 ;
 516
 517 TUPLE: box-parser quot ;
 518
 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
 523     #! it at run time.
 524     quot>> call( -- parser ) compile-parser-quot ;
 525
 526 PRIVATE>
 527
 528 : token ( string -- parser )
 529     token-parser boa wrap-peg ;
 530
 531 : satisfy ( quot -- parser )
 532     satisfy-parser boa wrap-peg ;
 533
 534 : range ( min max -- parser )
 535     range-parser boa wrap-peg ;
 536
 537 : seq ( seq -- parser )
 538     seq-parser boa wrap-peg ;
 539
 540 : 2seq ( parser1 parser2 -- parser )
 541     2array seq ;
 542
 543 : 3seq ( parser1 parser2 parser3 -- parser )
 544     3array seq ;
 545
 546 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
 547     4array seq ;
 548
 549 : seq* ( quot -- paser )
 550     { } make seq ; inline
 551
 552 : choice ( seq -- parser )
 553     choice-parser boa wrap-peg ;
 554
 555 : 2choice ( parser1 parser2 -- parser )
 556     2array choice ;
 557
 558 : 3choice ( parser1 parser2 parser3 -- parser )
 559     3array choice ;
 560
 561 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
 562     4array choice ;
 563
 564 : choice* ( quot -- paser )
 565     { } make choice ; inline
 566
 567 : repeat0 ( parser -- parser )
 568     repeat0-parser boa wrap-peg ;
 569
 570 : repeat1 ( parser -- parser )
 571     repeat1-parser boa wrap-peg ;
 572
 573 : optional ( parser -- parser )
 574     optional-parser boa wrap-peg ;
 575
 576 : semantic ( parser quot -- parser )
 577     semantic-parser boa wrap-peg ;
 578
 579 : ensure ( parser -- parser )
 580     ensure-parser boa wrap-peg ;
 581
 582 : ensure-not ( parser -- parser )
 583     ensure-not-parser boa wrap-peg ;
 584
 585 : action ( parser quot -- parser )
 586     action-parser boa wrap-peg ;
 587
 588 : sp ( parser -- parser )
 589     sp-parser boa wrap-peg ;
 590
 591 : hide ( parser -- parser )
 592     [ drop ignore ] action ;
 593
 594 : delay ( quot -- parser )
 595     delay-parser boa wrap-peg ;
 596
 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 ;
 610
 611 ERROR: parse-failed input word ;
 612
 613 SYNTAX: PEG:
 614     [let
 615         (:) :> ( word def effect )
 616         [
 617           [
 618             def call compile :> compiled-def
 619             [
 620               dup compiled-def compiled-parse
 621               [ ast>> ] [ word parse-failed ] ?if
 622             ]
 623             word swap effect define-declared
 624           ] with-compilation-unit
 625         ] append!
 626     ] ;
 627
 628 USE: vocabs.loader
 629
 630 { "debugger" "peg" } "peg.debugger" require-when