basis/peg/parsers/parsers.factor

   1 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors fry kernel literals make math math.parser
   4 ranges peg peg.private peg.search sequences splitting strings
   5 unicode vectors ;
   6 IN: peg.parsers
   7
   8 <PRIVATE
   9
  10 TUPLE: just-parser p1 ;
  11
  12 M: just-parser parser-quot
  13     p1>> execute-parser-quot [
  14         dup [
  15             dup remaining>> empty? [ drop f ] unless
  16         ] when
  17     ] compose ;
  18
  19 PRIVATE>
  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
  28     [ 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 CONSTANT: epsilon $[ V{ } token ]
  38
  39 CONSTANT: any-char $[ [ drop t ] satisfy ]
  40
  41 <PRIVATE
  42
  43 : flatten-vectors ( pair -- vector )
  44     first2 append! ;
  45
  46 PRIVATE>
  47
  48 : exactly-n ( parser n -- parser' )
  49     swap <repetition> seq ;
  50
  51 : at-most-n ( parser n -- parser' )
  52     [
  53         drop epsilon
  54     ] [
  55         [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice
  56     ] if-zero ;
  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     [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq
  64     [ flatten-vectors ] action ;
  65
  66 : pack ( begin body end -- parser )
  67     [ hide ] [ ] [ hide ] tri* 3seq [ first ] action ;
  68
  69 : surrounded-by ( parser begin end -- parser' )
  70     [ token ] bi@ swapd pack ;
  71
  72 : digit-parser ( -- parser )
  73     [ digit? ] satisfy [ digit> ] action ;
  74
  75 : integer-parser ( -- parser )
  76     [ digit? ] satisfy repeat1 [ string>number ] action ;
  77
  78 : string-parser ( -- 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 peg-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     "^" ?head [
 106         (range-pattern) dup length 1 =
 107         [ first '[ _ = ] ] [ '[ _ member? ] ] if
 108     ] [
 109         [ [ not ] compose ] when satisfy
 110     ] bi* ;