! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
assocs combinators io io.streams.string accessors\r
-xml.data wrap xml.entities unicode.categories fry ;\r
+xml.data wrap.strings xml.entities unicode.categories fry ;\r
IN: xml.writer\r
\r
-SYMBOL: xml-pprint?\r
SYMBOL: sensitive-tags\r
-SYMBOL: indentation\r
SYMBOL: indenter\r
" " indenter set-global\r
\r
<PRIVATE\r
\r
+SYMBOL: xml-pprint?\r
+SYMBOL: indentation\r
+\r
: sensitive? ( tag -- ? )\r
- sensitive-tags get swap '[ _ names-match? ] contains? ;\r
+ sensitive-tags get swap '[ _ names-match? ] any? ;\r
\r
: indent-string ( -- string )\r
xml-pprint? get\r
- [ indentation get indenter get <repetition> concat ]\r
+ [ indentation get indenter get <repetition> "" concat-as ]\r
[ "" ] if ;\r
\r
: ?indent ( -- )\r
: unindent ( -- )\r
xml-pprint? get [ -1 indentation +@ ] when ;\r
\r
-: trim-whitespace ( string -- no-whitespace )\r
- [ blank? ] trim ;\r
-\r
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
- [ dup string? [ trim-whitespace ] when ] map\r
- [ [ empty? ] [ string? ] bi and not ] filter\r
+ [ dup string? [ [ blank? ] trim ] when ] map\r
+ [ "" = ] reject\r
] when ;\r
\r
PRIVATE>\r
\r
<PRIVATE\r
\r
+: write-quoted ( string -- )\r
+ CHAR: " write1 write CHAR: " write1 ;\r
+\r
: print-attrs ( assoc -- )\r
[\r
- " " write\r
- swap print-name\r
- "=\"" write\r
- escape-quoted-string write\r
- "\"" write\r
+ [ bl print-name "=" write ]\r
+ [ escape-quoted-string write-quoted ] bi*\r
] assoc-each ;\r
\r
PRIVATE>\r
\r
-GENERIC: write-xml-chunk ( object -- )\r
+GENERIC: write-xml ( xml -- )\r
\r
<PRIVATE\r
\r
-M: string write-xml-chunk\r
+M: string write-xml\r
escape-string xml-pprint? get [\r
dup [ blank? ] all?\r
[ drop "" ]\r
- [ nl 80 indent-string indented-break ] if\r
+ [ nl 80 indent-string wrap-indented-string ] if\r
] when write ;\r
\r
: write-tag ( tag -- )\r
: write-start-tag ( tag -- )\r
write-tag ">" write ;\r
\r
-M: contained-tag write-xml-chunk\r
+M: contained-tag write-xml\r
write-tag "/>" write ;\r
\r
: write-children ( tag -- )\r
indent children>> ?filter-children\r
- [ write-xml-chunk ] each unindent ;\r
+ [ write-xml ] each unindent ;\r
\r
: write-end-tag ( tag -- )\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
-M: open-tag write-xml-chunk\r
+M: open-tag write-xml\r
xml-pprint? get [\r
{\r
- [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
[ write-start-tag ]\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
[ write-children ]\r
[ write-end-tag ]\r
} cleave\r
] dip xml-pprint? set ;\r
\r
-M: comment write-xml-chunk\r
+M: unescaped write-xml\r
+ string>> write ;\r
+\r
+M: comment write-xml\r
"<!--" write text>> write "-->" write ;\r
\r
-M: element-decl write-xml-chunk\r
- "<!ELEMENT " write\r
- [ name>> write " " write ]\r
- [ content-spec>> write ">" write ]\r
- bi ;\r
-\r
-M: attlist-decl write-xml-chunk\r
- "<!ATTLIST " write\r
- [ name>> write " " write ]\r
- [ att-defs>> write ">" write ]\r
- bi ;\r
-\r
-M: notation-decl write-xml-chunk\r
- "<!NOTATION " write\r
- [ name>> write " " write ]\r
- [ id>> write ">" write ]\r
- bi ;\r
-\r
-M: entity-decl write-xml-chunk\r
+: write-decl ( decl name quot: ( decl -- slot ) -- )\r
+ "<!" write swap write bl\r
+ [ name>> write bl ]\r
+ swap '[ @ write ">" write ] bi ; inline\r
+\r
+M: element-decl write-xml\r
+ "ELEMENT" [ content-spec>> ] write-decl ;\r
+\r
+M: attlist-decl write-xml\r
+ "ATTLIST" [ att-defs>> ] write-decl ;\r
+\r
+M: notation-decl write-xml\r
+ "NOTATION" [ id>> ] write-decl ;\r
+\r
+M: entity-decl write-xml\r
"<!ENTITY " write\r
[ pe?>> [ " % " write ] when ]\r
[ name>> write " \"" write ] [\r
def>> f xml-pprint?\r
- [ write-xml-chunk ] with-variable\r
+ [ write-xml ] with-variable\r
"\">" write\r
] tri ;\r
\r
-M: system-id write-xml-chunk\r
- "SYSTEM '" write system-literal>> write "'" write ;\r
+M: system-id write-xml\r
+ "SYSTEM" write bl system-literal>> write-quoted ;\r
\r
-M: public-id write-xml-chunk\r
- "PUBLIC '" write\r
- [ pubid-literal>> write "' '" write ]\r
- [ system-literal>> write "'" write ] bi ;\r
+M: public-id write-xml\r
+ "PUBLIC" write bl\r
+ [ pubid-literal>> write-quoted bl ]\r
+ [ system-literal>> write-quoted ] bi ;\r
\r
-: write-internal-subset ( seq -- )\r
+: write-internal-subset ( dtd -- )\r
[\r
"[" write indent\r
- [ ?indent write-xml-chunk ] each\r
+ directives>> [ ?indent write-xml ] each\r
unindent ?indent "]" write\r
] when* ;\r
\r
-M: doctype-decl write-xml-chunk\r
+M: doctype-decl write-xml\r
?indent "<!DOCTYPE " write\r
- [ name>> write " " write ]\r
- [ external-id>> [ write-xml-chunk " " write ] when* ]\r
+ [ name>> write bl ]\r
+ [ external-id>> [ write-xml bl ] when* ]\r
[ internal-subset>> write-internal-subset ">" write ] tri ;\r
\r
-M: directive write-xml-chunk\r
+M: directive write-xml\r
"<!" write text>> write CHAR: > write1 nl ;\r
\r
-M: instruction write-xml-chunk\r
+M: instruction write-xml\r
"<?" write text>> write "?>" write ;\r
\r
-M: sequence write-xml-chunk\r
- [ write-xml-chunk ] each ;\r
+M: number write-xml\r
+ "Numbers are not allowed in XML" throw ;\r
\r
-PRIVATE>\r
+M: sequence write-xml\r
+ [ write-xml ] each ;\r
\r
-: write-prolog ( xml -- )\r
- "<?xml version=\"" write dup version>> write\r
- "\" encoding=\"" write dup encoding>> write\r
- standalone>> [ "\" standalone=\"yes" write ] when\r
- "\"?>" write ;\r
+M: prolog write-xml\r
+ "<?xml version=" write\r
+ [ version>> write-quoted ]\r
+ [ drop " encoding=\"UTF-8\"" write ]\r
+ [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
+ "?>" write ;\r
\r
-: write-xml ( xml -- )\r
+M: xml write-xml\r
{\r
- [ prolog>> write-prolog ]\r
- [ before>> write-xml-chunk ]\r
- [ body>> write-xml-chunk ]\r
- [ after>> write-xml-chunk ]\r
+ [ prolog>> write-xml ]\r
+ [ before>> write-xml ]\r
+ [ body>> write-xml ]\r
+ [ after>> write-xml ]\r
} cleave ;\r
\r
-M: xml write-xml-chunk\r
- body>> write-xml-chunk ;\r
+PRIVATE>\r
\r
: xml>string ( xml -- string )\r
[ write-xml ] with-string-writer ;\r
\r
-: xml-chunk>string ( object -- string )\r
- [ write-xml-chunk ] with-string-writer ;\r
-\r
-: pprint-xml-but ( xml sensitive-tags -- )\r
+: pprint-xml ( xml -- )\r
[\r
- [ assure-name ] map sensitive-tags set\r
+ sensitive-tags [ [ assure-name ] map ] change\r
0 indentation set\r
xml-pprint? on\r
write-xml\r
] with-scope ;\r
\r
-: pprint-xml ( xml -- )\r
- f pprint-xml-but ;\r
-\r
-: pprint-xml>string-but ( xml sensitive-tags -- string )\r
- [ pprint-xml-but ] with-string-writer ;\r
-\r
: pprint-xml>string ( xml -- string )\r
- f pprint-xml>string-but ;\r
+ [ pprint-xml ] with-string-writer ;\r
projects / factor.git / blobdiff