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: comment write-xml-chunk\r
 102     "<!--" write text>> write "-->" write ;\r
 103 \r
 104 M: element-decl write-xml-chunk\r
 105     "<!ELEMENT " write\r
 106     [ name>> write " " write ]\r
 107     [ content-spec>> write ">" write ]\r
 108     bi ;\r
 109 \r
 110 M: attlist-decl write-xml-chunk\r
 111     "<!ATTLIST " write\r
 112     [ name>> write " " write ]\r
 113     [ att-defs>> write ">" write ]\r
 114     bi ;\r
 115 \r
 116 M: notation-decl write-xml-chunk\r
 117     "<!NOTATION " write\r
 118     [ name>> write " " write ]\r
 119     [ id>> write ">" write ]\r
 120     bi ;\r
 121 \r
 122 M: entity-decl write-xml-chunk\r
 123     "<!ENTITY " write\r
 124     [ pe?>> [ " % " write ] when ]\r
 125     [ name>> write " \"" write ] [\r
 126         def>> f xml-pprint?\r
 127         [ write-xml-chunk ] with-variable\r
 128         "\">" write\r
 129     ] tri ;\r
 130 \r
 131 M: system-id write-xml-chunk\r
 132     "SYSTEM '" write system-literal>> write "'" write ;\r
 133 \r
 134 M: public-id write-xml-chunk\r
 135     "PUBLIC '" write\r
 136     [ pubid-literal>> write "' '" write ]\r
 137     [ system-literal>> write "'" write ] bi ;\r
 138 \r
 139 : write-internal-subset ( dtd -- )\r
 140     [\r
 141         "[" write indent\r
 142         directives>> [ ?indent write-xml-chunk ] each\r
 143         unindent ?indent "]" write\r
 144     ] when* ;\r
 145 \r
 146 M: doctype-decl write-xml-chunk\r
 147     ?indent "<!DOCTYPE " write\r
 148     [ name>> write " " write ]\r
 149     [ external-id>> [ write-xml-chunk " " write ] when* ]\r
 150     [ internal-subset>> write-internal-subset ">" write ] tri ;\r
 151 \r
 152 M: directive write-xml-chunk\r
 153     "<!" write text>> write CHAR: > write1 nl ;\r
 154 \r
 155 M: instruction write-xml-chunk\r
 156     "<?" write text>> write "?>" write ;\r
 157 \r
 158 M: number write-xml-chunk\r
 159     "Numbers are not allowed in XML" throw ;\r
 160 \r
 161 M: sequence write-xml-chunk\r
 162     [ write-xml-chunk ] each ;\r
 163 \r
 164 PRIVATE>\r
 165 \r
 166 : write-prolog ( xml -- )\r
 167     "<?xml version=\"" write dup version>> write\r
 168     "\" encoding=\"" write dup encoding>> write\r
 169     standalone>> [ "\" standalone=\"yes" write ] when\r
 170     "\"?>" write ;\r
 171 \r
 172 : write-xml ( xml -- )\r
 173     {\r
 174         [ prolog>> write-prolog ]\r
 175         [ before>> write-xml-chunk ]\r
 176         [ body>> write-xml-chunk ]\r
 177         [ after>> write-xml-chunk ]\r
 178     } cleave ;\r
 179 \r
 180 M: xml write-xml-chunk\r
 181     body>> write-xml-chunk ;\r
 182 \r
 183 : xml>string ( xml -- string )\r
 184     [ write-xml ] with-string-writer ;\r
 185 \r
 186 : xml-chunk>string ( object -- string )\r
 187     [ write-xml-chunk ] with-string-writer ;\r
 188 \r
 189 : pprint-xml-but ( xml sensitive-tags -- )\r
 190     [\r
 191         [ assure-name ] map sensitive-tags set\r
 192         0 indentation set\r
 193         xml-pprint? on\r
 194         write-xml\r
 195     ] with-scope ;\r
 196 \r
 197 : pprint-xml ( xml -- )\r
 198     f pprint-xml-but ;\r
 199 \r
 200 : pprint-xml>string-but ( xml sensitive-tags -- string )\r
 201     [ pprint-xml-but ] with-string-writer ;\r
 202 \r
 203 : pprint-xml>string ( xml -- string )\r
 204     f pprint-xml>string-but ;\r