modern: Tokens are sequences. It makes everything easier.

extra/modern/compiler/compiler.factor

@@ -2,107 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators
 combinators.short-circuit combinators.smart constructors fry
-kernel lexer math math.parser modern namespaces sequences sets
+kernel lexer math math.parser modern.slices namespaces sequences
-splitting strings ;
+sequences.private sets splitting strings ;
 IN: modern.compiler
 
-<<
-INITIALIZED-SYMBOL: left-decorators [ HS{ } clone ]
->>
-<<
-: make-left-decorator ( string -- )
-    left-decorators get adjoin ;
-
->>
-<<
-SYNTAX: \LEFT-DECORATOR: scan-token make-left-decorator ;
->>
-
-LEFT-DECORATOR: delimiter
-LEFT-DECORATOR: deprecated
-LEFT-DECORATOR: final
-LEFT-DECORATOR: flushable
-LEFT-DECORATOR: foldable
-LEFT-DECORATOR: inline
-LEFT-DECORATOR: recursive
-
-: left-decorator? ( obj -- ? )
-    left-decorators get in? ;
-
-<<
-! Initialize with : foo ( -- ) .. ; already
-INITIALIZED-SYMBOL: arities [ H{ } clone 2 "" pick set-at ]
->>
-<<
-: make-arity ( n string -- )
-    arities get set-at ;
->>
-<<
-SYNTAX: \ARITY:
-    scan-token
-    scan-token string>number swap make-arity ;
->>
-
-ARITY: \ABOUT: 1
-ARITY: \ALIAS: 2
-ARITY: \ARITY: 2
-ARITY: \B: 1
-ARITY: \BUILTIN: 1
-ARITY: \CONSTANT: 2
-ARITY: \DEFER: 1
-ARITY: \FORGET: 1
-ARITY: \GENERIC#: 3
-ARITY: \GENERIC: 2
-ARITY: \LEFT-DECORATOR: 1
-ARITY: \HOOK: 3
-ARITY: \IN: 1
-ARITY: \INSTANCE: 2
-ARITY: \MAIN: 1
-ARITY: \MATH: 2
-ARITY: \MIXIN: 1
-ARITY: \PRIMITIVE: 2
-ARITY: \QUALIFIED-WITH: 2
-ARITY: \QUALIFIED: 1
-ARITY: \RENAME: 3
-ARITY: \SINGLETON: 1
-ARITY: \SLOT: 1
-ARITY: \SOLUTION: 1
-ARITY: \SYMBOL: 1
-ARITY: \UNUSE: 1
-ARITY: \USE: 1
-
-ARITY: \MEMO: 2
-ARITY: \: 2
-
-! ARITY: \USING: 0
-
-: get-arity ( string -- n/f )
-    arities get at ;
-
-<<
-INITIALIZED-SYMBOL: variable-arities [ H{ } clone ]
->>
-<<
-: make-variable-arity ( n string -- )
-    variable-arities get set-at ;
->>
-<<
-SYNTAX: \VARIABLE-ARITY: scan-token scan-token swap make-arity ;
->>
-
-VARIABLE-ARITY: \EXCLUDE: 2
-VARIABLE-ARITY: \FROM: 2
-VARIABLE-ARITY: \INTERSECTION: 1
-VARIABLE-ARITY: \PREDICATE: 3
-VARIABLE-ARITY: \SYNTAX: 1
-VARIABLE-ARITY: \TUPLE: 1
-VARIABLE-ARITY: \UNION: 1
-VARIABLE-ARITY: \WORD: 2
-
-VARIABLE-ARITY: \<CLASS: 3
-VARIABLE-ARITY: \<FUNCTOR: 2
-
-
 TUPLE: vocabulary-root uri path ;
 CONSTRUCTOR: <vocabulary-root> vocabulary-root ( uri path -- obj ) ;
 
