basis/peg/peg.factor

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