From 7060a5905f89098f265afe0ffcf80b47ff743499 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:44:06 -0500
Subject: [PATCH] add take-sequence to state parser

---
 extra/html/parser/state/state-tests.factor | 18 ++++++++++
 extra/html/parser/state/state.factor       | 39 +++++++++++++---------
 2 files changed, 42 insertions(+), 15 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 835b54d0d3..6766cfddc2 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -34,3 +34,21 @@ IN: html.parser.state.tests
 
 [ { 1 2 } ]
 [ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ "ab" ]
+[ "abcd" <state-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <state-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+    "abcd" <state-parser>
+    [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <state-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 3f899446c0..85b0b0fbb9 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -12,32 +12,32 @@ TUPLE: state-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
-: state-parser-nth ( n state -- char/f )
+: state-parser-nth ( n state-parser -- char/f )
     sequence>> ?nth ; inline
 
-: current ( state -- char/f )
+: current ( state-parser -- char/f )
     [ n>> ] keep state-parser-nth ; inline
 
-: previous ( state -- char/f )
+: previous ( state-parser -- char/f )
     [ n>> 1 - ] keep state-parser-nth ; inline
 
-: peek-next ( state -- char/f )
+: peek-next ( state-parser -- char/f )
     [ n>> 1 + ] keep state-parser-nth ; inline
 
-: next ( state -- state )
+: next ( state-parser -- state-parser )
     [ 1 + ] change-n ; inline
 
-: get+increment ( state -- char/f )
+: get+increment ( state-parser -- char/f )
     [ current ] [ next drop ] bi ; inline
 
-:: skip-until ( state quot: ( obj -- ? ) -- )
-    state current [
-        state quot call [ state next quot skip-until ] unless
+:: skip-until ( state-parser quot: ( obj -- ? ) -- )
+    state-parser current [
+        state-parser quot call [ state-parser next quot skip-until ] unless
     ] when ; inline recursive
 
-: state-parse-end? ( state -- ? ) peek-next not ;
+: state-parse-end? ( state-parser -- ? ) peek-next not ;
 
-: take-until ( state quot: ( obj -- ? ) -- sequence/f )
+: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
     over state-parse-end? [
         2drop f
     ] [
@@ -46,9 +46,18 @@ TUPLE: state-parser sequence n ;
         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
     ] if ; inline
 
-: take-while ( state quot: ( obj -- ? ) -- sequence/f )
+: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
     [ not ] compose take-until ; inline
 
+:: take-sequence ( state-parser sequence -- obj/f )
+    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
+    sequence sequence= [
+        sequence
+        state-parser [ sequence length + ] change-n drop
+    ] [
+        f
+    ] if ;
+
 :: take-until-sequence ( state-parser sequence -- sequence' )
     sequence length <growing-circular> :> growing
     state-parser
@@ -60,13 +69,13 @@ TUPLE: state-parser sequence n ;
     growing length 1- - head
     state-parser next drop ;
     
-: skip-whitespace ( state -- state )
+: skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
-: take-rest ( state -- sequence )
+: take-rest ( state-parser -- sequence )
     [ drop f ] take-until ; inline
 
-: take-until-object ( state obj -- sequence )
+: take-until-object ( state-parser obj -- sequence )
     '[ current _ = ] take-until ;
 
 : state-parse ( sequence quot -- )