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