Merge branch 'master' of git://factorcode.org/git/factor

basis/html/templates/chloe/compiler/compiler.factor

@@ -7,16 +7,16 @@ html.templates html.templates.chloe.syntax continuations ;
 IN: html.templates.chloe.compiler
 
 : chloe-attrs-only ( assoc -- assoc' )
-    [ drop url>> chloe-ns = ] assoc-filter ;
+    [ drop chloe-name? ] assoc-filter ;
 
 : non-chloe-attrs-only ( assoc -- assoc' )
-    [ drop url>> chloe-ns = not ] assoc-filter ;
+    [ drop chloe-name? not ] assoc-filter ;
 
 : chloe-tag? ( tag -- ? )
     dup xml? [ body>> ] when
     {
         { [ dup tag? not ] [ f ] }
-        { [ dup url>> chloe-ns = not ] [ f ] }
+        { [ dup chloe-name? not ] [ f ] }
         [ t ]
     } cond nip ;
 
@@ -49,7 +49,7 @@ DEFER: compile-element
     reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
 
 : compile-attrs ( assoc -- )
-    [
+    attrs>> [
         " " [write]
         swap name>string [write]
         "=\"" [write]

basis/html/templates/chloe/syntax/syntax.factor

@@ -21,14 +21,14 @@ tags global [ H{ } clone or ] change-at
 
 : chloe-ns "http://factorcode.org/chloe/1.0" ; inline
 
-: chloe-name ( string -- name )
-    name new
-        swap >>main
-        chloe-ns >>url ;
+: chloe-name? ( name -- ? )
+    url>> chloe-ns = ;
+
+XML-NS: chloe-name http://factorcode.org/chloe/1.0
 
 : required-attr ( tag name -- value )
-    dup chloe-name rot at*
-    [ nip ] [ drop " attribute is required" append throw ] if ;
+    tuck chloe-name attr
+    [ nip ] [ " attribute is required" append throw ] if* ;
 
 : optional-attr ( tag name -- value )
-    chloe-name swap at ;
+    chloe-name attr ;

basis/http/client/client.factor

@@ -5,7 +5,7 @@ sequences strings splitting calendar continuations accessors vectors
 math.order hashtables byte-arrays destructors
 io io.sockets io.streams.string io.files io.timeouts
 io.pathnames io.encodings io.encodings.string io.encodings.ascii
-io.encodings.utf8 io.encodings.8-bit io.encodings.binary
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
 io.streams.duplex fry ascii urls urls.encoding present
 http http.parsers http.client.post-data ;
 IN: http.client

basis/http/server/server.factor

@@ -14,6 +14,7 @@ io.encodings.binary
 io.streams.limited
 io.servers.connection
 io.timeouts
+io.crlf
 fry logging logging.insomniac calendar urls urls.encoding
 mime.multipart
 unicode.categories

basis/specialized-vectors/functor/functor.factor

@@ -33,7 +33,7 @@ M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
 
 : >V ( seq -- vector ) V new clone-like ; inline
 
-M: V pprint-delims drop V{ \ } ;
+M: V pprint-delims drop \ V{ \ } ;
 
 M: V >pprint-sequence ;
 

basis/syndication/syndication.factor

@@ -70,8 +70,8 @@ TUPLE: entry title url description date ;
     tri ;
 
 : atom-entry-link ( tag -- url/f )
-    "link" tags-named [ "rel" swap at "alternate" = ] find nip
-    dup [ "href" swap at >url ] when ;
+    "link" tags-named [ "rel" attr "alternate" = ] find nip
+    dup [ "href" attr >url ] when ;
 
 : atom1.0-entry ( tag -- entry )
     entry new
@@ -95,7 +95,7 @@ TUPLE: entry title url description date ;
     feed new
     swap
     [ "title" tag-named children>string >>title ]
-    [ "link" tag-named "href" swap at >url >>url ]
+    [ "link" tag-named "href" attr >url >>url ]
     [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
     tri ;
 

basis/xml/data/data.factor

@@ -150,9 +150,11 @@ TUPLE: tag
     [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
     tag boa ;
 
-! For convenience, tags follow the assoc protocol too (for attrs)
-CONSULT: assoc-protocol tag attrs>> ;
-INSTANCE: tag assoc
+: attr ( tag/xml name -- string )
+    swap attrs>> at ;
+
+: set-attr ( tag/xml value name -- )
+    rot attrs>> set-at ;
 
 ! They also follow the sequence protocol (for children)
 CONSULT: sequence-protocol tag children>> ;
@@ -186,9 +188,6 @@ C: <xml> xml
 CONSULT: sequence-protocol xml body>> ;
 INSTANCE: xml sequence
 
-CONSULT: assoc-protocol xml body>> ;
-INSTANCE: xml assoc
-
 CONSULT: tag xml body>> ;
 
 CONSULT: name xml body>> ;
@@ -217,8 +216,14 @@ M: xml like
 PREDICATE: contained-tag < tag children>> not ;
 PREDICATE: open-tag < tag children>> ;
 
-UNION: xml-data
-    tag comment string directive instruction ;
-
 TUPLE: unescaped string ;
 C: <unescaped> unescaped
+
+UNION: xml-data
+    tag comment string directive instruction unescaped ;
+
+TUPLE: xml-chunk seq ;
+C: <xml-chunk> xml-chunk
+
+CONSULT: sequence-protocol xml-chunk seq>> ;
+INSTANCE: xml-chunk sequence

basis/xml/elements/elements.factor

@@ -65,11 +65,12 @@ IN: xml.elements
     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
 
 : prolog-version ( alist -- version )
-    T{ name f "" "version" f } swap at
+    T{ name { space "" } { main "version" } } swap at
     [ good-version ] [ versionless-prolog ] if* ;
 
 : prolog-encoding ( alist -- encoding )
-    T{ name f "" "encoding" f } swap at "UTF-8" or ;
+    T{ name { space "" } { main "encoding" } } swap at
+    "UTF-8" or ;
 
 : yes/no>bool ( string -- t/f )
     {
@@ -79,7 +80,7 @@ IN: xml.elements
     } case ;
 
 : prolog-standalone ( alist -- version )
-    T{ name f "" "standalone" f } swap at
+    T{ name { space "" } { main "standalone" } } swap at
     [ yes/no>bool ] [ f ] if* ;
 
 : prolog-attrs ( alist -- prolog )

basis/xml/interpolate/interpolate-tests.factor

@@ -2,14 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test xml.interpolate multiline kernel assocs
 sequences accessors xml.writer xml.interpolate.private
-locals splitting urls ;
+locals splitting urls xml.data classes ;
 IN: xml.interpolate.tests
 
 [ "a" "c" { "a" "c" f } ] [
     "<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
     string>doc
     [ second var>> ]
-    [ fourth "val" swap at var>> ]
+    [ fourth "val" attr var>> ]
     [ extract-variables ] tri
 ] unit-test
 
@@ -54,6 +54,15 @@ IN: xml.interpolate.tests
 [ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
 [ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
 
-\ parse-def must-infer
-[ "" interpolate-chunk ] must-infer
+\ <XML must-infer
+[ { } "" interpolate-xml ] must-infer
 [ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
+
+[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
+[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
+[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
+[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
+[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
+[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
+
+[ "" ] [ [XML XML] concat ] unit-test

basis/xml/interpolate/interpolate.factor

@@ -33,8 +33,9 @@ M: string push-item , ;
 M: xml-data push-item , ;
 M: object push-item present , ;
 M: sequence push-item
-    [ dup array? [ % ] [ , ] if ] each ;
+    dup xml-data? [ , ] [ [ push-item ] each ] if ;
 M: number push-item present , ;
+M: xml-chunk push-item % ;
 
 GENERIC: interpolate-item ( table item -- )
 M: object interpolate-item nip , ;
@@ -63,14 +64,18 @@ M: interpolated interpolate-item
 
 : number<-> ( doc -- dup )
     0 over [
-        dup var>> [ over >>var [ 1+ ] dip ] unless drop
+        dup var>> [
+            over >>var [ 1+ ] dip
+        ] unless drop
     ] each-interpolated drop ;
 
-MACRO: interpolate-xml ( string -- doc )
-    string>doc number<-> '[ _ interpolate-xml-doc ] ;
+GENERIC: interpolate-xml ( table xml -- xml )
 
-MACRO: interpolate-chunk ( string -- chunk )
-    string>chunk number<-> '[ _ interpolate-sequence ] ;
+M: xml interpolate-xml
+    interpolate-xml-doc ;
+
+M: xml-chunk interpolate-xml
+    interpolate-sequence <xml-chunk> ;
 
 : >search-hash ( seq -- hash )
     [ dup search ] H{ } map>assoc ;
@@ -81,26 +86,24 @@ MACRO: interpolate-chunk ( string -- chunk )
 : nenum ( ... n -- assoc )
     narray <enum> ; inline
 
-: collect ( accum seq -- accum )
+: collect ( accum variables -- accum ? )
     {
-        { [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
-        { [ dup [ not ] all? ] [ ! fry
-            length parsed \ nenum parsed
-        ] }
+        { [ dup empty? ] [ drop f ] } ! Just a literal
+        { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
+        { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
     } cond ;
 
-: parse-def ( accum delimiter word -- accum )
-    [
-        parse-multiline-string but-last
-        [ string>chunk extract-variables collect ] keep
-        parsed
-    ] dip parsed ;
+: parse-def ( accum delimiter quot -- accum )
+    [ parse-multiline-string 1 short head* ] dip call
+    [ extract-variables collect ] keep swap
+    [ number<-> parsed ] dip
+    [ \ interpolate-xml parsed ] when ; inline
 
 PRIVATE>
 
 : <XML
-    "XML>" \ interpolate-xml parse-def ; parsing
+    "XML>" [ string>doc ] parse-def ; parsing
 
 : [XML
-    "XML]" \ interpolate-chunk parse-def ; parsing
+    "XML]" [ string>chunk ] parse-def ; parsing

basis/xml/tests/test.factor

@@ -19,7 +19,7 @@ SYMBOL: xml-file
 [ "a" ] [ xml-file get space>> ] unit-test
 [ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
 [ "that" ] [
-    xml-file get T{ name f "" "this" "http://d.de" } swap at
+    xml-file get T{ name f "" "this" "http://d.de" } attr
 ] unit-test
 [ t ] [ xml-file get children>> second contained-tag? ] unit-test
 [ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
@@ -30,7 +30,7 @@ SYMBOL: xml-file
     xml-file get after>> [ instruction? ] find nip text>>
 ] unit-test
 [ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
-[ "that" ] [ xml-file get "this" swap at ] unit-test
+[ "that" ] [ xml-file get "this" attr ] unit-test
 [ "abcd" ] [
     "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
     [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
@@ -43,9 +43,11 @@ SYMBOL: xml-file
     "<a><b id='c'>foo</b><d id='e'/></a>" string>xml
     "c" get-id children>string
 ] unit-test
-[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
-    at swap "z" [ tuck ] dip swap set-at
-    T{ name f "blah" "z" f } swap at ] unit-test
+[ "foo" ] [
+    "<x y='foo'/>" string>xml
+    dup dup "y" attr "z" set-attr
+    T{ name { space "blah" } { main "z" } } attr
+] unit-test
 [ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
 [ "<!-- B+, B, or B--->" string>xml ] must-fail
 [ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
@@ -58,5 +60,6 @@ SYMBOL: xml-file
 [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
 [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo   SYSTEM \"blah.dtd\"   >" string>xml-chunk first ] unit-test
 [ 958 ] [ [ "&xi;" string>xml-chunk ] with-html-entities first first ] unit-test
-[ "x" "<" ] [ "<x value='&lt;'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
+[ "x" "<" ] [ "<x value='&lt;'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
 [ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
+[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test

basis/xml/tests/xmltest.factor

@@ -1,16 +1,16 @@
 USING: accessors assocs combinators continuations fry generalizations
 io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.utilities xml.writer arrays ;
+xml.utilities xml.writer arrays xml.data ; 
 IN: xml.tests.suite
 
 TUPLE: xml-test id uri sections description type ;
 
 : >xml-test ( tag -- test )
     xml-test new swap {
-        [ "TYPE" swap at >>type ]
-        [ "ID" swap at >>id ]
-        [ "URI" swap at >>uri ]
-        [ "SECTIONS" swap at >>sections ]
+        [ "TYPE" attr >>type ]
+        [ "ID" attr >>id ]
+        [ "URI" attr >>uri ]
+        [ "SECTIONS" attr >>sections ]
         [ children>> xml-chunk>string >>description ]
     } cleave ;
 
@@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot )
 
 : failing-valids ( -- tests )
     partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
+
+[ ] [ partition-xml-tests 2drop ] unit-test

basis/xml/writer/writer-tests.factor

@@ -52,7 +52,6 @@ IN: xml.writer.tests
 <x>&foo;</x>"} pprint-reprints-as
 
 [ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
-[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
     [ "<a b='c'/>" string>xml xml>string ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]

basis/xml/xml.factor

@@ -162,7 +162,8 @@ PRIVATE>
 
 : read-xml-chunk ( stream -- seq )
     1 depth
-    [ (read-xml-chunk) nip ] with-variable ;
+    [ (read-xml-chunk) nip ] with-variable
+    <xml-chunk> ;
 
 : string>xml ( string -- xml )
     t string-input?

basis/xmode/catalog/catalog.factor

@@ -1,6 +1,6 @@
 USING: xmode.loader xmode.utilities xmode.rules namespaces
 strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors ;
+words globs combinators io.encodings.utf8 sorting accessors xml.data ;
 IN: xmode.catalog
 
 TUPLE: mode file file-name-glob first-line-glob ;
@@ -8,7 +8,7 @@ TUPLE: mode file file-name-glob first-line-glob ;
 <TAGS: parse-mode-tag ( modes tag -- )
 
 TAG: MODE
-    "NAME" over at [
+    dup "NAME" attr [
         mode new {
             { "FILE" f (>>file) }
             { "FILE_NAME_GLOB" f (>>file-name-glob) }

basis/xmode/loader/loader.factor

@@ -13,10 +13,10 @@ TAG: PROPS
     parse-props-tag >>props drop ;
 
 TAG: IMPORT
-    "DELEGATE" swap at swap import-rule-set ;
+    "DELEGATE" attr swap import-rule-set ;
 
 TAG: TERMINATE
-    "AT_CHAR" swap at string>number >>terminate-char drop ;
+    "AT_CHAR" attr string>number >>terminate-char drop ;
 
 RULE: SEQ seq-rule
     shared-tag-attrs delegate-attr literal-start ;

basis/xmode/utilities/utilities.factor

@@ -22,7 +22,7 @@ IN: xmode.utilities
         ] }
         { [ dup length 3 = ] [
             first3 '[
-                _ tag get at
+                tag get _ attr
                 _ [ execute ] when* object get _ execute
             ]
         ] }