factor: trim using lists

[factor.git] / basis / xml / data / data.factor

diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor
index 74ad348babbb709e765ce16a19ce48994ac87820..645c693540baa37124bacc6ed57bf08258108db2 100644 (file)
--- a/basis/xml/data/data.factor
+++ b/basis/xml/data/data.factor
@@ -1,28 +1,28 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors accessors multiline
-macros words quotations combinators slots fry strings ;
+USING: accessors arrays assocs combinators
+combinators.short-circuit delegate delegate.protocols kernel
+sequences slots strings vectors words ;
 IN: xml.data
 
 TUPLE: interpolated var ;
 C: <interpolated> interpolated
 
-UNION: nullable-string string POSTPONE: f ;
-
 TUPLE: name
-    { space nullable-string }
+    { space maybe{ string } }
     { main string }
-    { url nullable-string } ;
+    { url maybe{ string } } ;
 C: <name> name
 
 : ?= ( object/f object/f -- ? )
     2dup and [ = ] [ 2drop t ] if ;
 
 : names-match? ( name1 name2 -- ? )
-    [ [ space>> ] bi@ ?= ]
-    [ [ url>> ] bi@ ?= ]
-    [ [ main>> ] bi@ ?= ] 2tri and and ;
+    {
+        [ [ space>> ] bi@ ?= ]
+        [ [ url>> ] bi@ ?= ]
+        [ [ main>> ] bi@ ?= ]
+    } 2&& ;
 
 : <simple-name> ( string -- name )
     "" swap f <name> ;
@@ -47,11 +47,11 @@ M: attrs set-at
         2nip set-second
     ] [
         [ assure-name swap 2array ] dip
-        [ alist>> ?push ] keep (>>alist)
+        [ alist>> ?push ] keep alist<<
     ] if* ;
 
 M: attrs assoc-size alist>> length ;
-M: attrs new-assoc drop V{ } new-sequence <attrs> ;
+M: attrs new-assoc drop <vector> <attrs> ;
 M: attrs >alist alist>> ;
 
 : >attrs ( assoc -- attrs )
@@ -66,7 +66,7 @@ M: attrs clear-assoc
     f >>alist drop ;
 M: attrs delete-at
     [ nip ] [ attr@ drop ] 2bi
-    [ swap alist>> delete-nth ] [ drop ] if* ;
+    [ swap alist>> remove-nth! drop ] [ drop ] if* ;
 
 M: attrs clone
     alist>> clone <attrs> ;
@@ -97,8 +97,6 @@ TUPLE: attlist-decl < directive
     { att-defs string } ;
 C: <attlist-decl> attlist-decl
 
-UNION: boolean t POSTPONE: f ;
-
 TUPLE: entity-decl < directive
     { name string }
     { def string }
@@ -111,7 +109,7 @@ C: <system-id> system-id
 TUPLE: public-id { pubid-literal string } { system-literal string } ;
 C: <public-id> public-id
 
-UNION: id system-id public-id POSTPONE: f ;
+UNION: id system-id public-id ;
 
 TUPLE: dtd
     { directives sequence }
@@ -119,12 +117,10 @@ TUPLE: dtd
     { parameter-entities assoc } ;
 C: <dtd> dtd
 
-UNION: dtd/f dtd POSTPONE: f ;
-
 TUPLE: doctype-decl < directive
     { name string }
-    { external-id id }
-    { internal-subset dtd/f } ;
+    { external-id maybe{ id } }
+    { internal-subset maybe{ dtd } } ;
 C: <doctype-decl> doctype-decl
 
 TUPLE: notation-decl < directive
@@ -150,16 +146,20 @@ TUPLE: tag
     [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
     tag boa ;
 
-: attr ( tag name -- string )
+: attr ( tag/xml name -- string )
     swap attrs>> at ;
 
-: set-attr ( tag value name -- )
+: set-attr ( tag/xml value name -- )
     rot attrs>> set-at ;
 
 ! They also follow the sequence protocol (for children)
 CONSULT: sequence-protocol tag children>> ;
 INSTANCE: tag sequence
 
+! They also follow the assoc protocol (for attributes)
+CONSULT: assoc-protocol tag attrs>> ;
+INSTANCE: tag assoc
+
 CONSULT: name tag name>> ;
 
 M: tag like
@@ -168,7 +168,7 @@ M: tag like
         rot dup [ V{ } like ] when <tag>
     ] if ;
 
-MACRO: clone-slots ( class -- tuple )
+MACRO: clone-slots ( class -- quot )
     [
         "slots" word-prop
         [ name>> reader-word '[ _ execute clone ] ] map
@@ -188,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>> ;
@@ -200,7 +197,7 @@ CONSULT: name xml body>> ;
     [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
     swap <xml> ;
 
-: seq>xml ( xml seq -- newxml )
+: sequence>xml ( xml seq -- newxml )
     over body>> like tag>xml ;
 PRIVATE>
 
@@ -209,15 +206,15 @@ M: xml clone
 
 M: xml like
     swap dup xml? [ nip ] [
-        dup tag? [ tag>xml ] [ seq>xml ] if
+        dup tag? [ tag>xml ] [ sequence>xml ] if
     ] if ;
 
 ! tag with children=f is contained
 : <contained-tag> ( name attrs -- tag )
     f <tag> ;
 
-PREDICATE: contained-tag < tag children>> not ;
-PREDICATE: open-tag < tag children>> ;
+PREDICATE: contained-tag < tag children>> empty? ;
+PREDICATE: open-tag < tag children>> empty? not ;
 
 TUPLE: unescaped string ;
 C: <unescaped> unescaped