From 70aa3fa56933734cc644f6ea718ee0e6475fc67f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 28 Aug 2008 00:02:54 +0200 Subject: [PATCH] XML updates --- basis/state-parser/state-parser.factor | 2 +- basis/xml/data/.data.factor.swo | Bin 0 -> 16384 bytes basis/xml/data/data.factor | 81 ++++++++++++++----------- basis/xml/tokenize/tokenize.factor | 11 ++-- basis/xml/utilities/utilities.factor | 21 ++++--- basis/xml/writer/writer.factor | 30 ++++----- basis/xml/xml.factor | 14 ++--- extra/sequences/lib/lib.factor | 2 +- 8 files changed, 86 insertions(+), 75 deletions(-) create mode 100644 basis/xml/data/.data.factor.swo 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 0000000000000000000000000000000000000000..223c74706e77dd68dc05ac31c7acf3a954c1af33 GIT binary patch literal 16384 zcmeI2Z;TyP6~IRdNCnzb`auoqZGmLB^zC-HTEeotwru}c1EsdxM%b(}``)~LL+8yr zX6Eg7X{s?1>IW#{lYdGASmOs3{GcR4G@`L6XfS{=5iu(NtVT^Rh8k0?zjN=MdGBp^ zTUs>+GSmKcX71d3?!D)pd+)htcVhMKtv9Nx`&K(#OB`q9M~{AZ@!`vygYR&hz)#b_ ztGc0lJH>UQTk*p*O6sM7)oc2KsNx25=Kf?Zu)h*`ZrERQD`^z>Pq>Mn^zUs1{Z%)0 z^^ZRDX-+XkVxfUT181dyi=8!t1FJ7zv0Pocbk|u)C<+xCC^S%LpwK{}fkFd?1_})n z8YndI*404TJjXdf^Ur}xfMdUA0rvy2%)WCgu0jKa1_})n8YnbSXrRzQp@BjJg$4=@ z6dEWrP-x&SssXp^IA6cman4;t2l)NJ!~lN2*l`X)1+Ieg;O~4t1~0%*;A!|O+y!@n z3!9+?BI{4cd;;!=L+~qj6z+wCkif0*3HS(H4Qt`uaN;7z`4=38=ixbc93FxP;V$r@ z4#Ut3J#Z0R2ya~IIIqGh@ECj!nh?PRTm!wZ4359casCF+z#+I74uS^*a49T>Hx|+- zcm}=#_rZSH1*5PIR={HT=>_Nrz61BeA-EGh1LJTN9DAqZybLeFgRmE>P=Tx9pXWQy zYw#-k5}ttjA%Qwf!YyzmEP|)cbDXE(FigW*SOLr7*tw4LTlfup8@>#O;frtwtbsvT z3a=CRISRjr7vM_}LIYgb1n+@Ga54Omz|jxjTkuWzG<*!U@7T0)>&S-DO+zYbdSNMb zC)Kc$pHQmQ{h%6qp}Mv+Vy>QSNF@RXaT zaiU5kU2CtiT;Hetw63!1ud69PQF&=2d0hE5#7ZS{Ra;FdxK549t;}DksBxYX?{@p_ z*Br^0OuJ2;nH-Wi^qZ2=xp7EInZV!U8Tn(X>IL4Un|i7eM4?BnJ)YN;TqU=bda+F& zCPDfq!pHR2W*i04WOpg^Wx}gPakspzVqJ%f$JX79Mp=uCrl=)vg)}Yio9Hv^TaRuz zZ=%G|o0fj`noj86(i4;;?Y1q`sq${y6Ej{X^)BnzP+q602kmy%Gi;meI9s>v9Nn;O z1XGe0xJeRKoROQh?c8<4=#Y7p2Bc9X3UrRVXV^-2S^CoQ!iv`}o~6t$LG&;6VkSu% zw<=$rKQf^+gICp`I@&R%W4LAKT0-g=uuX6won86S0)oWmuh>R(OuhbuzjC5 zvz-;DObC(gu0UtY7Vy5jd$|U0ICvNO$KmTRkmo4W0HZ_NT>*jn6r=#5%-) z#?1GiY zg;QSWi|MYCW+j~s&;r}Fr%|MI3$zG3Uq$TP2K=UtMXS0TEB;esEA~oym5s}4be~;o z_uJX1hcYgUl~eJo1vxjrd}Z!XkmjH6lpWLscuEhNRb)TDXFUoo*S1s8m`5PdFujV znq|}2an%X~FG)IU)8$IqR;3f!EYJnAJwQGn$47zdb&M3@M1k2Vecew^-uNF~> z#~i6TIxQQz^?E1Q`?%4NsZ(c?1pA%xQdY@^H->jo<37uz+;nB;0o42$dzSf=lp1bY zsjnluc1>zNLQLOhb%Kf3F%k@+sl5kH$f6_@gi)lpw^!{WZPk<;w7mVYV~;Qqby+JS z+fsCzEsOH)Mk8y5`I1jnK8g&p{gmyVmF2ga5P z-A>7EAKUqDLZ?e(#pJcoYPm{^HzexRp3c)N~YA6LotlO5GHzl#@YY!Vg{kMqO6xY^UtYHu|LP zLr>8r$>mlmEba2tXa%VsaGG&;?cBO;%MjBv4!t0E7n1f90{tmD59s9)A+k^UOegO^FQac7diXM`Tqd76P)*7geTz$JOESBf?Hq2UU@`oIGyfmpD0~+lfW0scx4{M&fXm=q zIL;aW7w|A-F@b$NZ-El5f+cW19OaDv1bhu74j?gr5N?KzFaUq$eE&MU1W&>d_y#-z z_rTpC@qj*1@B#SsLgE?l5IhKV7=|n13Rnmiz;Vv{FT?lY^KcK`4K=tGHp3E-c))Y; zEc_52frsG$+yOK2Q5b@2U>P`Yg0sKG2ws7w;K%SicmVc*#0YMNYv8?b2`qsH@E2kO ze}><|5%>ZegnQsNxE?+TYhVG0jXV#}g2WC!1y%SsTmi-Pf6>6%gj&v^%=R5;kl6%% z@&e`|e?2)CbT*&nEh8=6zJ15aexe=b-+VEs%&}psI&B21Bk$WG{-i@0;*^z=AWH2i zBu|_xP&5%$XHb+r)X8y9GM`D9C=2+AlYmbZJ@}Zx_!OKRc?MX?$%@+<&8%B2A zG}P7X9^TNexPWP^8F-l+I4k^m20gzGOn1%D;+Eyg`7SP)NugSqj2&mv^`zz z*;NOFwbkk)FuK-rBR}tU1T6FiJBQ|p63HnV5oZ-4D%)_0KDBgJ`}U0tS$%c%_CJjZ zS&65O2-$pH(V!kX1ikqxHYWI4RV0naC|9&fvwf7KHiwUju>(!B+Q{Q{dnr36v{9;sZT&&hKzDsUa KT=v|o 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 ; -: ( string -- name ) +: ( string -- name ) f swap f ; : assure-name ( string/name -- name ) - dup name? [ ] unless ; + dup name? [ ] unless ; TUPLE: opener name attrs ; C: opener @@ -42,13 +43,11 @@ C: instruction TUPLE: prolog version encoding standalone ; C: prolog -TUPLE: tag attrs children ; - TUPLE: attrs alist ; C: 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 ; -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 ; + alist>> clone ; INSTANCE: attrs assoc +TUPLE: tag name attrs children ; + : ( 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 ] 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 ; -: ( 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 -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>> ; + xml ( xml tag -- newxml ) - swap [ dup xml-prolog swap xml-before rot ] keep xml-after ; + >r [ prolog>> ] [ before>> ] [ after>> ] tri r> + swap ; : 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 clone-slots ; M: xml like swap dup xml? [ nip ] [ @@ -139,5 +148,5 @@ M: xml like : ( name attrs -- tag ) f ; -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 ] [ throw ] if* swap set-name-url ; + dup space>> dup ns-stack get assoc-stack + [ nip ] [ 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 { } ; : 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 ; + "" write ; M: directive write-item - " write1 ; + "> write CHAR: > write1 ; M: instruction write-item - "" write ; + "> write "?>" write ; : write-prolog ( xml -- ) - "> 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 add-child ; M: opener process push-xml ; : check-closer ( name opener -- name opener ) dup [ throw ] unless - 2dup opener-name = - [ opener-name swap throw ] unless ; + 2dup name>> = + [ name>> swap 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> 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 )