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> "" join ]\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 : trim-whitespace ( string -- no-whitespace )\r
  35     [ blank? ] trim ;\r
  36 \r
  37 : ?filter-children ( children -- no-whitespace )\r
  38     xml-pprint? get [\r
  39         [ dup string? [ trim-whitespace ] when ] map\r
  40         [ [ empty? ] [ string? ] bi and not ] filter\r
  41     ] when ;\r
  42 \r
  43 PRIVATE>\r
  44 \r
  45 : name>string ( name -- string )\r
  46     [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;\r
  47 \r
  48 : print-name ( name -- )\r
  49     name>string write ;\r
  50 \r
  51 <PRIVATE\r
  52 \r
  53 : write-quoted ( string -- )\r
  54     CHAR: " write1 write CHAR: " write1 ;\r
  55 \r
  56 : print-attrs ( assoc -- )\r
  57     [\r
  58         [ bl print-name "=" write ]\r
  59         [ escape-quoted-string write-quoted ] bi*\r
  60     ] assoc-each ;\r
  61 \r
  62 PRIVATE>\r
  63 \r
  64 GENERIC: write-xml ( xml -- )\r
  65 \r
  66 <PRIVATE\r
  67 \r
  68 M: string write-xml\r
  69     escape-string xml-pprint? get [\r
  70         dup [ blank? ] all?\r
  71         [ drop "" ]\r
  72         [ nl 80 indent-string wrap-indented-string ] if\r
  73     ] when write ;\r
  74 \r
  75 : write-tag ( tag -- )\r
  76     ?indent CHAR: < write1\r
  77     dup print-name attrs>> print-attrs ;\r
  78 \r
  79 : write-start-tag ( tag -- )\r
  80     write-tag ">" write ;\r
  81 \r
  82 M: contained-tag write-xml\r
  83     write-tag "/>" write ;\r
  84 \r
  85 : write-children ( tag -- )\r
  86     indent children>> ?filter-children\r
  87     [ write-xml ] each unindent ;\r
  88 \r
  89 : write-end-tag ( tag -- )\r
  90     ?indent "</" write print-name CHAR: > write1 ;\r
  91 \r
  92 M: open-tag write-xml\r
  93     xml-pprint? get [\r
  94         {\r
  95             [ write-start-tag ]\r
  96             [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
  97             [ write-children ]\r
  98             [ write-end-tag ]\r
  99         } cleave\r
 100     ] dip xml-pprint? set ;\r
 101 \r
 102 M: unescaped write-xml\r
 103     string>> write ;\r
 104 \r
 105 M: comment write-xml\r
 106     "<!--" write text>> write "-->" write ;\r
 107 \r
 108 : write-decl ( decl name quot: ( decl -- slot ) -- )\r
 109     "<!" write swap write bl\r
 110     [ name>> write bl ]\r
 111     swap '[ @ write ">" write ] bi ; inline\r
 112 \r
 113 M: element-decl write-xml\r
 114     "ELEMENT" [ content-spec>> ] write-decl ;\r
 115 \r
 116 M: attlist-decl write-xml\r
 117     "ATTLIST" [ att-defs>> ] write-decl ;\r
 118 \r
 119 M: notation-decl write-xml\r
 120     "NOTATION" [ id>> ] write-decl ;\r
 121 \r
 122 M: entity-decl write-xml\r
 123     "<!ENTITY " write\r
 124     [ pe?>> [ " % " write ] when ]\r
 125     [ name>> write " \"" write ] [\r
 126         def>> f xml-pprint?\r
 127         [ write-xml ] with-variable\r
 128         "\">" write\r
 129     ] tri ;\r
 130 \r
 131 M: system-id write-xml\r
 132     "SYSTEM" write bl system-literal>> write-quoted ;\r
 133 \r
 134 M: public-id write-xml\r
 135     "PUBLIC" write bl\r
 136     [ pubid-literal>> write-quoted bl ]\r
 137     [ system-literal>> write-quoted ] bi ;\r
 138 \r
 139 : write-internal-subset ( dtd -- )\r
 140     [\r
 141         "[" write indent\r
 142         directives>> [ ?indent write-xml ] each\r
 143         unindent ?indent "]" write\r
 144     ] when* ;\r
 145 \r
 146 M: doctype-decl write-xml\r
 147     ?indent "<!DOCTYPE " write\r
 148     [ name>> write " " write ]\r
 149     [ external-id>> [ write-xml " " write ] when* ]\r
 150     [ internal-subset>> write-internal-subset ">" write ] tri ;\r
 151 \r
 152 M: directive write-xml\r
 153     "<!" write text>> write CHAR: > write1 nl ;\r
 154 \r
 155 M: instruction write-xml\r
 156     "<?" write text>> write "?>" write ;\r
 157 \r
 158 M: number write-xml\r
 159     "Numbers are not allowed in XML" throw ;\r
 160 \r
 161 M: sequence write-xml\r
 162     [ write-xml ] each ;\r
 163 \r
 164 M: prolog write-xml\r
 165     "<?xml version=" write\r
 166     [ version>> write-quoted ]\r
 167     [ drop " encoding=\"UTF-8\"" write ]\r
 168     [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
 169     "?>" write ;\r
 170 \r
 171 M: xml write-xml\r
 172     {\r
 173         [ prolog>> write-xml ]\r
 174         [ before>> write-xml ]\r
 175         [ body>> write-xml ]\r
 176         [ after>> write-xml ]\r
 177     } cleave ;\r
 178 \r
 179 PRIVATE>\r
 180 \r
 181 : xml>string ( xml -- string )\r
 182     [ write-xml ] with-string-writer ;\r
 183 \r
 184 : pprint-xml ( xml -- )\r
 185     [\r
 186         sensitive-tags [ [ assure-name ] map ] change\r
 187         0 indentation set\r
 188         xml-pprint? on\r
 189         write-xml\r
 190     ] with-scope ;\r
 191 \r
 192 : pprint-xml>string ( xml -- string )\r
 193     [ pprint-xml ] with-string-writer ;\r