! 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> ;
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 )
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> ;
{ att-defs string } ;
C: <attlist-decl> attlist-decl
-UNION: boolean t POSTPONE: f ;
-
TUPLE: entity-decl < directive
{ name string }
{ def string }
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 }
{ 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
[ 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>> ;
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
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
CONSULT: sequence-protocol xml body>> ;
INSTANCE: xml sequence
-CONSULT: assoc-protocol xml body>> ;
-INSTANCE: xml assoc
-
CONSULT: tag xml body>> ;
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>
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
+
+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