basis/xml/writer/writer.factor

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