1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: hashtables kernel math namespaces sequences strings
\r
4 assocs combinators io io.streams.string accessors
\r
5 xml.data wrap xml.entities unicode.categories fry ;
\r
9 SYMBOL: sensitive-tags
\r
12 " " indenter set-global
\r
16 : sensitive? ( tag -- ? )
\r
17 sensitive-tags get swap '[ _ names-match? ] contains? ;
\r
19 : indent-string ( -- string )
\r
21 [ indentation get indenter get <repetition> concat ]
\r
25 xml-pprint? get [ nl indent-string write ] when ;
\r
28 xml-pprint? get [ 1 indentation +@ ] when ;
\r
31 xml-pprint? get [ -1 indentation +@ ] when ;
\r
33 : trim-whitespace ( string -- no-whitespace )
\r
36 : ?filter-children ( children -- no-whitespace )
\r
38 [ dup string? [ trim-whitespace ] when ] map
\r
39 [ [ empty? ] [ string? ] bi and not ] filter
\r
44 : name>string ( name -- string )
\r
45 [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
\r
47 : print-name ( name -- )
\r
52 : print-attrs ( assoc -- )
\r
57 escape-quoted-string write
\r
63 GENERIC: write-xml-chunk ( object -- )
\r
67 M: string write-xml-chunk
\r
68 escape-string xml-pprint? get [
\r
71 [ nl 80 indent-string indented-break ] if
\r
74 : write-tag ( tag -- )
\r
75 ?indent CHAR: < write1
\r
76 dup print-name attrs>> print-attrs ;
\r
78 : write-start-tag ( tag -- )
\r
79 write-tag ">" write ;
\r
81 M: contained-tag write-xml-chunk
\r
82 write-tag "/>" write ;
\r
84 : write-children ( tag -- )
\r
85 indent children>> ?filter-children
\r
86 [ write-xml-chunk ] each unindent ;
\r
88 : write-end-tag ( tag -- )
\r
89 ?indent "</" write print-name CHAR: > write1 ;
\r
91 M: open-tag write-xml-chunk
\r
94 [ sensitive? not xml-pprint? get and xml-pprint? set ]
\r
99 ] dip xml-pprint? set ;
\r
101 M: unescaped write-xml-chunk
\r
104 M: comment write-xml-chunk
\r
105 "<!--" write text>> write "-->" write ;
\r
107 M: element-decl write-xml-chunk
\r
109 [ name>> write " " write ]
\r
110 [ content-spec>> write ">" write ]
\r
113 M: attlist-decl write-xml-chunk
\r
115 [ name>> write " " write ]
\r
116 [ att-defs>> write ">" write ]
\r
119 M: notation-decl write-xml-chunk
\r
120 "<!NOTATION " write
\r
121 [ name>> write " " write ]
\r
122 [ id>> write ">" write ]
\r
125 M: entity-decl write-xml-chunk
\r
127 [ pe?>> [ " % " write ] when ]
\r
128 [ name>> write " \"" write ] [
\r
129 def>> f xml-pprint?
\r
130 [ write-xml-chunk ] with-variable
\r
134 M: system-id write-xml-chunk
\r
135 "SYSTEM '" write system-literal>> write "'" write ;
\r
137 M: public-id write-xml-chunk
\r
139 [ pubid-literal>> write "' '" write ]
\r
140 [ system-literal>> write "'" write ] bi ;
\r
142 : write-internal-subset ( dtd -- )
\r
145 directives>> [ ?indent write-xml-chunk ] each
\r
146 unindent ?indent "]" write
\r
149 M: doctype-decl write-xml-chunk
\r
150 ?indent "<!DOCTYPE " write
\r
151 [ name>> write " " write ]
\r
152 [ external-id>> [ write-xml-chunk " " write ] when* ]
\r
153 [ internal-subset>> write-internal-subset ">" write ] tri ;
\r
155 M: directive write-xml-chunk
\r
156 "<!" write text>> write CHAR: > write1 nl ;
\r
158 M: instruction write-xml-chunk
\r
159 "<?" write text>> write "?>" write ;
\r
161 M: number write-xml-chunk
\r
162 "Numbers are not allowed in XML" throw ;
\r
164 M: sequence write-xml-chunk
\r
165 [ write-xml-chunk ] each ;
\r
169 : write-prolog ( xml -- )
\r
170 "<?xml version=\"" write dup version>> write
\r
171 "\" encoding=\"" write dup encoding>> write
\r
172 standalone>> [ "\" standalone=\"yes" write ] when
\r
175 : write-xml ( xml -- )
\r
177 [ prolog>> write-prolog ]
\r
178 [ before>> write-xml-chunk ]
\r
179 [ body>> write-xml-chunk ]
\r
180 [ after>> write-xml-chunk ]
\r
183 M: xml write-xml-chunk
\r
184 body>> write-xml-chunk ;
\r
186 : xml>string ( xml -- string )
\r
187 [ write-xml ] with-string-writer ;
\r
189 : xml-chunk>string ( object -- string )
\r
190 [ write-xml-chunk ] with-string-writer ;
\r
192 : pprint-xml-but ( xml sensitive-tags -- )
\r
194 [ assure-name ] map sensitive-tags set
\r
200 : pprint-xml ( xml -- )
\r
203 : pprint-xml>string-but ( xml sensitive-tags -- string )
\r
204 [ pprint-xml-but ] with-string-writer ;
\r
206 : pprint-xml>string ( xml -- string )
\r
207 f pprint-xml>string-but ;
\r