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