basis/peg/ebnf/ebnf.factor

   1 ! Copyright (C) 2007 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 effects fry kernel make math math.parser multiline namespaces
   5 parser peg peg.parsers quotations sequences sequences.deep
   6 splitting stack-checker strings strings.parser summary unicode
   7 vocabs.parser words ;
   8 FROM: vocabs.parser => search ;
   9 FROM: peg.search => replace ;
  10 IN: peg.ebnf
  11
  12 : rule ( name word -- parser )
  13     ! Given an EBNF word produced from EBNF: return the EBNF rule
  14     "ebnf-parser" word-prop at ;
  15
  16 ERROR: no-rule rule parser ;
  17
  18 <PRIVATE
  19
  20 : lookup-rule ( rule parser -- rule' )
  21     2dup rule [ 2nip ] [ no-rule ] if* ;
  22
  23 TUPLE: tokenizer-tuple any one many ;
  24
  25 : default-tokenizer ( -- tokenizer )
  26     T{ tokenizer-tuple f
  27         [ any-char ]
  28         [ token ]
  29         [ [ = ] curry any-char swap semantic ]
  30     } ;
  31
  32 : parser-tokenizer ( parser -- tokenizer )
  33     [ 1quotation ] keep
  34     [ swap [ = ] curry semantic ] curry dup tokenizer-tuple boa ;
  35
  36 : rule-tokenizer ( name word -- tokenizer )
  37     rule parser-tokenizer ;
  38
  39 : tokenizer ( -- word )
  40     \ tokenizer get-global [ default-tokenizer ] unless* ;
  41
  42 : reset-tokenizer ( -- )
  43     default-tokenizer \ tokenizer set-global ;
  44
  45 TUPLE: ebnf-non-terminal symbol ;
  46 TUPLE: ebnf-terminal symbol ;
  47 TUPLE: ebnf-foreign word rule ;
  48 TUPLE: ebnf-any-character ;
  49 TUPLE: ebnf-range pattern ;
  50 TUPLE: ebnf-ensure group ;
  51 TUPLE: ebnf-ensure-not group ;
  52 TUPLE: ebnf-choice options ;
  53 TUPLE: ebnf-sequence elements ;
  54 TUPLE: ebnf-repeat0 group ;
  55 TUPLE: ebnf-repeat1 group ;
  56 TUPLE: ebnf-ignore group ;
  57 TUPLE: ebnf-ignore-repeat0 group ;
  58 TUPLE: ebnf-ignore-repeat1 group ;
  59 TUPLE: ebnf-optional group ;
  60 TUPLE: ebnf-whitespace group ;
  61 TUPLE: ebnf-tokenizer elements ;
  62 TUPLE: ebnf-rule symbol elements ;
  63 TUPLE: ebnf-action parser code ;
  64 TUPLE: ebnf-var parser name ;
  65 TUPLE: ebnf-semantic parser code ;
  66 TUPLE: ebnf rules ;
  67
  68 C: <ebnf-non-terminal> ebnf-non-terminal
  69 C: <ebnf-terminal> ebnf-terminal
  70 C: <ebnf-foreign> ebnf-foreign
  71 C: <ebnf-any-character> ebnf-any-character
  72 C: <ebnf-range> ebnf-range
  73 C: <ebnf-ensure> ebnf-ensure
  74 C: <ebnf-ensure-not> ebnf-ensure-not
  75 C: <ebnf-choice> ebnf-choice
  76 C: <ebnf-sequence> ebnf-sequence
  77 C: <ebnf-repeat0> ebnf-repeat0
  78 C: <ebnf-repeat1> ebnf-repeat1
  79 C: <ebnf-ignore> ebnf-ignore
  80 C: <ebnf-ignore-repeat0> ebnf-ignore-repeat0
  81 C: <ebnf-ignore-repeat1> ebnf-ignore-repeat1
  82 C: <ebnf-optional> ebnf-optional
  83 C: <ebnf-whitespace> ebnf-whitespace
  84 C: <ebnf-tokenizer> ebnf-tokenizer
  85 C: <ebnf-rule> ebnf-rule
  86 C: <ebnf-action> ebnf-action
  87 C: <ebnf-var> ebnf-var
  88 C: <ebnf-semantic> ebnf-semantic
  89 C: <ebnf> ebnf
  90
  91 MIXIN: ebnf-ignored
  92
  93 INSTANCE: ebnf-ignore ebnf-ignored
  94 INSTANCE: ebnf-ignore-repeat0 ebnf-ignored
  95 INSTANCE: ebnf-ignore-repeat1 ebnf-ignored
  96
  97 : filter-hidden ( seq -- seq )
  98     ! Remove elements that produce no AST from sequence
  99     [ ebnf-ensure-not? ] reject [ ebnf-ensure? ] reject
 100     [ ebnf-ignored? ] reject ;
 101
 102 : syntax ( string -- parser )
 103     ! Parses the string, ignoring white space, and
 104     ! does not put the result in the AST.
 105     token sp hide ;
 106
 107 : syntax-pack ( begin parser end -- parser )
 108     ! Parse parser-parser surrounded by syntax elements
 109     ! begin and end.
 110     [ syntax ] 2dip syntax pack ;
 111
 112 : insert-escapes ( string -- string )
 113     [
 114         "\t" token [ drop "\\t" ] action ,
 115         "\n" token [ drop "\\n" ] action ,
 116         "\r" token [ drop "\\r" ] action ,
 117     ] choice* replace ;
 118
 119 : identifier-parser ( -- parser )
 120     ! Return a parser that parses an identifer delimited by
 121     ! a quotation character. The quotation can be single
 122     ! or double quotes. The AST produced is the identifier
 123     ! between the quotes.
 124     [
 125         [
 126             [ CHAR: \ = ] satisfy
 127             [ "\"\\" member? ] satisfy 2seq ,
 128             [ CHAR: \" = not ] satisfy ,
 129         ] choice* repeat1 "\"" "\"" surrounded-by ,
 130         [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
 131     ] choice* [ "" flatten-as unescape-string ] action ;
 132
 133 : non-terminal-parser ( -- parser )
 134     ! A non-terminal is the name of another rule. It can
 135     ! be any non-blank character except for characters used
 136     ! in the EBNF syntax itself.
 137     [
 138         {
 139             [ blank? ]
 140             [ "\"'|{}=)(][.!&*+?:~<>" member? ]
 141         } 1|| not
 142     ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 143
 144 : terminal-parser ( -- parser )
 145     ! A terminal is an identifier enclosed in quotations
 146     ! and it represents the literal value of the identifier.
 147     identifier-parser [ <ebnf-terminal> ] action ;
 148
 149 : foreign-name-parser ( -- parser )
 150     ! Parse a valid foreign parser name
 151     [
 152         {
 153             [ blank? ]
 154             [ CHAR: > = ]
 155         } 1|| not
 156     ] satisfy repeat1 [ >string ] action ;
 157
 158 : foreign-parser ( -- parser )
 159     ! A foreign call is a call to a rule in another ebnf grammar
 160     [
 161         "<foreign" syntax ,
 162         foreign-name-parser sp ,
 163         foreign-name-parser sp optional ,
 164         ">" syntax ,
 165     ] seq* [ first2 <ebnf-foreign> ] action ;
 166
 167 : any-character-parser ( -- parser )
 168     ! A parser to match the symbol for any character match.
 169     [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
 170
 171 : range-parser ( -- parser )
 172     ! Match the syntax for declaring character ranges
 173     [
 174         [ "[" syntax , "[" token ensure-not , ] seq* hide ,
 175         [
 176             "\\]" token [ second ] action ,
 177             [ CHAR: ] = not ] satisfy ,
 178         ] choice* repeat0 ,
 179         "]" syntax ,
 180     ] seq* [ first >string unescape-string <ebnf-range> ] action ;
 181
 182 : (element-parser) ( -- parser )
 183     ! An element of a rule. It can be a terminal or a
 184     ! non-terminal but must not be followed by a "=".
 185     ! The latter indicates that it is the beginning of a
 186     ! new rule.
 187     [
 188         [
 189             [
 190                 non-terminal-parser ,
 191                 terminal-parser ,
 192                 foreign-parser ,
 193                 range-parser ,
 194                 any-character-parser ,
 195             ] choice*
 196             [ dup , "~" token hide , ] seq* [ first <ebnf-ignore> ] action ,
 197             [ dup , "*~" token hide , ] seq* [ first <ebnf-ignore-repeat0> ] action ,
 198             [ dup , "+~" token hide , ] seq* [ first <ebnf-ignore-repeat1> ] action ,
 199             [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,
 200             [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,
 201             [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,
 202             ,
 203         ] choice* ,
 204         [
 205             "=" syntax ensure-not ,
 206             "=>" syntax ensure ,
 207         ] choice* ,
 208     ] seq* [ first ] action ;
 209
 210 DEFER: action-parser
 211
 212 : element-parser ( -- parser )
 213     [
 214         [
 215             (element-parser) , ":" syntax ,
 216             "a-zA-Z_" range-pattern
 217             "a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action ,
 218         ] seq* [ first2 <ebnf-var> ] action ,
 219         (element-parser) ,
 220     ] choice* ;
 221
 222 DEFER: choice-parser
 223
 224 : grouped ( quot suffix -- parser )
 225     ! Parse a group of choices, with a suffix indicating
 226     ! the type of group (repeat0, repeat1, etc) and
 227     ! an quot that is the action that produces the AST.
 228     [
 229         2dup
 230         "(" [ choice-parser sp ] delay ")" syntax-pack
 231         swap 2seq
 232         [ first ] rot compose action ,
 233         "{" [ choice-parser sp ] delay "}" syntax-pack
 234         swap 2seq
 235         [ first <ebnf-whitespace> ] rot compose action ,
 236     ] choice* ;
 237
 238 : group-parser ( -- parser )
 239     ! A grouping with no suffix. Used for precedence.
 240     [ ] [
 241         "~" token sp ensure-not ,
 242         "*" token sp ensure-not ,
 243         "+" token sp ensure-not ,
 244         "?" token sp ensure-not ,
 245     ] seq* hide grouped ;
 246
 247 : repeat0-parser ( -- parser )
 248     [ <ebnf-repeat0> ] "*" syntax grouped ;
 249
 250 : repeat1-parser ( -- parser )
 251     [ <ebnf-repeat1> ] "+" syntax grouped ;
 252
 253 : ignore-parser ( -- parser )
 254     [ <ebnf-ignore> ] "~" syntax grouped ;
 255
 256 : ignore-repeat0-parser ( -- parser )
 257     [ <ebnf-ignore-repeat0> ] "*~" syntax grouped ;
 258
 259 : ignore-repeat1-parser ( -- parser )
 260     [ <ebnf-ignore-repeat1> ] "+~" syntax grouped ;
 261
 262 : optional-parser ( -- parser )
 263     [ <ebnf-optional> ] "?" syntax grouped ;
 264
 265 : factor-code-parser ( -- parser )
 266     [
 267         "]]" token ensure-not ,
 268         "]?" token ensure-not ,
 269         [ drop t ] satisfy ,
 270     ] seq* repeat0 [ "" concat-as ] action ;
 271
 272 : ensure-not-parser ( -- parser )
 273     ! Parses the '!' syntax to ensure that
 274     ! something that matches the following elements do
 275     ! not exist in the parse stream.
 276     [
 277         "!" syntax ,
 278         group-parser sp ,
 279     ] seq* [ first <ebnf-ensure-not> ] action ;
 280
 281 : ensure-parser ( -- parser )
 282     ! Parses the '&' syntax to ensure that
 283     ! something that matches the following elements does
 284     ! exist in the parse stream.
 285     [
 286         "&" syntax ,
 287         group-parser sp ,
 288     ] seq* [ first <ebnf-ensure> ] action ;
 289
 290 : (sequence-parser) ( -- parser )
 291     ! A sequence of terminals and non-terminals, including
 292     ! groupings of those.
 293     [
 294         [
 295             ensure-not-parser sp ,
 296             ensure-parser sp ,
 297             element-parser sp ,
 298             group-parser sp ,
 299             ignore-parser sp ,
 300             ignore-repeat0-parser sp ,
 301             ignore-repeat1-parser sp ,
 302             repeat0-parser sp ,
 303             repeat1-parser sp ,
 304             optional-parser sp ,
 305         ] choice* [
 306             dup , ":" syntax , "a-zA-Z" range-pattern repeat1
 307             [ >string ] action ,
 308         ] seq* [ first2 <ebnf-var> ] action ,
 309         ,
 310     ] choice* ;
 311
 312 : action-parser ( -- parser )
 313      "[[" factor-code-parser "]]" syntax-pack ;
 314
 315 : semantic-parser ( -- parser )
 316      "?[" factor-code-parser "]?" syntax-pack ;
 317
 318 : sequence-parser ( -- parser )
 319     ! A sequence of terminals and non-terminals, including
 320     ! groupings of those.
 321     [
 322         [ (sequence-parser) , action-parser , ] seq*
 323         [ first2 <ebnf-action> ] action ,
 324
 325         [ (sequence-parser) , semantic-parser , ] seq*
 326         [ first2 <ebnf-semantic> ] action ,
 327
 328         (sequence-parser) ,
 329     ] choice* repeat1 [
 330          dup length 1 = [ first ] [ <ebnf-sequence> ] if
 331     ] action ;
 332
 333 : actioned-sequence-parser ( -- parser )
 334     [
 335         [ sequence-parser , "=>" syntax , action-parser , ] seq*
 336         [ first2 <ebnf-action> ] action ,
 337         sequence-parser ,
 338     ] choice* ;
 339
 340 : choice-parser ( -- parser )
 341     actioned-sequence-parser sp repeat1 [
 342         dup length 1 = [ first ] [ <ebnf-sequence> ] if
 343     ] action "|" token sp list-of [
 344         dup length 1 = [ first ] [ <ebnf-choice> ] if
 345     ] action ;
 346
 347 : tokenizer-parser ( -- parser )
 348     [
 349         "tokenizer" syntax ,
 350         "=" syntax ,
 351         ">" token ensure-not ,
 352         [ "default" token sp , choice-parser , ] choice* ,
 353     ] seq* [ first <ebnf-tokenizer> ] action ;
 354
 355 : rule-parser ( -- parser )
 356     [
 357         "tokenizer" token ensure-not ,
 358         non-terminal-parser [ symbol>> ] action ,
 359         "=" syntax ,
 360         ">" token ensure-not ,
 361         choice-parser ,
 362     ] seq* [ first2 <ebnf-rule> ] action ;
 363
 364 : ebnf-parser ( -- parser )
 365     [ tokenizer-parser sp , rule-parser sp , ] choice* repeat1 [ <ebnf> ] action ;
 366
 367 GENERIC: (transform) ( ast -- parser )
 368
 369 SYMBOL: parser
 370 SYMBOL: main
 371 SYMBOL: ignore-ws
 372
 373 : transform ( ast -- object )
 374     H{ } clone dup dup [
 375         f ignore-ws set
 376         parser set
 377         swap (transform)
 378         main set
 379     ] with-variables ;
 380
 381 M: ebnf (transform)
 382     rules>> [ (transform) ] map last ;
 383
 384 M: ebnf-tokenizer (transform)
 385     elements>> dup "default" = [
 386         drop default-tokenizer \ tokenizer set-global any-char
 387     ] [
 388         (transform)
 389         dup parser-tokenizer \ tokenizer set-global
 390     ] if ;
 391
 392 ERROR: redefined-rule name ;
 393
 394 M: redefined-rule summary
 395     name>> "Rule '" "' defined more than once" surround ;
 396
 397 M: ebnf-rule (transform)
 398     dup elements>>
 399     (transform) [
 400         swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
 401     ] keep ;
 402
 403 M: ebnf-sequence (transform)
 404     ! If ignore-ws is set then each element of the sequence
 405     ! ignores leading whitespace. This is not inherited by
 406     ! subelements of the sequence.
 407     elements>> [
 408         f ignore-ws [ (transform) ] with-variable
 409         ignore-ws get [ sp ] when
 410     ] map seq [ dup length 1 = [ first ] when ] action ;
 411
 412 M: ebnf-choice (transform)
 413     options>> [ (transform) ] map choice ;
 414
 415 M: ebnf-any-character (transform)
 416     drop tokenizer any>> call( -- parser ) ;
 417
 418 M: ebnf-range (transform)
 419     pattern>> range-pattern ;
 420
 421 : transform-group ( ast -- parser )
 422     ! convert a ast node with groups to a parser for that group
 423     group>> (transform) ;
 424
 425 M: ebnf-ensure (transform)
 426     transform-group ensure ;
 427
 428 M: ebnf-ensure-not (transform)
 429     transform-group ensure-not ;
 430
 431 M: ebnf-ignore (transform)
 432     transform-group [ drop ignore ] action ;
 433
 434 M: ebnf-ignore-repeat0 (transform)
 435     transform-group repeat0 hide ;
 436
 437 M: ebnf-ignore-repeat1 (transform)
 438     transform-group repeat1 hide ;
 439
 440 M: ebnf-repeat0 (transform)
 441     transform-group repeat0 ;
 442
 443 M: ebnf-repeat1 (transform)
 444     transform-group repeat1 ;
 445
 446 M: ebnf-optional (transform)
 447     transform-group optional ;
 448
 449 M: ebnf-whitespace (transform)
 450     t ignore-ws [ transform-group ] with-variable ;
 451
 452 GENERIC: build-locals ( code ast -- code )
 453
 454 M: ebnf-sequence build-locals
 455     ! Note the need to filter out this ebnf items that
 456     ! leave nothing in the AST
 457     elements>> filter-hidden dup length 1 = [
 458         first build-locals
 459     ] [
 460         dup [ ebnf-var? ] none? [
 461             drop
 462         ] [
 463             [
 464                 "[let " %
 465                 [
 466                     over ebnf-var? [
 467                         " " % # " over nth :> " %
 468                         name>> %
 469                     ] [
 470                         2drop
 471                     ] if
 472                 ] each-index
 473                 " " %
 474                 %
 475                 " nip ]" %
 476              ] "" make
 477         ] if
 478     ] if ;
 479
 480 M: ebnf-var build-locals
 481     [
 482         "[let dup :> " % name>> %
 483         " " %
 484         %
 485         " nip ]" %
 486     ] "" make ;
 487
 488 M: object build-locals
 489     drop ;
 490
 491 ERROR: bad-effect quot effect ;
 492
 493 : check-action-effect ( quot -- quot )
 494     dup infer {
 495         { [ dup ( a -- b ) effect<= ] [ drop ] }
 496         { [ dup ( -- b ) effect<= ] [ drop [ drop ] prepose ] }
 497         [ bad-effect ]
 498     } cond ;
 499
 500 : ebnf-transform ( ast -- parser quot )
 501     [ parser>> (transform) ]
 502     [ code>> insert-escapes ]
 503     [ parser>> ] tri build-locals
 504     H{
 505         { "dup" dup } { "nip" nip } { "over" over } ! kernel
 506         { "nth" nth } ! sequences
 507     } [ string-lines parse-lines ] with-words ;
 508
 509 M: ebnf-action (transform)
 510     ebnf-transform check-action-effect action ;
 511
 512 M: ebnf-semantic (transform)
 513     ebnf-transform semantic ;
 514
 515 M: ebnf-var (transform)
 516     parser>> (transform) ;
 517
 518 M: ebnf-terminal (transform)
 519     symbol>> tokenizer one>> call( symbol -- parser ) ;
 520
 521 ERROR: ebnf-foreign-not-found name ;
 522
 523 M: ebnf-foreign-not-found summary
 524     name>> "Foreign word '" "' not found" surround ;
 525
 526 M: ebnf-foreign (transform)
 527     dup word>> search [ word>> ebnf-foreign-not-found ] unless*
 528     swap rule>> [ main ] unless* over rule [
 529         nip
 530     ] [
 531         execute( -- parser )
 532     ] if* ;
 533
 534 ERROR: parser-not-found name ;
 535
 536 M: ebnf-non-terminal (transform)
 537     symbol>> parser get
 538     '[ _ dup _ at [ parser-not-found ] unless* nip ] box ;
 539
 540 : transform-ebnf ( string -- object )
 541     ebnf-parser parse transform ;
 542
 543 ERROR: unable-to-fully-parse-ebnf remaining ;
 544
 545 ERROR: could-not-parse-ebnf ;
 546
 547 : check-parse-result ( result -- result )
 548     [
 549         dup remaining>> [ blank? ] trim [
 550             unable-to-fully-parse-ebnf
 551         ] unless-empty
 552     ] [
 553         could-not-parse-ebnf
 554     ] if* ;
 555
 556 : parse-ebnf ( string -- hashtable )
 557     ebnf-parser (parse) check-parse-result ast>> transform ;
 558
 559 : ebnf>quot ( string -- hashtable quot: ( string -- results ) )
 560     parse-ebnf dup dup parser [ main of compile ] with-variable
 561     '[ [ _ compiled-parse ] with-scope ] ;
 562
 563 PRIVATE>
 564
 565 SYNTAX: EBNF:
 566     reset-tokenizer
 567     scan-new-word dup scan-object
 568     ebnf>quot swapd
 569     [ "ebnf-quot" set-word-prop ] 2keep
 570     [ check-parse-result ast>> ] compose
 571     ( input -- ast ) define-declared
 572     "ebnf-parser" set-word-prop ;
 573
 574 SYNTAX: PARTIAL-EBNF:
 575     scan-new-word
 576     scan-word "ebnf-quot" word-prop
 577     [ ast>> ] compose
 578     ( input -- ast ) define-declared ;
 579
 580 : define-inline-ebnf ( ast string -- quot )
 581     reset-tokenizer
 582     ebnf>quot [ check-parse-result ast>> ] compose nip
 583     suffix! \ call suffix! reset-tokenizer ;
 584
 585 : define-partial-inline-ebnf ( ast string -- quot )
 586     reset-tokenizer
 587     ebnf>quot [ ast>> ] compose nip
 588     suffix! \ call suffix! reset-tokenizer ;
 589
 590 SYNTAX: EBNF[[ "]]" parse-multiline-string define-inline-ebnf ;
 591 SYNTAX: EBNF[=[ "]=]" parse-multiline-string define-inline-ebnf ;
 592 SYNTAX: EBNF[==[ "]==]" parse-multiline-string define-inline-ebnf ;
 593 SYNTAX: EBNF[===[ "]===]" parse-multiline-string define-inline-ebnf ;
 594 SYNTAX: EBNF[====[ "]====]" parse-multiline-string define-inline-ebnf ;
 595
 596 SYNTAX: PARTIAL-EBNF[[ "]]" parse-multiline-string define-partial-inline-ebnf ;
 597 SYNTAX: PARTIAL-EBNF[=[ "]=]" parse-multiline-string define-partial-inline-ebnf ;
 598 SYNTAX: PARTIAL-EBNF[==[ "]==]" parse-multiline-string define-partial-inline-ebnf ;
 599 SYNTAX: PARTIAL-EBNF[===[ "]===]" parse-multiline-string define-partial-inline-ebnf ;
 600 SYNTAX: PARTIAL-EBNF[====[ "]====]" parse-multiline-string define-partial-inline-ebnf ;
 601
 602 SYNTAX: EBNF-PARSER:
 603     reset-tokenizer
 604     scan-new-word
 605     scan-object parse-ebnf main of '[ _ ]
 606     ( -- parser ) define-declared
 607     reset-tokenizer ;