Add satisfy parser in peg

extra/peg/peg-docs.factor

@@ -20,6 +20,15 @@ HELP: token
 { $description 
     "Returns a parser that matches the given string." } ;
 
+HELP: satisfy
+{ $values 
+  { "quot" "a quotation" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that calls the quotation on the first character of the input string, "
+    "succeeding if that quotation returns true. The AST is the character from the string." } ;
+
 HELP: range
 { $values 
   { "min" "a character" } 

extra/peg/peg-tests.factor

@@ -136,4 +136,12 @@ IN: temporary
 
 { f } [
   "b" "a" token [ drop 1 ] action parse 
+] unit-test
+
+{ f } [ 
+  "b" [ CHAR: a = ] satisfy parse 
+] unit-test
+
+{ CHAR: a } [ 
+  "a" [ CHAR: a = ] satisfy parse parse-result-ast
 ] unit-test

extra/peg/peg.factor

@@ -33,6 +33,19 @@ M: token-parser parse ( state parser -- result )
     2drop f
   ] if ;
 
+TUPLE: satisfy-parser quot ;
+
+M: satisfy-parser parse ( state parser -- result )
+  over empty? [
+    2drop f 
+  ] [
+    satisfy-parser-quot [ unclip-slice dup ] dip call [  
+      <parse-result>
+    ] [
+      2drop f
+    ] if
+  ] if ;
+
 TUPLE: range-parser min max ;
 
 M: range-parser parse ( state parser -- result )
@@ -148,6 +161,9 @@ PRIVATE>
 : token ( string -- parser )
   token-parser construct-boa init-parser ;      
 
+: satisfy ( quot -- parser )
+  satisfy-parser construct-boa init-parser ;
+
 : range ( min max -- parser )
   range-parser construct-boa init-parser ;