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