basis/peg/parsers/parsers.factor

   1 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences strings namespaces math assocs shuffle
   4      vectors arrays math.parser accessors
   5      unicode.categories sequences.deep peg peg.private
   6      peg.search math.ranges words ;
   7 IN: peg.parsers
   8
   9 TUPLE: just-parser p1 ;
  10
  11 : just-pattern
  12   [
  13     execute dup [
  14       dup remaining>> empty? [ drop f ] unless
  15     ] when
  16   ] ;
  17
  18
  19 M: just-parser (compile) ( parser -- quot )
  20   p1>> compile-parser just-pattern curry ;
  21
  22 : just ( parser -- parser )
  23   just-parser boa wrap-peg ;
  24
  25 : 1token ( ch -- parser ) 1string token ;
  26
  27 : (list-of) ( items separator repeat1? -- parser )
  28   >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
  29   [ unclip 1vector swap first append ] action ;
  30
  31 : list-of ( items separator -- parser )
  32   hide f (list-of) ;
  33
  34 : list-of-many ( items separator -- parser )
  35   hide t (list-of) ;
  36
  37 : epsilon ( -- parser ) V{ } token ;
  38
  39 : any-char ( -- parser ) [ drop t ] satisfy ;
  40
  41 <PRIVATE
  42
  43 : flatten-vectors ( pair -- vector )
  44   first2 over push-all ;
  45
  46 PRIVATE>
  47
  48 : exactly-n ( parser n -- parser' )
  49   swap <repetition> seq ;
  50
  51 : at-most-n ( parser n -- parser' )
  52   dup zero? [
  53     2drop epsilon
  54   ] [
  55     2dup exactly-n
  56     -rot 1- at-most-n 2choice
  57   ] if ;
  58
  59 : at-least-n ( parser n -- parser' )
  60   dupd exactly-n swap repeat0 2seq
  61   [ flatten-vectors ] action ;
  62
  63 : from-m-to-n ( parser m n -- parser' )
  64   >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
  65   [ flatten-vectors ] action ;
  66
  67 : pack ( begin body end -- parser )
  68   >r >r hide r> r> hide 3seq [ first ] action ;
  69
  70 : surrounded-by ( parser begin end -- parser' )
  71   [ token ] bi@ swapd pack ;
  72
  73 : 'digit' ( -- parser )
  74   [ digit? ] satisfy [ digit> ] action ;
  75
  76 : 'integer' ( -- parser )
  77   'digit' repeat1 [ 10 digits>integer ] action ;
  78
  79 : 'string' ( -- parser )
  80   [
  81     [ CHAR: " = ] satisfy hide ,
  82     [ CHAR: " = not ] satisfy repeat0 ,
  83     [ CHAR: " = ] satisfy hide ,
  84   ] seq* [ first >string ] action ;
  85
  86 : (range-pattern) ( pattern -- string )
  87   #! Given a range pattern, produce a string containing
  88   #! all characters within that range.
  89   [
  90     any-char ,
  91     [ CHAR: - = ] satisfy hide ,
  92     any-char ,
  93   ] seq* [
  94     first2 [a,b] >string
  95   ] action
  96   replace ;
  97
  98 : range-pattern ( pattern -- parser )
  99   #! 'pattern' is a set of characters describing the
 100   #! parser to be produced. Any single character in
 101   #! the pattern matches that character. If the pattern
 102   #! begins with a ^ then the set is negated (the element
 103   #! matches any character not in the set). Any pair of
 104   #! characters separated with a dash (-) represents the
 105   #! range of characters from the first to the second,
 106   #! inclusive.
 107   dup first CHAR: ^ = [
 108     rest (range-pattern) [ member? not ] curry satisfy
 109   ] [
 110     (range-pattern) [ member? ] curry satisfy
 111   ] if ;