improve sequence-parser

extra/sequence-parser/sequence-parser-tests.factor

@@ -17,13 +17,39 @@ IN: sequence-parser.tests
     ] parse-sequence
 ] unit-test
 
-[ "foo " " bar" ]
+[ "foo " "and bar" ]
 [
     "foo and bar" [
         [ "and" take-until-sequence ] [ take-rest ] bi 
     ] parse-sequence
 ] unit-test
 
+[ "foo " " bar" ]
+[
+    "foo and bar" [
+        [ "and" take-until-sequence ]
+        [ "and" take-sequence drop ]
+        [ take-rest ] tri
+    ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+    "foo and bar" [
+        [ "and" take-until-sequence* ]
+        [ take-rest ] bi
+    ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+    "aaaa" <sequence-parser>
+    [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
 [ 6 ]
 [
     "      foo   " [ skip-whitespace n>> ] parse-sequence
@@ -32,9 +58,6 @@ IN: sequence-parser.tests
 [ { 1 2 } ]
 [ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
 
-[ { 1 2 } ]
-[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
-
 [ "ab" ]
 [ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
 
@@ -102,3 +125,16 @@ IN: sequence-parser.tests
 
 [ f ]
 [ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ 1234 ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+    "yes1234f" <sequence-parser>
+    [ take-integer drop ] [ "yes" take-sequence ] bi 
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test

extra/sequence-parser/sequence-parser.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
 unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting ;
+make combinators io splitting math.parser ;
 IN: sequence-parser
 
 TUPLE: sequence-parser sequence n ;
@@ -66,16 +66,32 @@ TUPLE: sequence-parser sequence n ;
         f
     ] if ;
 
-:: take-until-sequence ( sequence-parser sequence -- sequence' )
+: take-sequence* ( sequence-parser sequence -- )
+    take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+    sequence-parser n>> :> saved
     sequence length <growing-circular> :> growing
     sequence-parser
     [
         current growing push-growing-circular
         sequence growing sequence=
     ] take-until :> found
-    found dup length
+    growing sequence sequence= [
-    growing length 1- - head
+        found dup length
-    sequence-parser advance drop ;
+        growing length 1- - head
+        sequence-parser [ growing length - 1 + ] change-n drop
+        ! sequence-parser advance drop
+    ] [
+        saved sequence-parser (>>n)
+        f
+    ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+    sequence-parser sequence take-until-sequence :> out
+    out [
+        sequence-parser [ sequence length + ] change-n drop
+    ] when out ;
 
 : skip-whitespace ( sequence-parser -- sequence-parser )
     [ [ current blank? not ] take-until drop ] keep ;
@@ -122,5 +138,16 @@ TUPLE: sequence-parser sequence n ;
 : take-token ( sequence-parser -- string/f )
     CHAR: \ CHAR: " take-token* ;
 
+: take-integer ( sequence-parser -- n/f )
+    [ current digit? ] take-while string>number ;
+
+:: take-n ( sequence-parser n -- seq/f )
+    n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+        f
+    ] [
+        sequence-parser n>> dup n + sequence-parser sequence>> subseq
+        sequence-parser [ n + ] change-n drop
+    ] if ;
+
 : write-full ( sequence-parser -- ) sequence>> write ;
 : write-rest ( sequence-parser -- ) take-rest write ;