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