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