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