basis/peg/peg.factor

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