modern: Fix FOO>bar and remove duplicated words.

extra/find/extras/extras.factor

@@ -2,27 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators combinators.extras
 combinators.smart fry generalizations kernel literals locals
-macros make math math.private multiline namespaces quotations
+macros make math math.private modern.slices multiline namespaces
-sequences sequences.deep sequences.extras
+quotations sequences sequences.deep sequences.extras
 sequences.generalizations sequences.private shuffle
 stack-checker.transforms strings unicode words ;
 IN: find.extras
 
-: >strings ( seq -- str )
-    [ dup slice? [ >string ] when ] deep-map ;
-
-: matching-delimiter ( ch -- ch' )
-    H{
-        { char: \( char: \) }
-        { char: \[ char: \] }
-        { char: \{ char: \} }
-        { char: < char: > }
-        { char: \: char: \; }
-    } ?at drop ;
-
-: matching-delimiter-string ( string -- string' )
-    [ matching-delimiter ] map ;
-
 SYMBOL: delimiter-stack
 
 : with-delimiter-stack ( string quot -- seq )

extra/modern/modern-tests.factor

@@ -26,9 +26,13 @@ IN: modern.tests
 } [ ":asdf:" string>literals >strings ] unit-test
 
 {
-    { { "one:" "1" } }
+    { { "one:" { "1" } } }
 } [ "one: 1" string>literals >strings ] unit-test
 
+{
+    { { "two::" { "1" "2" } } }
+} [ "two:: 1 2" string>literals >strings ] unit-test
+
 {
     { "1" ":>" "one" }
 } [ "1 :> one" string>literals >strings ] unit-test
@@ -96,16 +100,16 @@ IN: modern.tests
     { { "foo\\bar{" { "1" } "}" } }
 } [ "foo\\bar{ 1 }" string>literals >strings ] unit-test
 
-{ { { "char:" "\\{" } } } [ "char: \\{" string>literals >strings ] unit-test
+{ { { "char:" { "\\{" } } } } [ "char: \\{" string>literals >strings ] unit-test
 [ "char: {" string>literals >strings ] must-fail
 [ "char: [" string>literals >strings ] must-fail
 [ "char: {" string>literals >strings ] must-fail
 [ "char: \"" string>literals >strings ] must-fail
