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