@@ -117,42 +20,14 @@ CONSTANT: extra-root T{ vocabulary-root f "git@github.com:factor/factor" "extra/
 : syntax-vocabulary ( -- vocabulary )
     "syntax" <vocabulary> ;
 
-TUPLE: word name effect quot ;
-
-: add-word ( word vocabulary -- )
-    [ dup name>> ] [ words>> ] bi* set-at ;
-
-
-: find-sections ( literals -- sections )
-    [ ?first section-open? ] filter ;
-
-DEFER: map-literals
-: map-literal ( obj quot: ( obj -- obj' ) -- obj )
-    over { [ array? ] [ ?first section-open? ] } 1&& [
-        [ first3 swap ] dip map-literals swap 3array
-    ] [
-        call
-    ] if ; inline recursive
-
-: map-literals ( seq quot: ( obj -- obj' ) -- seq' )
-    '[ _ map-literal ] map ; inline recursive
-
-
-DEFER: map-literals!
-: map-literal! ( obj quot: ( obj -- obj' ) -- obj )
-    over { [ array? ] [ ?first section-open? ] } 1&& [
-        [ call drop ] [
-            map-literals!
-        ] 2bi
-    ] [
-        call
-    ] if ; inline recursive
-
-: map-literals! ( seq quot: ( obj -- obj' ) -- seq )
-    '[ _ map-literal! ] map! ; inline recursive
-
 TUPLE: lexed tokens ;
 
+INSTANCE: lexed sequence
+M: lexed nth tokens>> nth ;
+M: lexed nth-unsafe tokens>> nth-unsafe ;
+M: lexed length tokens>> length ;
+
+
 TUPLE: comment < lexed payload ;
 CONSTRUCTOR: <comment> comment ( tokens payload -- obj ) ;
 
@@ -169,33 +44,57 @@ TUPLE: named-section < lexed tag name payload ;
 CONSTRUCTOR: <named-section> named-section ( tokens tag name payload -- obj ) ;
 
 TUPLE: upper-colon < lexed tag payload ;
-CONSTRUCTOR: <upper-colon> upper-colon ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <upper-colon> upper-colon ( tokens -- obj ) ;
 
 TUPLE: lower-colon < lexed tag payload ;
 CONSTRUCTOR: <lower-colon> lower-colon ( tokens tag payload -- obj ) ;
 
 TUPLE: matched < lexed tag payload ;
-CONSTRUCTOR: <matched> matched ( tokens tag payload -- obj ) ;
 
 TUPLE: single-bracket < matched ;
-CONSTRUCTOR: <single-bracket> single-bracket ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <single-bracket> single-bracket ( tokens -- obj )
+    dup tokens>>
+        [ first >string >>tag ]
+        [ second >strings >>payload ] bi ;
 
 TUPLE: double-bracket < matched ;
-CONSTRUCTOR: <double-bracket> double-bracket ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <double-bracket> double-bracket ( tokens -- obj )
+    dup tokens>>
+        [ first >string >>tag ]
+        [ third >string >>payload ] bi ;
 
 
 TUPLE: single-brace < matched ;
-CONSTRUCTOR: <single-brace> single-brace ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <single-brace> single-brace ( tokens -- obj )
+    dup tokens>>
+        [ first >string >>tag ]
+        [ second >strings >>payload ] bi ;
 
 TUPLE: double-brace < matched ;
-CONSTRUCTOR: <double-brace> double-brace ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <double-brace> double-brace ( tokens -- obj )
+    dup tokens>>
+        [ first >string >>tag ]
+        [ third >string >>payload ] bi ;
 
 
 TUPLE: single-paren < matched ;
-CONSTRUCTOR: <single-paren> single-paren ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <single-paren> single-paren ( tokens -- obj )
+    dup tokens>>
+        [ first >string but-last >>tag ]
+        [ second >strings >>payload ] bi ;
 
 TUPLE: double-paren < matched ;
-CONSTRUCTOR: <double-paren> double-paren ( tokens tag payload -- obj ) ;
+CONSTRUCTOR: <double-paren> double-paren ( tokens -- obj )
+    dup tokens>>
+        [ first >string >>tag ]
+        [ third >string >>payload ] bi ;
+
+: <matched> ( tokens ch -- obj )
+    {
+        { char: \[ [ <single-bracket> ] }
+        { char: \{ [ <single-brace> ] }
+        { char: \( [ <single-paren> ] }
+    } case ;
 
 
 TUPLE: double-quote < matched ;
@@ -205,104 +104,7 @@ CONSTRUCTOR: <double-quote> double-quote ( tokens tag payload -- obj ) ;
 TUPLE: identifier < lexed name ;
 CONSTRUCTOR: <identifier> identifier ( tokens name -- obj ) ;
 
-ERROR: unknown-literal tokens ;
 
-DEFER: literal>tuple
-: literal>tuple* ( obj -- tuple )
-    {
-        ! Comment has to be first
-        { [ dup ?first "!" head? ] [
-            [ ] [ ?second >string ] bi <comment>
-        ] }
-
-        ! Must be before escaped-identifier so that ``\ foo`` works
-        { [ dup ?first "\\" tail? ] [
-            [ ] [ ?first >string ] [ ?second ] tri <escaped-object>
-        ] }
-
-        { [ dup ?first "\\" head? ] [
-            [ ] [ ?second >string ] bi <escaped-identifier>
-        ] }
-
-        { [ dup ?first section-open? ] [
-            dup first ":" tail? [
-                { [ ] [ first "<" ?head drop ":" ?tail drop ] [ ?second ?first >string ] [ ?second dup length 0 > [ rest dup [ [ literal>tuple ] map ] when ] when ] } cleave <named-section>
-            ] [
-                [ ] [ first "<" ?head drop ] [ rest but-last ?first dup [ [ literal>tuple ] map ] when ] tri <section>
-            ] if
-        ] }
-        { [ dup { [ ?first ":" tail? ] [ ?first strict-upper? ] } 1&& ] [
-            ! : .. ;  FOO: ;
-            [ ] [ ?first ":" ?tail drop ] [ rest dup ?last ";" tail? [ but-last ] when ?first dup [ [ literal>tuple ] map ] when ] tri <upper-colon>
-        ] }
-        { [ dup ?first ":" tail? ] [
-            ! foo: 123
-            [ ] [ ?first >string ] [ second literal>tuple ] tri <lower-colon>
-        ] }
-        { [ dup ?first "\"" tail? ] [
-            [ ] [ ?first >string ] [ second >string ] tri <double-quote>
-        ] }
-        { [ dup ?first "[" tail? ] [
-            [ ] [ ?first "[" ?tail drop ] [ rest but-last ?first dup [ [ literal>tuple ] map ] when ] tri <single-bracket>
-        ] }
-        { [ dup ?first "{" tail? ] [
-            [ ] [ ?first "{" ?tail drop ] [ rest but-last ?first dup [ [ literal>tuple ] map ] when ] tri <single-brace>
-        ] }
-        { [ dup ?first "(" tail? ] [
-            [ ] [ ?first "(" ?tail drop ] [ rest but-last ?first dup [ [ literal>tuple ] map ] when ] tri <single-paren>
-        ] }
-        { [ dup ?second "[" head? ] [
-            [ ] [ ?first ] [ 2 tail but-last ] tri <double-bracket>
-        ] }
-        { [ dup ?second "{" head? ] [
-            [ ] [ ?first ] [ 2 tail but-last ] tri <double-brace>
-        ] }
-        { [ dup ?second "(" head? ] [
-            [ ] [ ?first ] [ 2 tail but-last ] tri <double-paren>
-        ] }
-
-        { [ dup array? ] [ [ literal>tuple ] map ] }
-
-        [ unknown-literal ]
-    } cond ;
-
-: literal>tuple ( obj -- tuple )
-    dup { [ slice? ] [ string? ] } 1|| [
-        [ ] [ >string ] bi <identifier>
-    ] [
-        literal>tuple*
-    ] if ;
-
-: literals>tuples ( seq -- seq' )
-    [ literal>tuple ] map ;
-
-: vocab>tuples ( path -- seq )
-    vocab>literals literals>tuples ;
-
-: string>tuples ( string -- seq )
-    string>literals literals>tuples ;
-
-: literals>vocabulary ( literals -- vocabulary )
-    ;
-
-
-![[
-GENERIC: tuple>string ( obj -- string )
-
-M: sequence tuple>string
-    [ tuple>string ] map " " join ;
-
-M: upper-colon tuple>string
-    [
-        {
-            [ tag>> ": " ]
-            [ payload>> [ tuple>string ] map " " join ]
-            [ drop " ;" ]
-        } cleave
-    ] "" append-outputs-as ;
-
-M: identifier tuple>string name>> ;
-]]
 
 TUPLE: compilation-unit ;
 
@@ -365,12 +167,6 @@ M: upper-colon tuple>identifiers
 M: sequence tuple>identifiers
     [ tuple>identifiers ] map sift concat ;
 
-: vocab>identifiers ( vocab -- hashtable )
-    vocab>tuples tuple>identifiers ;
-
-: string>identifiers ( string -- identifiers )
-    string>tuples tuple>identifiers ;
-
 
 ![[
 GENERIC: fixup-arity ( obj -- seq )

extra/modern/manifest/manifest.factor

@@ -229,3 +229,26 @@ GENERIC: upper-colon>definitions ( form -- seq )
         [ ]
     } cond ;
 
+DEFER: map-literals
+: map-literal ( obj quot: ( obj -- obj' ) -- obj )
+    over { [ array? ] [ ?first section-open? ] } 1&& [
+        [ first3 swap ] dip map-literals swap 3array
+    ] [
+        call
+    ] if ; inline recursive
+
+: map-literals ( seq quot: ( obj -- obj' ) -- seq' )
+    '[ _ map-literal ] map ; inline recursive
+
+DEFER: map-literals!
+: map-literal! ( obj quot: ( obj -- obj' ) -- obj )
+    over { [ array? ] [ ?first section-open? ] } 1&& [
+        [ call drop ] [
+            map-literals!
+        ] 2bi
+    ] [
+        call
+    ] if ; inline recursive
+
+: map-literals! ( seq quot: ( obj -- obj' ) -- seq )
+    '[ _ map-literal! ] map! ; inline recursive

extra/modern/modern.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2016 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators combinators.short-circuit
-constructors continuations io.encodings.utf8 io.files kernel
+continuations io.encodings.utf8 io.files kernel make math
-make math math.order modern.paths modern.slices
+math.order modern.compiler modern.paths modern.slices sequences
-sequences sequences.extras sequences.generalizations sets
+sequences.extras sets splitting strings syntax.modern unicode
-shuffle splitting strings syntax.modern unicode vocabs.loader ;
+vocabs.loader ;
 IN: modern
 
 : <ws> ( obj -- obj ) ;
@@ -29,13 +29,13 @@ MACRO:: read-double-matched ( open-ch -- quot: ( string n tag ch -- string n' se
 
                 string' n' needle slice-til-string :> ( string'' n'' payload closing )
                 string n''
-                tag opening payload closing 4array
+                tag opening payload closing 4array <double-bracket>
             ] }
             { open-ch [
                 tag 1 cut-slice* swap tag! 1 modify-to :> opening
                 string n 1 + closestr2 slice-til-string :> ( string' n' payload closing )
                 string n'
-                tag opening payload closing 4array
+                tag opening payload closing 4array <double-bracket>
             ] }
             [ [ tag openstr2 string n ] dip long-opening-mismatch ]
         } case
@@ -108,7 +108,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
             { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
             { [ dup blank? ] [
                 drop dup '[ _ matching-delimiter-string closestr1 2array members lex-until ] dip
-                swap unclip-last 3array
+                swap unclip-last 3array ch <matched>
             ] } ! ( foo )
             [
                 drop [ slice-til-whitespace drop ] dip span-slices
@@ -117,9 +117,9 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
         } cond
     ] ;
 
-: read-bracket ( string n slice -- string n' slice' ) char: \[ read-matched ;
+: read-bracket ( string n slice -- string n' obj ) char: \[ read-matched ;
-: read-brace ( string n slice -- string n' slice' ) char: \{ read-matched ;
+: read-brace ( string n slice -- string n' obj ) char: \{ read-matched ;
-: read-paren ( string n slice -- string n' slice' ) char: \( read-matched ;
+: read-paren ( string n slice -- string n' obj ) char: \( read-matched ;
 : read-string-payload ( string n -- string n' )
     dup [
         { char: \\ char: \" } slice-until-include {
@@ -291,7 +291,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
         { [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks
         { [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
         { [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
-        [ drop 2array ]
+        [ drop 2array <upper-colon> ]
     } cond ;
 
 : read-colon ( string n slice -- string n' colon )

extra/modern/out/out.factor

@@ -24,12 +24,16 @@ GENERIC: write-literal* ( last obj -- last' )
 M: slice write-literal* [ write-whitespace ] [ >string write ] [ ] tri ;
 M: array write-literal* [ write-literal* ] each ;
 M: lexed write-literal* tokens>> write-literal* ;
-M: renamed write-literal* [ slice>> write-whitespace ] [ string>> write ] [ slice>> ] tri ; ! for refactoring
+M: renamed write-literal*
+    [ slice>> write-whitespace ]
+    [ string>> write ]
+    [ slice>> ] tri ; ! for refactoring
 : write-literal ( obj -- ) f swap write-literal* drop ;
 
 DEFER: map-literals
 : (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
-    over [ array? ] any? [
+    over array? [
+    ! over [ array? ] any? [
         [ call ] [ map-literals ] bi
     ] [
         over array? [ map-literals ] [ call ] if
@@ -64,17 +68,6 @@ DEFER: map-literals
 : rewrite-string-exact ( string -- string' )
     string>literals write-modern-string ;
 
-![[
-: rewrite-path-exact ( path -- )
-    [ path>literals ] [ ] bi write-modern-path ;
-
-: rewrite-vocab-exact ( name -- )
-    vocab-source-path rewrite-path-exact ;
-
-: rewrite-paths ( paths -- )
-    [ rewrite-path-exact ] each ;
-]]
-
 : strings-core-to-file ( -- )
     core-vocabs
     [ ".private" ?tail drop vocab-source-path utf8 file-contents ] map-zip