Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / extra / sequence-parser / sequence-parser.factor

diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
index ad49982d8898f2148ca91192bebe33ebd9b7bdba..d14a77057f9bdb75988168b98aff8906da5b6314 100644 (file)
--- a/extra/sequence-parser/sequence-parser.factor
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
 ! 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 ;
+USING: accessors circular combinators.short-circuit fry io
+kernel locals math math.order sequences sorting.functor
+sorting.slots unicode.categories ;
 IN: sequence-parser
 
 TUPLE: sequence-parser sequence n ;
@@ -12,6 +12,12 @@ TUPLE: sequence-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+    sequence-parser n>> :> n
+    sequence-parser quot call [
+        n sequence-parser (>>n) f
+    ] unless* ; inline
+
 : offset  ( sequence-parser offset -- char/f )
     swap
     [ n>> + ] [ sequence>> ?nth ] bi ; inline
@@ -28,12 +34,15 @@ TUPLE: sequence-parser sequence n ;
 : advance* ( sequence-parser -- )
     advance drop ; inline
 
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
 : get+increment ( sequence-parser -- char/f )
     [ current ] [ advance drop ] bi ; inline
 
 :: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
     sequence-parser current [
-        sequence-parser quot call [ sequence-parser advance quot skip-until ] unless
+        sequence-parser quot call
+        [ sequence-parser advance quot skip-until ] unless
     ] when ; inline recursive
 
 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
@@ -44,7 +53,7 @@ TUPLE: sequence-parser sequence n ;
     ] [
         [ drop n>> ]
         [ skip-until ]
-        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
     ] if ; inline
 
 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
@@ -66,26 +75,45 @@ 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 length 1- - head
-    sequence-parser advance drop ;
-    
+    growing sequence sequence= [
+        found dup length
+        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 ;
 
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+    [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
 : take-rest-slice ( sequence-parser -- sequence/f )
     [ sequence>> ] [ n>> ] bi
     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 
 : take-rest ( sequence-parser -- sequence )
-    [ take-rest-slice ] [ sequence>> like ] bi ;
+    [ take-rest-slice ] [ sequence>> like ] bi f like ;
 
 : take-until-object ( sequence-parser obj -- sequence )
     '[ current _ = ] take-until ;
@@ -93,34 +121,28 @@ TUPLE: sequence-parser sequence n ;
 : parse-sequence ( sequence quot -- )
     [ <sequence-parser> ] dip call ; inline
 
-:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
-    sequence-parser n>> :> start-n
-    sequence-parser advance
-    [
-        {
-            [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
-            [ current quote-char = not ]
-        } 1||
-    ] take-while :> string
-    sequence-parser current quote-char = [
-        sequence-parser advance* string
+: take-integer ( sequence-parser -- n/f )
+    [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+    n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+        sequence-parser take-rest
     ] [
-        start-n sequence-parser (>>n) f
+        sequence-parser n>> dup n + sequence-parser sequence>> subseq
+        sequence-parser [ n + ] change-n drop
     ] if ;
 
-: (take-token) ( sequence-parser -- string )
-    skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+    { length>=< <=> } sort-by ;
 
-:: take-token* ( sequence-parser escape-char quote-char -- string/f )
-    sequence-parser skip-whitespace
-    dup current {
-        { quote-char [ escape-char quote-char take-quoted-string ] }
-        { f [ drop f ] }
-        [ drop (take-token) ]
-    } case ;
+: take-first-matching ( sequence-parser seq -- seq )
+    swap
+    '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 
-: take-token ( sequence-parser -- string/f )
-    CHAR: \ CHAR: " take-token* ;
+: take-longest ( sequence-parser seq -- seq )
+    sort-tokens take-first-matching ;
 
 : write-full ( sequence-parser -- ) sequence>> write ;
 : write-rest ( sequence-parser -- ) take-rest write ;