-{ { { "char:" "\\\\" } } } [ "char: \\\\" string>literals >strings ] unit-test
+{ { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test
 
 [ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually
 
-{ { { "\\" "(" } } } [ "\\ (" string>literals >strings ] unit-test
+{ { { "\\" { "(" } } } } [ "\\ (" string>literals >strings ] unit-test
 
 { { "\\[[" } } [ "\\[[" string>literals >strings ] unit-test
 { { "\\[=[" } } [ "\\[=[" string>literals >strings ] unit-test
@@ -177,3 +181,24 @@ IN: modern.tests
         { "<FOO:" { "foo" { "BAR:" { "bar" } } } ";FOO>" }
     }
 } [ "<FOO: foo BAR: bar ;FOO>" string>literals >strings ] unit-test
+
+
+{
+    {
+        {
+            {
+                "foo::"
+                {
+                    {
+                        { "<FOO" { } "FOO>" }
+                        { "[" { "0" } "]" }
+                        { "[" { "1" } "]" }
+                        { "[" { "2" } "]" }
+                        { "[" { "3" } "]" }
+                    }
+                    { { "<BAR" { } "BAR>" } }
+                }
+            }
+        }
+    }
+} [ "foo:: <FOO FOO>[ 0 ][ 1 ][ 2 ][ 3 ] <BAR BAR>" string>literals >strings ] unit-test

extra/modern/modern.factor

@@ -46,13 +46,14 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se
 : read-double-matched-bracket ( n string tag ch -- n' string seq ) char: \[ read-double-matched ;
 : read-double-matched-brace ( n string tag ch -- n' string seq ) char: \{ read-double-matched ;
 
+DEFER: (lex-factor)
 DEFER: lex-factor
 ERROR: lex-expected-but-got-eof n string expected ;
 ! For implementing [ { (
 : lex-until ( n string tag-sequence -- n' string payload )
     3dup '[
         [
-            lex-factor dup f like [ , ] when* [
+            (lex-factor) dup f like [ , ] when* [
                 dup [
                     ! } gets a chance, but then also full seq { } after recursion...
                     [ _ ] dip '[ _ sequence= ] any? not
@@ -68,7 +69,7 @@ ERROR: lex-expected-but-got-eof n string expected ;
 : lex-colon-until ( n string tag-sequence -- n' string payload )
     '[
         [
-            lex-factor dup f like [ , ] when* [
+            (lex-factor) dup f like [ , ] when* [
                 dup [
                     ! } gets a chance, but then also full seq { } after recursion...
                     [ _ ] dip '[ _ sequence= ] any? not
@@ -226,7 +227,7 @@ ERROR: no-backslash-payload n string slice ;
 ! If the slice is 0 width, we stopped on whitespace.
 ! Advance the index and read again!
 : read-token-or-whitespace ( n string slice -- n' string slice/f )
-    dup length 0 = [ [ 1 + ] 2dip drop lex-factor ] when ;
+    dup length 0 = [ [ 1 + ] 2dip drop (lex-factor) ] when ;
 
 ERROR: mismatched-terminator n string slice ;
 : read-terminator ( n string slice -- n' string slice ) ;
@@ -236,7 +237,7 @@ ERROR: mismatched-terminator n string slice ;
 : ?length-and-string ( length/f string -- length string )
     over [ nip [ length ] [ ] bi ] unless ; inline
 
-: (lex-factor) ( n/f string slice/f ch/f -- n'/f string literal )
+: ((lex-factor)) ( n/f string slice/f ch/f -- n'/f string literal )
     {
         { char: \" [ read-string ] }
         { char: \! [ read-exclamation ] }
@@ -267,13 +268,15 @@ ERROR: mismatched-terminator n string slice ;
             ] when
         ] }
         { char: > [
-            [ slice-til-whitespace drop ] dip span-slices
+            [ [ char: > = not ] slice-until ] dip merge-slices
             dup section-close? [
                 strict-upper get [
                     [ ?length-and-string ] dip
                     length swap [ - ] dip f strict-upper off
                 ] when
-            ] when
+            ] [
+                [ slice-til-whitespace drop ] dip ?span-slices
+            ] if
         ] }
         { char: \[ [ read-bracket ] }
         { char: \{ [ read-brace ] }
@@ -287,7 +290,7 @@ ERROR: mismatched-terminator n string slice ;
         { f [ ] }
     } case ;
 
-: lex-factor ( n/f string -- n'/f string literal )
+: (lex-factor) ( n/f string -- n'/f string literal )
     over [
         ! skip-whitespace
         "\"\\!:[{(]})<>\s\r\n" slice-til-either
@@ -302,10 +305,10 @@ ERROR: mismatched-terminator n string slice ;
                 drop
                 dup "\\" sequence= [ read-backslash ] [ merge-slice-til-whitespace ] if
             ] [
-                over "\\" tail? [ drop read-backslash ] [ (lex-factor) ] if
+                over "\\" tail? [ drop read-backslash ] [ ((lex-factor)) ] if
             ] if
         ] [
-            (lex-factor)
+            ((lex-factor))
         ] if
     ] [
         f
@@ -314,23 +317,27 @@ ERROR: mismatched-terminator n string slice ;
 ERROR: compound-syntax-disallowed seq i obj ;
 : check-for-compound-syntax ( seq -- seq' )
     dup [ length 1 > ] find
-    [ compound-syntax-disallowed ] [ drop ] if*
+    [ compound-syntax-disallowed ] [ drop ] if* ;
-    concat ;
 
-: string>literals ( string -- sequence )
+: lex-factor ( n/f string/f -- n'/f string literal/f )
-    [ 0 ] dip [
     [
+        ! Compound syntax loop
         [
-                [
+            (lex-factor) f like [ , ] when*
-                    lex-factor f like [ , ] when*
             ! concatenated syntax ( a )[ a 1 + ]( b )
             [ ]
             [ peek-from blank? ]
             [ previous-from blank? or not ] 2tri pick and
         ] loop
-            ] { } make f like [ , ] when* over
+    ] { } make
-        ] loop
+    ! check-for-compound-syntax
-    ] { } make 2nip check-for-compound-syntax ;
+    ! concat
+    f like ;
+
+: string>literals ( string -- sequence )
+    [ 0 ] dip [
+        [ lex-factor [ , ] when* over ] loop
+    ] { } make 2nip ;
 
 : vocab>literals ( vocab -- sequence )
     ".private" ?tail drop

extra/modern/slices/slices.factor

@@ -59,9 +59,6 @@ ERROR: unexpected-end n string ;
 : char-after-slice ( slice -- ch/f )
     [ to>> ] [ seq>> ] bi ?nth ;
 
-: next-char-from* ( n/f string -- ch/f )
-    next-char-from 2nip ;
-
 : find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
     [ find-from ] 2keep drop
     pick [ drop t ] [ length -rot nip f ] if ; inline
@@ -180,6 +177,7 @@ ERROR: unexpected-end n string ;
         [ [ 1 - ] change-to ] dip
     ] when ;
 
+! Takes at least one character if not whitespace
 :: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
     n [
         n string '[ tokens member? ] find-from