New XML generation sytnax and word in sequences.lib

extra/delegate/delegate.factor

@@ -42,7 +42,7 @@ M: tuple-class group-words
 
 PROTOCOL: sequence-protocol
     clone clone-like like new new-resizable nth nth-unsafe
-    set-nth set-nth-unsafe length immutable set-length lengthen ;
+    set-nth set-nth-unsafe length set-length lengthen ;
 
 PROTOCOL: assoc-protocol
     at* assoc-size >alist assoc-find set-at

extra/rss/rss.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: rss
-USING: xml.utilities kernel assocs
+USING: xml.utilities kernel assocs xml.generator
     strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
     http.client namespaces xml.generator hashtables ;
@@ -74,30 +74,29 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get rot 200 = [
+    http-get-stream rot 200 = [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw
     ] if ;
 
 ! Atom generation
-: simple-tag, ( content name -- )
-    [ , ] tag, ;
-
 : entry, ( entry -- )
-    "entry" [
-        dup entry-title "title" simple-tag,
-        "link" over entry-link "href" associate contained*,
-        dup entry-pub-date "published" simple-tag,
-        entry-description "content" simple-tag,
-    ] tag, ;
+    << entry >> [
+        << title >> [ dup entry-title , ]
+        << link [ dup entry-link ] == href // >>
+        << published >> [ dup entry-pub-date , ]
+        << content >> [ entry-description , ]
+    ] ;
 
 : feed>xml ( feed -- xml )
-    "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
-        dup feed-title "title" simple-tag,
-        "link" over feed-link "href" associate contained*,
-        feed-entries [ entry, ] each
-    ] make-xml* ;
+    <XML
+        << feed [ "http://www.w3.org/2005/Atom" ] == xmlns >> [
+            << title >> [ dup feed-title , ]
+            << link [ dup feed-link ] == href // >>
+            feed-entries [ entry, ] each
+        ]
+    XML> ;
 
 : write-feed ( feed -- xml )
     feed>xml write-xml ;

extra/sequences/lib/lib.factor

@@ -62,3 +62,7 @@ IN: sequences.lib
 
 : delete-random ( seq -- value )
     [ length random ] keep [ nth ] 2keep delete-nth ;
+
+: split-around ( seq quot -- before elem after )
+    dupd find over [ "Element not found" throw ] unless
+    >r cut-slice 1 tail r> swap ; inline

extra/xml/generator/generator.factor

@@ -1,4 +1,7 @@
-USING: namespaces kernel xml.data xml.utilities ;
+! Copyright (C) 2006, 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel xml.data xml.utilities assocs splitting
+sequences parser quotations sequences.lib ;
 IN: xml.generator
 
 : comment, ( string -- ) <comment> , ;
@@ -21,3 +24,59 @@ IN: xml.generator
     (tag,) build-xml ; inline
 : make-xml ( name quot -- xml )
     f swap make-xml* ; inline
+
+SYMBOL: namespace-table
+: with-namespaces ( table quot -- )
+    >r H{ } assoc-like namespace-table r> with-variable ; inline
+
+: parsed-name ( accum -- accum )
+    scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
+
+: run-combinator ( accum quot1 quot2 -- accum )
+    >r [ ] like parsed r> [ parsed ] each ;
+
+: parse-tag-contents ( accum contained? -- accum )
+    [ \ contained*, parsed ] [
+        scan-word \ [ =
+        [ POSTPONE: [ \ tag*, parsed ]
+        [ "Expected [ missing" <parse-error> throw ] if
+    ] if ;
+
+DEFER: >>
+
+: attributes-parsed ( accum quot -- accum )
+    dup empty? [ drop f parsed ] [
+        >r \ >r parsed r> parsed
+        [ H{ } make-assoc r> swap ] [ parsed ] each
+    ] if ;
+
+: <<
+    parsed-name [
+        \ >> parse-until >quotation
+        attributes-parsed \ contained? get
+    ] with-scope parse-tag-contents ; parsing
+
+: ==
+    \ call parsed parsed-name \ set parsed ; parsing
+
+: //
+    \ contained? on ; parsing
+
+: parse-special ( accum end-token word -- accum )
+    >r parse-tokens " " join parsed r> parsed ;
+
+: <!-- "-->" \ comment, parse-special ; parsing
+
+: <!  ">" \ directive, parse-special ; parsing
+
+: <? "?>" \ instruction, parse-special ; parsing
+
+: >xml-document ( seq -- xml )
+    dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
+    [ tag? ] split-around <xml> ;
+
+DEFER: XML>
+
+: <XML
+    \ XML> [ >quotation ] parse-literal
+    { } parsed \ make parsed \ >xml-document parsed ; parsing

extra/xml/utilities/utilities.factor

@@ -42,8 +42,11 @@ M: process-missing error.
 : build-tag ( item name -- tag )
     >r 1array r> build-tag* ;
 
+: standard-prolog ( -- prolog )
+    T{ prolog f "1.0" "iso-8859-1" f } ;
+
 : build-xml ( tag -- xml )
-    T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
+    standard-prolog { } rot { } <xml> ;
 
 : children>string ( tag -- string )
     tag-children