extra/peg/peg.factor

   1 ! Copyright (C) 2007 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences strings namespaces math assocs shuffle
   4        vectors arrays combinators.lib memoize math.parser match
   5        unicode.categories ;
   6 IN: peg
   7
   8 TUPLE: parse-result remaining ast ;
   9
  10 GENERIC: compile ( parser -- quot )
  11
  12 : (parse) ( state parser -- result )
  13   compile call ;
  14
  15
  16 <PRIVATE
  17
  18 SYMBOL: packrat-cache
  19 SYMBOL: ignore
  20 SYMBOL: not-in-cache
  21
  22 : not-in-cache? ( result -- ? )
  23   not-in-cache = ;
  24
  25 : <parse-result> ( remaining ast -- parse-result )
  26   parse-result construct-boa ;
  27
  28 SYMBOL: next-id
  29
  30 : get-next-id ( -- number )
  31   next-id get-global 0 or dup 1+ next-id set-global ;
  32
  33 TUPLE: parser id ;
  34
  35 : init-parser ( parser -- parser )
  36   get-next-id parser construct-boa over set-delegate ;
  37
  38 : from ( slice-or-string -- index )
  39   dup slice? [ slice-from ] [ drop 0 ] if ;
  40
  41 : get-cached ( input parser -- result )
  42   [ from ] dip parser-id packrat-cache get at at* [
  43     drop not-in-cache
  44   ] unless ;
  45
  46 : put-cached ( result input parser -- )
  47   parser-id dup packrat-cache get at [
  48     nip
  49   ] [
  50     H{ } clone dup >r swap packrat-cache get set-at r>
  51   ] if*
  52   [ from ] dip set-at ;
  53
  54 PRIVATE>
  55
  56 : parse ( input parser -- result )
  57   packrat-cache get [
  58     2dup get-cached dup not-in-cache? [
  59 !      "cache missed: " write over parser-id number>string write " - " write nl ! pick .
  60       drop
  61       #! Protect against left recursion blowing the callstack
  62       #! by storing a failed parse in the cache.
  63       [ f ] dipd  [ put-cached ] 2keep
  64       [ (parse) dup ] 2keep put-cached
  65     ] [
  66 !      "cache hit: " write over parser-id number>string write " - " write nl ! pick .
  67       2nip
  68     ] if
  69   ] [
  70     (parse)
  71   ] if ;
  72
  73 : packrat-parse ( input parser -- result )
  74   H{ } clone packrat-cache [ parse ] with-variable ;
  75
  76 <PRIVATE
  77
  78 TUPLE: token-parser symbol ;
  79
  80 MATCH-VARS: ?token ;
  81
  82 : token-pattern ( -- quot )
  83   [
  84     ?token 2dup head? [
  85       dup >r length tail-slice r> <parse-result>
  86     ] [
  87       2drop f
  88     ] if
  89   ] ;
  90
  91 M: token-parser compile ( parser -- quot )
  92   token-parser-symbol \ ?token token-pattern match-replace ;
  93
  94 TUPLE: satisfy-parser quot ;
  95
  96 MATCH-VARS: ?quot ;
  97
  98 : satisfy-pattern ( -- quot )
  99   [
 100     dup empty? [
 101       drop f
 102     ] [
 103       unclip-slice dup ?quot call [
 104         <parse-result>
 105       ] [
 106         2drop f
 107       ] if
 108     ] if
 109   ] ;
 110
 111 M: satisfy-parser compile ( parser -- quot )
 112   satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
 113
 114 TUPLE: range-parser min max ;
 115
 116 MATCH-VARS: ?min ?max ;
 117
 118 : range-pattern ( -- quot )
 119   [
 120     dup empty? [
 121       drop f
 122     ] [
 123       0 over nth dup
 124       ?min ?max between? [
 125          [ 1 tail-slice ] dip <parse-result>
 126       ] [
 127         2drop f
 128       ] if
 129     ] if
 130   ] ;
 131
 132 M: range-parser compile ( parser -- quot )
 133   T{ range-parser _ ?min ?max } range-pattern match-replace ;
 134
 135 TUPLE: seq-parser parsers ;
 136
 137 : seq-pattern ( -- quot )
 138   [
 139     dup [
 140       dup parse-result-remaining ?quot call [
 141         [ parse-result-remaining swap set-parse-result-remaining ] 2keep
 142         parse-result-ast dup ignore = [
 143           drop
 144         ] [
 145           swap [ parse-result-ast push ] keep
 146         ] if
 147       ] [
 148         drop f
 149       ] if*
 150     ] [
 151       drop f
 152     ] if
 153   ] ;
 154
 155 M: seq-parser compile ( parser -- quot )
 156   [
 157     [ V{ } clone <parse-result> ] %
 158     seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
 159   ] [ ] make ;
 160
 161 TUPLE: choice-parser parsers ;
 162
 163 : choice-pattern ( -- quot )
 164   [
 165     dup [
 166
 167     ] [
 168       drop dup ?quot call
 169     ] if
 170   ] ;
 171
 172 M: choice-parser compile ( parser -- quot )
 173   [
 174     f ,
 175     choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
 176     \ nip ,
 177   ] [ ] make ;
 178
 179 TUPLE: repeat0-parser p1 ;
 180
 181 : (repeat0) ( quot result -- result )
 182   2dup parse-result-remaining swap call [
 183     [ parse-result-remaining swap set-parse-result-remaining ] 2keep
 184     parse-result-ast swap [ parse-result-ast push ] keep
 185     (repeat0)
 186  ] [
 187     nip
 188   ] if* ; inline
 189
 190 : repeat0-pattern ( -- quot )
 191   [
 192     ?quot swap (repeat0)
 193   ] ;
 194
 195 M: repeat0-parser compile ( parser -- quot )
 196   [
 197     [ V{ } clone <parse-result> ] %
 198     repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
 199   ] [ ] make ;
 200
 201 TUPLE: repeat1-parser p1 ;
 202
 203 : repeat1-pattern ( -- quot )
 204   [
 205     ?quot swap (repeat0) [
 206       dup parse-result-ast empty? [
 207         drop f
 208       ] when
 209     ] [
 210       f
 211     ] if*
 212   ] ;
 213
 214 M: repeat1-parser compile ( parser -- quot )
 215   [
 216     [ V{ } clone <parse-result> ] %
 217     repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
 218   ] [ ] make ;
 219
 220 TUPLE: optional-parser p1 ;
 221
 222 : optional-pattern ( -- quot )
 223   [
 224     dup ?quot call swap f <parse-result> or
 225   ] ;
 226
 227 M: optional-parser compile ( parser -- quot )
 228   optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
 229
 230 TUPLE: ensure-parser p1 ;
 231
 232 : ensure-pattern ( -- quot )
 233   [
 234     dup ?quot call [
 235       ignore <parse-result>
 236     ] [
 237       drop f
 238     ] if
 239   ] ;
 240
 241 M: ensure-parser compile ( parser -- quot )
 242   ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
 243
 244 TUPLE: ensure-not-parser p1 ;
 245
 246 : ensure-not-pattern ( -- quot )
 247   [
 248     dup ?quot call [
 249       drop f
 250     ] [
 251       ignore <parse-result>
 252     ] if
 253   ] ;
 254
 255 M: ensure-not-parser compile ( parser -- quot )
 256   ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
 257
 258 TUPLE: action-parser p1 quot ;
 259
 260 MATCH-VARS: ?action ;
 261
 262 : action-pattern ( -- quot )
 263   [
 264     ?quot call dup [
 265       dup parse-result-ast ?action call
 266       swap [ set-parse-result-ast ] keep
 267     ] when
 268   ] ;
 269
 270 M: action-parser compile ( parser -- quot )
 271   { action-parser-p1 action-parser-quot } get-slots [ compile ] dip
 272   2array { ?quot ?action } action-pattern match-replace ;
 273
 274 : left-trim-slice ( string -- string )
 275   #! Return a new string without any leading whitespace
 276   #! from the original string.
 277   dup empty? [
 278     dup first blank? [ 1 tail-slice left-trim-slice ] when
 279   ] unless ;
 280
 281 TUPLE: sp-parser p1 ;
 282
 283 M: sp-parser compile ( parser -- quot )
 284   [
 285     \ left-trim-slice , sp-parser-p1 compile %
 286   ] [ ] make ;
 287
 288 TUPLE: delay-parser quot ;
 289
 290 M: delay-parser compile ( parser -- quot )
 291   [
 292     delay-parser-quot % \ compile , \ call ,
 293   ] [ ] make ;
 294
 295 PRIVATE>
 296
 297 MEMO: token ( string -- parser )
 298   token-parser construct-boa init-parser ;
 299
 300 : satisfy ( quot -- parser )
 301   satisfy-parser construct-boa init-parser ;
 302
 303 MEMO: range ( min max -- parser )
 304   range-parser construct-boa init-parser ;
 305
 306 : seq ( seq -- parser )
 307   seq-parser construct-boa init-parser ;
 308
 309 : choice ( seq -- parser )
 310   choice-parser construct-boa init-parser ;
 311
 312 MEMO: repeat0 ( parser -- parser )
 313   repeat0-parser construct-boa init-parser ;
 314
 315 MEMO: repeat1 ( parser -- parser )
 316   repeat1-parser construct-boa init-parser ;
 317
 318 MEMO: optional ( parser -- parser )
 319   optional-parser construct-boa init-parser ;
 320
 321 MEMO: ensure ( parser -- parser )
 322   ensure-parser construct-boa init-parser ;
 323
 324 MEMO: ensure-not ( parser -- parser )
 325   ensure-not-parser construct-boa init-parser ;
 326
 327 : action ( parser quot -- parser )
 328   action-parser construct-boa init-parser ;
 329
 330 MEMO: sp ( parser -- parser )
 331   sp-parser construct-boa init-parser ;
 332
 333 MEMO: hide ( parser -- parser )
 334   [ drop ignore ] action ;
 335
 336 MEMO: delay ( parser -- parser )
 337   delay-parser construct-boa init-parser ;
 338
 339 MEMO: list-of ( items separator -- parser )
 340   hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ;
 341
 342 MEMO: 'digit' ( -- parser )
 343   [ digit? ] satisfy [ digit> ] action ;
 344
 345 MEMO: 'integer' ( -- parser )
 346   'digit' repeat1 [ 10 swap digits>integer ] action ;
 347
 348 MEMO: 'string' ( -- parser )
 349   [
 350     [ CHAR: " = ] satisfy hide ,
 351     [ CHAR: " = not ] satisfy repeat0 ,
 352     [ CHAR: " = ] satisfy hide ,
 353   ] { } make seq [ first >string ] action ;