Add semantic parser

extra/peg/peg-docs.factor

@@ -95,6 +95,19 @@ HELP: optional
     "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
     "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
 
+HELP: semantic
+{ $values 
+  { "parser" "a parser" } 
+  { "quot" "a quotation with stack effect ( object -- bool )" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
+    "the AST produced by 'p1' on the stack returns true." }
+{ $examples 
+  { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } 
+  { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } 
+} ;
+
 HELP: ensure
 { $values 
   { "parser" "a parser" } 

extra/peg/peg.factor

@@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
 M: optional-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot optional-pattern match-replace ;
 
+TUPLE: semantic-parser p1 quot ;
+
+MATCH-VARS: ?parser ;
+
+: semantic-pattern ( -- quot )
+  [
+    ?parser [
+      dup parse-result-ast ?quot call [ drop f ] unless
+    ] [
+      f
+    ] if*
+  ] ;
+
+M: semantic-parser (compile) ( parser -- quot )
+  [ p1>> compiled-parser ] [ quot>> ] bi  
+  2array { ?parser ?quot } semantic-pattern match-replace ;
+
 TUPLE: ensure-parser p1 ;
 
 : ensure-pattern ( -- quot )
@@ -546,6 +563,9 @@ PRIVATE>
 : optional ( parser -- parser )
   optional-parser construct-boa init-parser ;
 
+: semantic ( parser quot -- parser )
+  semantic-parser construct-boa init-parser ;
+
 : ensure ( parser -- parser )
   ensure-parser construct-boa init-parser ;