From 129f68d428f548bb20f28272718aa77074704510 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Wed, 21 Nov 2007 16:06:02 +1300
Subject: [PATCH] add ensure parser

---
 extra/peg/peg-tests.factor |  8 ++++++++
 extra/peg/peg.factor       | 16 +++++++++++++++-
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index b10fcb8e55..b7977285c4 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -104,4 +104,12 @@ IN: temporary
 
 { f } [ 
   "cb" 0 <parse-state> "a" token optional "b" token 2array seq parse  
+] unit-test
+
+{ V{ CHAR: a CHAR: b } } [
+  "ab" 0 <parse-state> "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
+] unit-test
+
+{ f } [
+  "bb" 0 <parse-state> "a" token ensure CHAR: a CHAR: z range 2array seq parse 
 ] unit-test
\ No newline at end of file
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index e2f0cfd1b2..239af02d26 100644
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -3,6 +3,8 @@
 USING: kernel sequences strings namespaces math assocs shuffle vectors combinators.lib ;
 IN: peg
 
+SYMBOL: ignore 
+
 TUPLE: parse-state input cache ;
 
 : <parse-state> ( input index -- state )
@@ -71,7 +73,7 @@ TUPLE: seq-parser parsers ;
 : do-seq-parser ( result parser -- result )
   [ dup parse-result-remaining ] dip parse [
     [ parse-result-remaining swap set-parse-result-remaining ] 2keep  
-    parse-result-ast swap [ parse-result-ast push ] keep
+    parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
   ] [
     drop f
   ] if* ;
@@ -148,3 +150,15 @@ M: optional-parser parse ( state parser -- result )
 
 : optional ( parser -- parser )
   optional-parser construct-boa init-parser ;
+
+TUPLE: ensure-parser p1 ;
+
+M: ensure-parser parse ( state parser -- result )
+   dupd ensure-parser-p1 parse [
+     ignore <parse-result>  
+   ] [
+     drop f
+   ] if ;
+
+: ensure ( parser -- parser )
+  ensure-parser construct-boa init-parser ;