basis/xml/writer/writer.factor

   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 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 : sensitive? ( tag -- ? )\r
  15     sensitive-tags get swap '[ _ names-match? ] contains? ;\r
  16 \r
  17 : indent-string ( -- string )\r
  18     xml-pprint? get\r
  19     [ indentation get indenter get <repetition> concat ]\r
  20     [ "" ] if ;\r
  21 \r
  22 : ?indent ( -- )\r
  23     xml-pprint? get [ nl indent-string write ] when ;\r
  24 \r
  25 : indent ( -- )\r
  26     xml-pprint? get [ 1 indentation +@ ] when ;\r
  27 \r
  28 : unindent ( -- )\r
  29     xml-pprint? get [ -1 indentation +@ ] when ;\r
  30 \r
  31 : trim-whitespace ( string -- no-whitespace )\r
  32     [ blank? ] trim ;\r
  33 \r
  34 : ?filter-children ( children -- no-whitespace )\r
  35     xml-pprint? get [\r
  36         [ dup string? [ trim-whitespace ] when ] map\r
  37         [ [ empty? ] [ string? ] bi and not ] filter\r
  38     ] when ;\r
  39 \r
  40 : name>string ( name -- string )\r
  41     [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;\r
  42 \r
  43 : print-name ( name -- )\r
  44     name>string write ;\r
  45 \r
  46 : print-attrs ( assoc -- )\r
  47     [\r
  48         " " write\r
  49         swap print-name\r
  50         "=\"" write\r
  51         escape-quoted-string write\r
  52         "\"" write\r
  53     ] assoc-each ;\r
  54 \r
  55 GENERIC: write-xml-chunk ( object -- )\r
  56 \r
  57 M: string write-xml-chunk\r
  58     escape-string dup empty? not xml-pprint? get and\r
  59     [ nl 80 indent-string indented-break ] when write ;\r
  60 \r
  61 : write-tag ( tag -- )\r
  62     ?indent CHAR: < write1\r
  63     dup print-name attrs>> print-attrs ;\r
  64 \r
  65 : write-start-tag ( tag -- )\r
  66     write-tag ">" write ;\r
  67 \r
  68 M: contained-tag write-xml-chunk\r
  69     write-tag "/>" write ;\r
  70 \r
  71 : write-children ( tag -- )\r
  72     indent children>> ?filter-children\r
  73     [ write-xml-chunk ] each unindent ;\r
  74 \r
  75 : write-end-tag ( tag -- )\r
  76     ?indent "</" write print-name CHAR: > write1 ;\r
  77 \r
  78 M: open-tag write-xml-chunk\r
  79     xml-pprint? get [\r
  80         {\r
  81             [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
  82             [ write-start-tag ]\r
  83             [ write-children ]\r
  84             [ write-end-tag ]\r
  85         } cleave\r
  86     ] dip xml-pprint? set ;\r
  87 \r
  88 M: comment write-xml-chunk\r
  89     "<!--" write text>> write "-->" write ;\r
  90 \r
  91 M: element-decl write-xml-chunk\r
  92     "<!ELEMENT " write\r
  93     [ name>> write " " write ]\r
  94     [ content-spec>> write ">" write ]\r
  95     bi ;\r
  96 \r
  97 M: attlist-decl write-xml-chunk\r
  98     "<!ATTLIST " write\r
  99     [ name>> write " " write ]\r
 100     [ att-defs>> write ">" write ]\r
 101     bi ;\r
 102 \r
 103 M: entity-decl write-xml-chunk\r
 104     "<!ENTITY " write\r
 105     [ name>> write " " write ]\r
 106     [ def>> write-xml-chunk ">" write ]\r
 107     bi ;\r
 108 \r
 109 M: system-id write-xml-chunk\r
 110     "SYSTEM '" write system-literal>> write "'" write ;\r
 111 \r
 112 M: public-id write-xml-chunk\r
 113     "PUBLIC '" write\r
 114     [ pubid-literal>> write "' '" write ]\r
 115     [ system-literal>> write "'>" write ] bi ;\r
 116 \r
 117 M: doctype-decl write-xml-chunk\r
 118     "<!DOCTYPE " write\r
 119     [ name>> write " " write ]\r
 120     [ external-id>> [ write-xml-chunk " " write ] when* ]\r
 121     [\r
 122         internal-subset>>\r
 123         [ "[" write [ write-xml-chunk ] each "]" write ] when* ">" write\r
 124     ] tri ;\r
 125 \r
 126 M: directive write-xml-chunk\r
 127     "<!" write text>> write CHAR: > write1 ;\r
 128 \r
 129 M: instruction write-xml-chunk\r
 130     "<?" write text>> write "?>" write ;\r
 131 \r
 132 M: sequence write-xml-chunk\r
 133     [ write-xml-chunk ] each ;\r
 134 \r
 135 : write-prolog ( xml -- )\r
 136     "<?xml version=\"" write dup version>> write\r
 137     "\" encoding=\"" write dup encoding>> write\r
 138     standalone>> [ "\" standalone=\"yes" write ] when\r
 139     "\"?>" write ;\r
 140 \r
 141 : write-xml ( xml -- )\r
 142     {\r
 143         [ prolog>> write-prolog ]\r
 144         [ before>> write-xml-chunk ]\r
 145         [ body>> write-xml-chunk ]\r
 146         [ after>> write-xml-chunk ]\r
 147     } cleave ;\r
 148 \r
 149 M: xml write-xml-chunk\r
 150     body>> write-xml-chunk ;\r
 151 \r
 152 : print-xml ( xml -- )\r
 153     write-xml nl ;\r
 154 \r
 155 : xml>string ( xml -- string )\r
 156     [ write-xml ] with-string-writer ;\r
 157 \r
 158 : with-xml-pprint ( sensitive-tags quot -- )\r
 159     [\r
 160         swap [ assure-name ] map sensitive-tags set\r
 161         0 indentation set\r
 162         xml-pprint? on\r
 163         call\r
 164     ] with-scope ; inline\r
 165 \r
 166 : pprint-xml-but ( xml sensitive-tags -- )\r
 167     [ print-xml ] with-xml-pprint ;\r
 168 \r
 169 : pprint-xml ( xml -- )\r
 170     f pprint-xml-but ;\r
 171 \r
 172 : pprint-xml>string-but ( xml sensitive-tags -- string )\r
 173     [ xml>string ] with-xml-pprint ;\r
 174 \r
 175 : pprint-xml>string ( xml -- string )\r
 176     f pprint-xml>string-but ;\r