diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor
index 0aec1280de..2550c992b9 100644
--- a/basis/state-parser/state-parser.factor
+++ b/basis/state-parser/state-parser.factor
@@ -94,7 +94,7 @@ SYMBOL: prolog-data
[ call ] keep swap [ drop ] [
next skip-until
] if
- ] [ drop ] if ; inline
+ ] [ drop ] if ; inline recursive
: take-until ( quot -- string )
#! Take the substring of a string starting at spot
diff --git a/basis/xml/data/.data.factor.swo b/basis/xml/data/.data.factor.swo
new file mode 100644
index 0000000000..223c74706e
Binary files /dev/null and b/basis/xml/data/.data.factor.swo differ
diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor
index da2e4ccb32..1bab8d0374 100755
--- a/basis/xml/data/data.factor
+++ b/basis/xml/data/data.factor
@@ -1,25 +1,26 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors ;
+delegate.protocols delegate vectors accessors multiline
+macros words quotations combinators ;
IN: xml.data
-TUPLE: name space tag url ;
+TUPLE: name space main url ;
C: <name> name
: ?= ( object/f object/f -- ? )
2dup and [ = ] [ 2drop t ] if ;
: names-match? ( name1 name2 -- ? )
- [ name-space swap name-space ?= ] 2keep
- [ name-url swap name-url ?= ] 2keep
- name-tag swap name-tag ?= and and ;
+ [ [ space>> ] bi@ ?= ]
+ [ [ url>> ] bi@ ?= ]
+ [ [ main>> ] bi@ ?= ] 2tri and and ;
-: <name-tag> ( string -- name )
+: <simple-name> ( string -- name )
f swap f <name> ;
: assure-name ( string/name -- name )
- dup name? [ <name-tag> ] unless ;
+ dup name? [ <simple-name> ] unless ;
TUPLE: opener name attrs ;
C: <opener> opener
@@ -42,13 +43,11 @@ C: <instruction> instruction
TUPLE: prolog version encoding standalone ;
C: <prolog> prolog
-TUPLE: tag attrs children ;
-
TUPLE: attrs alist ;
C: <attrs> attrs
: attr@ ( key alist -- index {key,value} )
- >r assure-name r> attrs-alist
+ >r assure-name r> alist>>
[ first names-match? ] with find ;
M: attrs at*
@@ -58,12 +57,12 @@ M: attrs set-at
2nip set-second
] [
>r assure-name swap 2array r>
- [ attrs-alist ?push ] keep set-attrs-alist
+ [ alist>> ?push ] keep (>>alist)
] if* ;
-M: attrs assoc-size attrs-alist length ;
+M: attrs assoc-size alist>> length ;
M: attrs new-assoc drop V{ } new-sequence <attrs> ;
-M: attrs >alist attrs-alist ;
+M: attrs >alist alist>> ;
: >attrs ( assoc -- attrs )
dup [
@@ -74,61 +73,71 @@ M: attrs assoc-like
drop dup attrs? [ >attrs ] unless ;
M: attrs clear-assoc
- f swap set-attrs-alist ;
+ f >>alist drop ;
M: attrs delete-at
- tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
+ tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
- attrs-alist clone <attrs> ;
+ alist>> clone <attrs> ;
INSTANCE: attrs assoc
+TUPLE: tag name attrs children ;
+
: <tag> ( name attrs children -- tag )
- >r >r assure-name r> T{ attrs } assoc-like r>
- { set-delegate set-tag-attrs set-tag-children }
- tag construct ;
+ [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
+ tag boa ;
! For convenience, tags follow the assoc protocol too (for attrs)
CONSULT: assoc-protocol tag tag-attrs ;
INSTANCE: tag assoc
! They also follow the sequence protocol (for children)
-CONSULT: sequence-protocol tag tag-children ;
+CONSULT: sequence-protocol tag children>> ;
INSTANCE: tag sequence
+CONSULT: name tag name>> ;
+
M: tag like
over tag? [ drop ] [
- [ delegate ] keep tag-attrs
+ [ name>> ] keep tag-attrs
rot dup [ V{ } like ] when <tag>
] if ;
+MACRO: clone-slots ( class -- tuple )
+ [
+ "slots" word-prop
+ [ reader>> 1quotation [ clone ] compose ] map
+ [ cleave ] curry
+ ] [ [ boa ] curry ] bi compose ;
+
M: tag clone
- [ delegate clone ] keep [ tag-attrs clone ] keep
- tag-children clone
- { set-delegate set-tag-attrs set-tag-children } tag construct ;
+ tag clone-slots ;
-TUPLE: xml prolog before main after ;
-: <xml> ( prolog before main after -- xml )
- { set-xml-prolog set-xml-before set-delegate set-xml-after }
- xml construct ;
+TUPLE: xml prolog before body after ;
+C: <xml> xml
-CONSULT: sequence-protocol xml delegate ;
+CONSULT: sequence-protocol xml body>> ;
INSTANCE: xml sequence
-CONSULT: assoc-protocol xml delegate ;
+CONSULT: assoc-protocol xml body>> ;
INSTANCE: xml assoc
+CONSULT: tag xml body>> ;
+
+CONSULT: name xml body>> ;
+
<PRIVATE
: tag>xml ( xml tag -- newxml )
- swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
+ >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+ swap <xml> ;
: seq>xml ( xml seq -- newxml )
- over delegate like tag>xml ;
+ over body>> like tag>xml ;
PRIVATE>
M: xml clone
- [ xml-prolog clone ] keep [ xml-before clone ] keep
- [ delegate clone ] keep xml-after clone <xml> ;
+ xml clone-slots ;
M: xml like
swap dup xml? [ nip ] [
@@ -139,5 +148,5 @@ M: xml like
: <contained-tag> ( name attrs -- tag )
f <tag> ;
-PREDICATE: contained-tag < tag tag-children not ;
-PREDICATE: open-tag < tag tag-children ;
+PREDICATE: contained-tag < tag children>> not ;
+PREDICATE: open-tag < tag children>> ;
diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor
index b4ff3a4ce9..284f53023d 100644
--- a/basis/xml/tokenize/tokenize.factor
+++ b/basis/xml/tokenize/tokenize.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case ;
+math.parser sequences assocs arrays splitting combinators unicode.case
+accessors ;
IN: xml.tokenize
! XML namespace processing: ns = namespace
@@ -14,8 +15,8 @@ SYMBOL: ns-stack
! this should check to make sure URIs are valid
[
[
- swap dup name-space "xmlns" =
- [ name-tag set ]
+ swap dup space>> "xmlns" =
+ [ main>> set ]
[
T{ name f "" "xmlns" f } names-match?
[ "" set ] [ drop ] if
@@ -24,8 +25,8 @@ SYMBOL: ns-stack
] { } make-assoc f like ;
: add-ns ( name -- )
- dup name-space dup ns-stack get assoc-stack
- [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
+ dup space>> dup ns-stack get assoc-stack
+ [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
: push-ns ( hash -- )
ns-stack get push ;
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor
index 209c0b55e9..2acb353bb6 100755
--- a/basis/xml/utilities/utilities.factor
+++ b/basis/xml/utilities/utilities.factor
@@ -10,13 +10,13 @@ IN: xml.utilities
TUPLE: process-missing process tag ;
M: process-missing error.
"Tag <" write
- dup process-missing-tag print-name
+ dup tag>> print-name
"> not implemented on process process " write
- process-missing-process name>> print ;
+ name>> print ;
: run-process ( tag word -- )
2dup "xtable" word-prop
- >r dup name-tag r> at* [ 2nip call ] [
+ >r dup main>> r> at* [ 2nip call ] [
drop \ process-missing boa throw
] if ;
@@ -48,17 +48,18 @@ M: process-missing error.
standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
- tag-children {
+ children>> {
{ [ dup empty? ] [ drop "" ] }
- { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+ { [ dup [ string? not ] contains? ]
+ [ "XML tag unexpectedly contains non-text children" throw ] }
[ concat ]
} cond ;
: children-tags ( tag -- sequence )
- tag-children [ tag? ] filter ;
+ children>> [ tag? ] filter ;
: first-child-tag ( tag -- tag )
- tag-children [ tag? ] find nip ;
+ children>> [ tag? ] find nip ;
! * Accessing part of an XML document
! for tag- words, a start means that it searches all children
@@ -91,7 +92,7 @@ M: process-missing error.
assure-name [ tag-with-attr? ] 2curry find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry filter tag-children ;
+ tags@ [ tag-with-attr? ] 2curry filter children>> ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name [ tag-with-attr? ] 2curry deep-find ;
@@ -109,8 +110,8 @@ M: process-missing error.
names-match? [ "Unexpected XML tag found" throw ] unless ;
: insert-children ( children tag -- )
- dup tag-children [ push-all ]
- [ >r V{ } like r> set-tag-children ] if ;
+ dup children>> [ push-all ]
+ [ swap V{ } like >>children drop ] if ;
: insert-child ( child tag -- )
>r 1vector r> insert-children ;
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 41e5422830..13f0be431c 100644
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math namespaces sequences strings
-assocs combinators io io.streams.string
+assocs combinators io io.streams.string accessors
xml.data wrap xml.entities unicode.categories ;
IN: xml.writer
@@ -38,9 +38,9 @@ SYMBOL: indenter
] when ;
: print-name ( name -- )
- dup name-space f like
+ dup space>> f like
[ write CHAR: : write1 ] when*
- name-tag write ;
+ main>> write ;
: print-attrs ( assoc -- )
[
@@ -59,7 +59,7 @@ M: string write-item
: write-tag ( tag -- )
?indent CHAR: < write1
- dup print-name tag-attrs print-attrs ;
+ dup print-name attrs>> print-attrs ;
: write-start-tag ( tag -- )
write-tag ">" write ;
@@ -68,7 +68,7 @@ M: contained-tag write-item
write-tag "/>" write ;
: write-children ( tag -- )
- indent tag-children ?filter-children
+ indent children>> ?filter-children
[ write-item ] each unindent ;
: write-end-tag ( tag -- )
@@ -85,18 +85,18 @@ M: open-tag write-item
r> xml-pprint? set ;
M: comment write-item
- "<!--" write comment-text write "-->" write ;
+ "<!--" write text>> write "-->" write ;
M: directive write-item
- "<!" write directive-text write CHAR: > write1 ;
+ "<!" write text>> write CHAR: > write1 ;
M: instruction write-item
- "<?" write instruction-text write "?>" write ;
+ "<?" write text>> write "?>" write ;
: write-prolog ( xml -- )
- "<?xml version=\"" write dup prolog-version write
- "\" encoding=\"" write dup prolog-encoding write
- prolog-standalone [ "\" standalone=\"yes" write ] when
+ "<?xml version=\"" write dup version>> write
+ "\" encoding=\"" write dup encoding>> write
+ standalone>> [ "\" standalone=\"yes" write ] when
"\"?>" write ;
: write-chunk ( seq -- )
@@ -104,10 +104,10 @@ M: instruction write-item
: write-xml ( xml -- )
{
- [ xml-prolog write-prolog ]
- [ xml-before write-chunk ]
- [ write-item ]
- [ xml-after write-chunk ]
+ [ prolog>> write-prolog ]
+ [ before>> write-chunk ]
+ [ body>> write-item ]
+ [ after>> write-chunk ]
} cleave ;
: print-xml ( xml -- )
diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor
index 4e2ad7a672..6b64aff257 100644
--- a/basis/xml/xml.factor
+++ b/basis/xml/xml.factor
@@ -38,19 +38,19 @@ M: directive process
add-child ;
M: contained process
- [ contained-name ] keep contained-attrs
+ [ name>> ] [ attrs>> ] bi
<contained-tag> add-child ;
M: opener process push-xml ;
: check-closer ( name opener -- name opener )
dup [ <unopened> throw ] unless
- 2dup opener-name =
- [ opener-name swap <mismatched> throw ] unless ;
+ 2dup name>> =
+ [ name>> swap <mismatched> throw ] unless ;
M: closer process
- closer-name pop-xml first2
- >r check-closer opener-attrs r>
+ name>> pop-xml first2
+ >r check-closer attrs>> r>
<tag> add-child ;
: init-xml-stack ( -- )
@@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
init-parser reset-prolog init-ns-stack
text-now? on
] H{ } make-assoc
- { set-pull-xml-scope } pull-xml construct ;
+ pull-xml boa ;
: pull-event ( pull -- xml-event/f )
- pull-xml-scope [
+ scope>> [
text-now? get [ parse-text f ] [
get-char [ make-tag t ] [ f f ] if
] if text-now? set
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 9a0b86dbe3..9e984857f6 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -193,7 +193,7 @@ USE: continuations
[
iterate-step roll
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
- ] [ 3drop f ] if-iterate? ; inline
+ ] [ 3drop f ] if-iterate? ; inline recursive
PRIVATE>
: attempt-each ( seq quot -- result )