1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: hashtables kernel math namespaces sequences strings
4 assocs combinators io io.streams.string accessors
5 xml.data wrap.strings xml.entities unicode.categories fry ;
10 " " indenter set-global
17 : sensitive? ( tag -- ? )
18 sensitive-tags get swap '[ _ names-match? ] any? ;
20 : indent-string ( -- string )
22 [ indentation get indenter get <repetition> "" concat-as ]
26 xml-pprint? get [ nl indent-string write ] when ;
29 xml-pprint? get [ 1 indentation +@ ] when ;
32 xml-pprint? get [ -1 indentation +@ ] when ;
34 : ?filter-children ( children -- no-whitespace )
36 [ dup string? [ [ blank? ] trim ] when ] map
42 : name>string ( name -- string )
43 [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
45 : print-name ( name -- )
50 : write-quoted ( string -- )
51 CHAR: " write1 write CHAR: " write1 ;
53 : print-attrs ( assoc -- )
55 [ bl print-name "=" write ]
56 [ escape-quoted-string write-quoted ] bi*
61 GENERIC: write-xml ( xml -- )
66 escape-string xml-pprint? get [
69 [ nl 80 indent-string wrap-indented-string ] if
72 : write-tag ( tag -- )
73 ?indent CHAR: < write1
74 dup print-name attrs>> print-attrs ;
76 : write-start-tag ( tag -- )
79 M: contained-tag write-xml
80 write-tag "/>" write ;
82 : write-children ( tag -- )
83 indent children>> ?filter-children
84 [ write-xml ] each unindent ;
86 : write-end-tag ( tag -- )
87 ?indent "</" write print-name CHAR: > write1 ;
93 [ sensitive? not xml-pprint? get and xml-pprint? set ]
97 ] dip xml-pprint? set ;
99 M: unescaped write-xml
103 "<!--" write text>> write "-->" write ;
105 : write-decl ( decl name quot: ( decl -- slot ) -- )
106 "<!" write swap write bl
108 swap '[ @ write ">" write ] bi ; inline
110 M: element-decl write-xml
111 "ELEMENT" [ content-spec>> ] write-decl ;
113 M: attlist-decl write-xml
114 "ATTLIST" [ att-defs>> ] write-decl ;
116 M: notation-decl write-xml
117 "NOTATION" [ id>> ] write-decl ;
119 M: entity-decl write-xml
121 [ pe?>> [ " % " write ] when ]
122 [ name>> write " \"" write ] [
124 [ write-xml ] with-variable
128 M: system-id write-xml
129 "SYSTEM" write bl system-literal>> write-quoted ;
131 M: public-id write-xml
133 [ pubid-literal>> write-quoted bl ]
134 [ system-literal>> write-quoted ] bi ;
136 : write-internal-subset ( dtd -- )
139 directives>> [ ?indent write-xml ] each
140 unindent ?indent "]" write
143 M: doctype-decl write-xml
144 ?indent "<!DOCTYPE " write
146 [ external-id>> [ write-xml bl ] when* ]
147 [ internal-subset>> write-internal-subset ">" write ] tri ;
149 M: directive write-xml
150 "<!" write text>> write CHAR: > write1 nl ;
152 M: instruction write-xml
153 "<?" write text>> write "?>" write ;
156 "Numbers are not allowed in XML" throw ;
158 M: sequence write-xml
162 "<?xml version=" write
163 [ version>> write-quoted ]
164 [ drop " encoding=\"UTF-8\"" write ]
165 [ standalone>> [ " standalone=\"yes\"" write ] when ] tri
170 [ prolog>> write-xml ]
171 [ before>> write-xml ]
173 [ after>> write-xml ]
178 : xml>string ( xml -- string )
179 [ write-xml ] with-string-writer ;
181 : pprint-xml ( xml -- )
183 sensitive-tags [ [ assure-name ] map ] change
189 : pprint-xml>string ( xml -- string )
190 [ pprint-xml ] with-string-writer ;