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