basis/peg/ebnf/ebnf.factor

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