1 ! Copyright (C) 2005, 2006 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
\r
5 xml.data wrap xml.entities unicode.categories ;
\r
9 SYMBOL: sensitive-tags
\r
12 " " indenter set-global
\r
14 : sensitive? ( tag -- ? )
\r
15 sensitive-tags get swap [ names-match? ] curry contains? ;
\r
17 : indent-string ( -- string )
\r
19 [ indentation get indenter get <repetition> concat ]
\r
23 xml-pprint? get [ nl indent-string write ] when ;
\r
26 xml-pprint? get [ 1 indentation +@ ] when ;
\r
29 xml-pprint? get [ -1 indentation +@ ] when ;
\r
31 : trim-whitespace ( string -- no-whitespace )
\r
34 : ?filter-children ( children -- no-whitespace )
\r
36 [ dup string? [ trim-whitespace ] when ] map
\r
37 [ dup empty? swap string? and not ] filter
\r
40 : print-name ( name -- )
\r
41 dup name-space f like
\r
42 [ write CHAR: : write1 ] when*
\r
45 : print-attrs ( assoc -- )
\r
50 escape-quoted-string write
\r
54 GENERIC: write-item ( object -- )
\r
56 M: string write-item
\r
57 escape-string dup empty? not xml-pprint? get and
\r
58 [ nl 80 indent-string indented-break ] when write ;
\r
60 : write-tag ( tag -- )
\r
61 ?indent CHAR: < write1
\r
62 dup print-name tag-attrs print-attrs ;
\r
64 : write-start-tag ( tag -- )
\r
65 write-tag ">" write ;
\r
67 M: contained-tag write-item
\r
68 write-tag "/>" write ;
\r
70 : write-children ( tag -- )
\r
71 indent tag-children ?filter-children
\r
72 [ write-item ] each unindent ;
\r
74 : write-end-tag ( tag -- )
\r
75 ?indent "</" write print-name CHAR: > write1 ;
\r
77 M: open-tag write-item
\r
80 [ sensitive? not xml-pprint? get and xml-pprint? set ]
\r
85 r> xml-pprint? set ;
\r
87 M: comment write-item
\r
88 "<!--" write comment-text write "-->" write ;
\r
90 M: directive write-item
\r
91 "<!" write directive-text write CHAR: > write1 ;
\r
93 M: instruction write-item
\r
94 "<?" write instruction-text write "?>" write ;
\r
96 : write-prolog ( xml -- )
\r
97 "<?xml version=\"" write dup prolog-version write
\r
98 "\" encoding=\"" write dup prolog-encoding write
\r
99 prolog-standalone [ "\" standalone=\"yes" write ] when
\r
102 : write-chunk ( seq -- )
\r
103 [ write-item ] each ;
\r
105 : write-xml ( xml -- )
\r
107 [ xml-prolog write-prolog ]
\r
108 [ xml-before write-chunk ]
\r
110 [ xml-after write-chunk ]
\r
113 : print-xml ( xml -- )
\r
116 : xml>string ( xml -- string )
\r
117 [ write-xml ] with-string-writer ;
\r
119 : with-xml-pprint ( sensitive-tags quot -- )
\r
121 swap [ assure-name ] map sensitive-tags set
\r
125 ] with-scope ; inline
\r
127 : pprint-xml-but ( xml sensitive-tags -- )
\r
128 [ print-xml ] with-xml-pprint ;
\r
130 : pprint-xml ( xml -- )
\r
133 : pprint-xml>string-but ( xml sensitive-tags -- string )
\r
134 [ xml>string ] with-xml-pprint ;
\r
136 : pprint-xml>string ( xml -- string )
\r
137 f pprint-xml>string-but ;
\r