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