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