From cc3e56c1228ebac0e9ea1516bb5b97edb10be6be Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 19:20:38 -0600
Subject: [PATCH] Add generic to get a predicate out of a parser-combinator

---
 .../parser-combinators-tests.factor           |  4 +++
 .../parser-combinators.factor                 | 27 ++++++++++++++++++-
 2 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor
index 59ef383c87..546eb84c98 100644
--- a/extra/parser-combinators/parser-combinators-tests.factor
+++ b/extra/parser-combinators/parser-combinators-tests.factor
@@ -151,3 +151,7 @@ IN: scratchpad
 ] unit-test
 
 
+[ "a"  "a" token <!> parse-1 ] unit-test-fails
+[ t ] [ "b"  "a" token <!> parse-1 >boolean ] unit-test
+[ t ] [ "b"  "ab" token <!> parse-1 >boolean ] unit-test
+
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index 04032db19f..7256ad18dd 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lazy-lists promises kernel sequences strings math
-arrays splitting ;
+arrays splitting quotations combinators ;
 IN: parser-combinators
 
 ! Parser combinator protocol
@@ -21,6 +21,15 @@ TUPLE: parse-result parsed unparsed ;
 
 C: <parse-result> parse-result
 
+: parse-result-parsed-slice ( parse-result -- slice )
+    dup parse-result-parsed empty? [
+        parse-result-unparsed 0 0 rot <slice>
+    ] [
+        dup parse-result-unparsed
+        dup slice-from [ rot parse-result-parsed length - ] keep
+        rot slice-seq <slice>
+    ] if ;
+
 TUPLE: token-parser string ;
 
 C: token token-parser ( string -- parser )
@@ -280,3 +289,19 @@ LAZY: <(+)> ( parser -- parser )
 
 LAZY: surrounded-by ( parser start end -- parser' )
     [ token ] 2apply swapd pack ;
+
+: predicates>cond ( seq -- quot )
+    #! Takes an array of quotation predicates/objects and makes a cond
+    #! Makes a predicate of each obj like so:  [ dup obj = ]
+    #! Leaves quotations alone
+    #! The cond returns a boolean, t if one of the predicates matches
+    [
+        dup callable? [ [ = ] curry ] unless
+        [ dup ] swap compose [ drop t ] 2array
+    ] map { [ t ] [ drop f ] } add [ cond ] curry ;
+
+GENERIC: parser>predicate ( obj -- quot )
+
+M: satisfy-parser parser>predicate ( obj -- quot )
+    satisfy-parser-quot ;
+