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