basis/xml/writer/writer.factor

   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
   6 IN: xml.writer\r
   7 \r
   8 SYMBOL: xml-pprint?\r
   9 SYMBOL: sensitive-tags\r
  10 SYMBOL: indentation\r
  11 SYMBOL: indenter\r
  12 "  " indenter set-global\r
  13 \r
  14 <PRIVATE\r
  15 \r
  16 : sensitive? ( tag -- ? )\r
  17     sensitive-tags get swap '[ _ names-match? ] contains? ;\r
  18 \r
  19 : indent-string ( -- string )\r
  20     xml-pprint? get\r
  21     [ indentation get indenter get <repetition> concat ]\r
  22     [ "" ] if ;\r
  23 \r
  24 : ?indent ( -- )\r
  25     xml-pprint? get [ nl indent-string write ] when ;\r
  26 \r
  27 : indent ( -- )\r
  28     xml-pprint? get [ 1 indentation +@ ] when ;\r
  29 \r
  30 : unindent ( -- )\r
  31     xml-pprint? get [ -1 indentation +@ ] when ;\r
  32 \r
  33 : trim-whitespace ( string -- no-whitespace )\r
  34     [ blank? ] trim ;\r
  35 \r
  36 : ?filter-children ( children -- no-whitespace )\r
  37     xml-pprint? get [\r
  38         [ dup string? [ trim-whitespace ] when ] map\r
  39         [ [ empty? ] [ string? ] bi and not ] filter\r
  40     ] when ;\r
  41 \r
  42 PRIVATE>\r
  43 \r
  44 : name>string ( name -- string )\r
  45     [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;\r
  46 \r
  47 : print-name ( name -- )\r
  48     name>string write ;\r
  49 \r
  50 <PRIVATE\r
  51 \r
  52 : print-attrs ( assoc -- )\r
  53     [\r
  54         " " write\r
  55         swap print-name\r
  56         "=\"" write\r
  57         escape-quoted-string write\r
  58         "\"" write\r
  59     ] assoc-each ;\r
  60 \r
  61 PRIVATE>\r
  62 \r
  63 GENERIC: write-xml-chunk ( object -- )\r
  64 \r
  65 <PRIVATE\r
  66 \r
  67 M: string write-xml-chunk\r
  68     escape-string xml-pprint? get [\r
  69         dup [ blank? ] all?\r
  70         [ drop "" ]\r
  71         [ nl 80 indent-string indented-break ] if\r
  72     ] when write ;\r
  73 \r
  74 : write-tag ( tag -- )\r
  75     ?indent CHAR: < write1\r
  76     dup print-name attrs>> print-attrs ;\r
  77 \r
  78 : write-start-tag ( tag -- )\r
  79     write-tag ">" write ;\r
  80 \r
  81 M: contained-tag write-xml-chunk\r
  82     write-tag "/>" write ;\r
  83 \r
  84 : write-children ( tag -- )\r
  85     indent children>> ?filter-children\r
  86     [ write-xml-chunk ] each unindent ;\r
  87 \r
  88 : write-end-tag ( tag -- )\r
  89     ?indent "</" write print-name CHAR: > write1 ;\r
  90 \r
  91 M: open-tag write-xml-chunk\r
  92     xml-pprint? get [\r
  93         {\r
  94             [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
  95             [ write-start-tag ]\r
  96             [ write-children ]\r
  97             [ write-end-tag ]\r
  98         } cleave\r
  99     ] dip xml-pprint? set ;\r
 100 \r
 101 M: unescaped write-xml-chunk\r
 102     string>> write ;\r
 103 \r
 104 M: comment write-xml-chunk\r
 105     "<!--" write text>> write "-->" write ;\r
 106 \r
 107 M: element-decl write-xml-chunk\r
 108     "<!ELEMENT " write\r
 109     [ name>> write " " write ]\r
 110     [ content-spec>> write ">" write ]\r
 111     bi ;\r
 112 \r
 113 M: attlist-decl write-xml-chunk\r
 114     "<!ATTLIST " write\r
 115     [ name>> write " " write ]\r
 116     [ att-defs>> write ">" write ]\r
 117     bi ;\r
 118 \r
 119 M: notation-decl write-xml-chunk\r
 120     "<!NOTATION " write\r
 121     [ name>> write " " write ]\r
 122     [ id>> write ">" write ]\r
 123     bi ;\r
 124 \r
 125 M: entity-decl write-xml-chunk\r
 126     "<!ENTITY " write\r
 127     [ pe?>> [ " % " write ] when ]\r
 128     [ name>> write " \"" write ] [\r
 129         def>> f xml-pprint?\r
 130         [ write-xml-chunk ] with-variable\r
 131         "\">" write\r
 132     ] tri ;\r
 133 \r
 134 M: system-id write-xml-chunk\r
 135     "SYSTEM '" write system-literal>> write "'" write ;\r
 136 \r
 137 M: public-id write-xml-chunk\r
 138     "PUBLIC '" write\r
 139     [ pubid-literal>> write "' '" write ]\r
 140     [ system-literal>> write "'" write ] bi ;\r
 141 \r
 142 : write-internal-subset ( dtd -- )\r
 143     [\r
 144         "[" write indent\r
 145         directives>> [ ?indent write-xml-chunk ] each\r
 146         unindent ?indent "]" write\r
 147     ] when* ;\r
 148 \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
 154 \r
 155 M: directive write-xml-chunk\r
 156     "<!" write text>> write CHAR: > write1 nl ;\r
 157 \r
 158 M: instruction write-xml-chunk\r
 159     "<?" write text>> write "?>" write ;\r
 160 \r
 161 M: number write-xml-chunk\r
 162     "Numbers are not allowed in XML" throw ;\r
 163 \r
 164 M: sequence write-xml-chunk\r
 165     [ write-xml-chunk ] each ;\r
 166 \r
 167 PRIVATE>\r
 168 \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
 173     "\"?>" write ;\r
 174 \r
 175 : write-xml ( xml -- )\r
 176     {\r
 177         [ prolog>> write-prolog ]\r
 178         [ before>> write-xml-chunk ]\r
 179         [ body>> write-xml-chunk ]\r
 180         [ after>> write-xml-chunk ]\r
 181     } cleave ;\r
 182 \r
 183 M: xml write-xml-chunk\r
 184     body>> write-xml-chunk ;\r
 185 \r
 186 : xml>string ( xml -- string )\r
 187     [ write-xml ] with-string-writer ;\r
 188 \r
 189 : xml-chunk>string ( object -- string )\r
 190     [ write-xml-chunk ] with-string-writer ;\r
 191 \r
 192 : pprint-xml-but ( xml sensitive-tags -- )\r
 193     [\r
 194         [ assure-name ] map sensitive-tags set\r
 195         0 indentation set\r
 196         xml-pprint? on\r
 197         write-xml\r
 198     ] with-scope ;\r
 199 \r
 200 : pprint-xml ( xml -- )\r
 201     f pprint-xml-but ;\r
 202 \r
 203 : pprint-xml>string-but ( xml sensitive-tags -- string )\r
 204     [ pprint-xml-but ] with-string-writer ;\r
 205 \r
 206 : pprint-xml>string ( xml -- string )\r
 207     f pprint-xml>string-but ;\r