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