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