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 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 CONSTANT: just-pattern
  11   [
  12     dup [
  13       dup remaining>> empty? [ drop f ] unless
  14     ] when
  15   ]
  16
  17
  18 M: just-parser (compile) ( parser -- quot )
  19   p1>> compile-parser-quot just-pattern compose ;
  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   [ over 2seq ] dip [ 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     [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice
  55   ] if ;
  56
  57 : at-least-n ( parser n -- parser' )
  58   dupd exactly-n swap repeat0 2seq
  59   [ flatten-vectors ] action ;
  60
  61 : from-m-to-n ( parser m n -- parser' )
  62   [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq
  63   [ flatten-vectors ] action ;
  64
  65 : pack ( begin body end -- parser )
  66   [ hide ] 2dip hide 3seq [ first ] action ;
  67
  68 : surrounded-by ( parser begin end -- parser' )
  69   [ token ] bi@ swapd pack ;
  70
  71 : 'digit' ( -- parser )
  72   [ digit? ] satisfy [ digit> ] action ;
  73
  74 : 'integer' ( -- parser )
  75   'digit' repeat1 [ 10 digits>integer ] action ;
  76
  77 : 'string' ( -- parser )
  78   [
  79     [ CHAR: " = ] satisfy hide ,
  80     [ CHAR: " = not ] satisfy repeat0 ,
  81     [ CHAR: " = ] satisfy hide ,
  82   ] seq* [ first >string ] action ;
  83
  84 : (range-pattern) ( pattern -- string )
  85   #! Given a range pattern, produce a string containing
  86   #! all characters within that range.
  87   [
  88     any-char ,
  89     [ CHAR: - = ] satisfy hide ,
  90     any-char ,
  91   ] seq* [
  92     first2 [a,b] >string
  93   ] action
  94   replace ;
  95
  96 : range-pattern ( pattern -- parser )
  97   #! 'pattern' is a set of characters describing the
  98   #! parser to be produced. Any single character in
  99   #! the pattern matches that character. If the pattern
 100   #! begins with a ^ then the set is negated (the element
 101   #! matches any character not in the set). Any pair of
 102   #! characters separated with a dash (-) represents the
 103   #! range of characters from the first to the second,
 104   #! inclusive.
 105   dup first CHAR: ^ = [
 106     rest (range-pattern) [ member? not ] curry satisfy
 107   ] [
 108     (range-pattern) [ member? ] curry satisfy
 109   ] if ;