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\r
   5 xml.data wrap xml.entities unicode.categories ;\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? ] curry 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         [ dup empty? swap string? and not ] filter\r
  38     ] when ;\r
  39 \r
  40 : print-name ( name -- )\r
  41     dup name-space f like\r
  42     [ write CHAR: : write1 ] when*\r
  43     name-tag write ;\r
  44 \r
  45 : print-attrs ( assoc -- )\r
  46     [\r
  47         " " write\r
  48         swap print-name\r
  49         "=\"" write\r
  50         escape-quoted-string write\r
  51         "\"" write\r
  52     ] assoc-each ;\r
  53 \r
  54 GENERIC: write-item ( object -- )\r
  55 \r
  56 M: string write-item\r
  57     escape-string dup empty? not xml-pprint? get and\r
  58     [ nl 80 indent-string indented-break ] when write ;\r
  59 \r
  60 : write-tag ( tag -- )\r
  61     ?indent CHAR: < write1\r
  62     dup print-name tag-attrs print-attrs ;\r
  63 \r
  64 : write-start-tag ( tag -- )\r
  65     write-tag ">" write ;\r
  66 \r
  67 M: contained-tag write-item\r
  68     write-tag "/>" write ;\r
  69 \r
  70 : write-children ( tag -- )\r
  71     indent tag-children ?filter-children\r
  72     [ write-item ] each unindent ;\r
  73 \r
  74 : write-end-tag ( tag -- )\r
  75     ?indent "</" write print-name CHAR: > write1 ;\r
  76 \r
  77 M: open-tag write-item\r
  78     xml-pprint? get >r\r
  79     {\r
  80         [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
  81         [ write-start-tag ]\r
  82         [ write-children ]\r
  83         [ write-end-tag ]\r
  84     } cleave\r
  85     r> xml-pprint? set ;\r
  86 \r
  87 M: comment write-item\r
  88     "<!--" write comment-text write "-->" write ;\r
  89 \r
  90 M: directive write-item\r
  91     "<!" write directive-text write CHAR: > write1 ;\r
  92 \r
  93 M: instruction write-item\r
  94     "<?" write instruction-text write "?>" write ;\r
  95 \r
  96 : write-prolog ( xml -- )\r
  97     "<?xml version=\"" write dup prolog-version write\r
  98     "\" encoding=\"" write dup prolog-encoding write\r
  99     prolog-standalone [ "\" standalone=\"yes" write ] when\r
 100     "\"?>" write ;\r
 101 \r
 102 : write-chunk ( seq -- )\r
 103     [ write-item ] each ;\r
 104 \r
 105 : write-xml ( xml -- )\r
 106     {\r
 107         [ xml-prolog write-prolog ]\r
 108         [ xml-before write-chunk ]\r
 109         [ write-item ]\r
 110         [ xml-after write-chunk ]\r
 111     } cleave ;\r
 112 \r
 113 : print-xml ( xml -- )\r
 114     write-xml nl ;\r
 115 \r
 116 : xml>string ( xml -- string )\r
 117     [ write-xml ] with-string-writer ;\r
 118 \r
 119 : with-xml-pprint ( sensitive-tags quot -- )\r
 120     [\r
 121         swap [ assure-name ] map sensitive-tags set\r
 122         0 indentation set\r
 123         xml-pprint? on\r
 124         call\r
 125     ] with-scope ; inline\r
 126 \r
 127 : pprint-xml-but ( xml sensitive-tags -- )\r
 128     [ print-xml ] with-xml-pprint ;\r
 129 \r
 130 : pprint-xml ( xml -- )\r
 131     f pprint-xml-but ;\r
 132 \r
 133 : pprint-xml>string-but ( xml sensitive-tags -- string )\r
 134     [ xml>string ] with-xml-pprint ;\r
 135 \r
 136 : pprint-xml>string ( xml -- string )\r
 137     f pprint-xml>string-but ;\r