-! Copyright (C) 2005, 2009 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: hashtables kernel math namespaces sequences strings\r
-assocs combinators io io.streams.string accessors\r
-xml.data wrap.strings xml.entities unicode.categories fry ;\r
-IN: xml.writer\r
-\r
-SYMBOL: sensitive-tags\r
-SYMBOL: indenter\r
-" " indenter set-global\r
-\r
-<PRIVATE\r
-\r
-SYMBOL: xml-pprint?\r
-SYMBOL: indentation\r
-\r
-: sensitive? ( tag -- ? )\r
- sensitive-tags get swap '[ _ names-match? ] any? ;\r
-\r
-: indent-string ( -- string )\r
- xml-pprint? get\r
- [ indentation get indenter get <repetition> "" concat-as ]\r
- [ "" ] if ;\r
-\r
-: ?indent ( -- )\r
- xml-pprint? get [ nl indent-string write ] when ;\r
-\r
-: indent ( -- )\r
- xml-pprint? get [ 1 indentation +@ ] when ;\r
-\r
-: unindent ( -- )\r
- xml-pprint? get [ -1 indentation +@ ] when ;\r
-\r
-: ?filter-children ( children -- no-whitespace )\r
- xml-pprint? get [\r
- [ dup string? [ [ blank? ] trim ] when ] map\r
- [ "" = ] reject\r
- ] when ;\r
-\r
-PRIVATE>\r
-\r
-: name>string ( name -- string )\r
- [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;\r
-\r
-: print-name ( name -- )\r
- name>string write ;\r
-\r
-<PRIVATE\r
-\r
-: write-quoted ( string -- )\r
- CHAR: " write1 write CHAR: " write1 ;\r
-\r
-: print-attrs ( assoc -- )\r
- [\r
- [ bl print-name "=" write ]\r
- [ escape-quoted-string write-quoted ] bi*\r
- ] assoc-each ;\r
-\r
-PRIVATE>\r
-\r
-GENERIC: write-xml ( xml -- )\r
-\r
-<PRIVATE\r
-\r
-M: string write-xml\r
- escape-string xml-pprint? get [\r
- dup [ blank? ] all?\r
- [ drop "" ]\r
- [ nl 80 indent-string wrap-indented-string ] if\r
- ] when write ;\r
-\r
-: write-tag ( tag -- )\r
- ?indent CHAR: < write1\r
- dup print-name attrs>> print-attrs ;\r
-\r
-: write-start-tag ( tag -- )\r
- write-tag ">" write ;\r
-\r
-M: contained-tag write-xml\r
- write-tag "/>" write ;\r
-\r
-: write-children ( tag -- )\r
- indent children>> ?filter-children\r
- [ write-xml ] each unindent ;\r
-\r
-: write-end-tag ( tag -- )\r
- ?indent "</" write print-name CHAR: > write1 ;\r
-\r
-M: open-tag write-xml\r
- xml-pprint? get [\r
- {\r
- [ write-start-tag ]\r
- [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
- [ write-children ]\r
- [ write-end-tag ]\r
- } cleave\r
- ] dip xml-pprint? set ;\r
-\r
-M: unescaped write-xml\r
- string>> write ;\r
-\r
-M: comment write-xml\r
- "<!--" write text>> write "-->" write ;\r
-\r
-: write-decl ( decl name quot: ( decl -- slot ) -- )\r
- "<!" write swap write bl\r
- [ name>> write bl ]\r
- swap '[ @ write ">" write ] bi ; inline\r
-\r
-M: element-decl write-xml\r
- "ELEMENT" [ content-spec>> ] write-decl ;\r
-\r
-M: attlist-decl write-xml\r
- "ATTLIST" [ att-defs>> ] write-decl ;\r
-\r
-M: notation-decl write-xml\r
- "NOTATION" [ id>> ] write-decl ;\r
-\r
-M: entity-decl write-xml\r
- "<!ENTITY " write\r
- [ pe?>> [ " % " write ] when ]\r
- [ name>> write " \"" write ] [\r
- def>> f xml-pprint?\r
- [ write-xml ] with-variable\r
- "\">" write\r
- ] tri ;\r
-\r
-M: system-id write-xml\r
- "SYSTEM" write bl system-literal>> write-quoted ;\r
-\r
-M: public-id write-xml\r
- "PUBLIC" write bl\r
- [ pubid-literal>> write-quoted bl ]\r
- [ system-literal>> write-quoted ] bi ;\r
-\r
-: write-internal-subset ( dtd -- )\r
- [\r
- "[" write indent\r
- directives>> [ ?indent write-xml ] each\r
- unindent ?indent "]" write\r
- ] when* ;\r
-\r
-M: doctype-decl write-xml\r
- ?indent "<!DOCTYPE " write\r
- [ name>> write bl ]\r
- [ external-id>> [ write-xml bl ] when* ]\r
- [ internal-subset>> write-internal-subset ">" write ] tri ;\r
-\r
-M: directive write-xml\r
- "<!" write text>> write CHAR: > write1 nl ;\r
-\r
-M: instruction write-xml\r
- "<?" write text>> write "?>" write ;\r
-\r
-M: number write-xml\r
- "Numbers are not allowed in XML" throw ;\r
-\r
-M: sequence write-xml\r
- [ write-xml ] each ;\r
-\r
-M: prolog write-xml\r
- "<?xml version=" write\r
- [ version>> write-quoted ]\r
- [ drop " encoding=\"UTF-8\"" write ]\r
- [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
- "?>" write ;\r
-\r
-M: xml write-xml\r
- {\r
- [ prolog>> write-xml ]\r
- [ before>> write-xml ]\r
- [ body>> write-xml ]\r
- [ after>> write-xml ]\r
- } cleave ;\r
-\r
-PRIVATE>\r
-\r
-: xml>string ( xml -- string )\r
- [ write-xml ] with-string-writer ;\r
-\r
-: pprint-xml ( xml -- )\r
- [\r
- sensitive-tags [ [ assure-name ] map ] change\r
- 0 indentation set\r
- xml-pprint? on\r
- write-xml\r
- ] with-scope ;\r
-\r
-: pprint-xml>string ( xml -- string )\r
- [ pprint-xml ] with-string-writer ;\r
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: hashtables kernel math namespaces sequences strings
+assocs combinators io io.streams.string accessors
+xml.data wrap.strings xml.entities unicode.categories fry ;
+IN: xml.writer
+
+SYMBOL: sensitive-tags
+SYMBOL: indenter
+" " indenter set-global
+
+<PRIVATE
+
+SYMBOL: xml-pprint?
+SYMBOL: indentation
+
+: sensitive? ( tag -- ? )
+ sensitive-tags get swap '[ _ names-match? ] any? ;
+
+: indent-string ( -- string )
+ xml-pprint? get
+ [ indentation get indenter get <repetition> "" concat-as ]
+ [ "" ] if ;
+
+: ?indent ( -- )
+ xml-pprint? get [ nl indent-string write ] when ;
+
+: indent ( -- )
+ xml-pprint? get [ 1 indentation +@ ] when ;
+
+: unindent ( -- )
+ xml-pprint? get [ -1 indentation +@ ] when ;
+
+: ?filter-children ( children -- no-whitespace )
+ xml-pprint? get [
+ [ dup string? [ [ blank? ] trim ] when ] map
+ [ "" = ] reject
+ ] when ;
+
+PRIVATE>
+
+: name>string ( name -- string )
+ [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
+
+: print-name ( name -- )
+ name>string write ;
+
+<PRIVATE
+
+: write-quoted ( string -- )
+ CHAR: " write1 write CHAR: " write1 ;
+
+: print-attrs ( assoc -- )
+ [
+ [ bl print-name "=" write ]
+ [ escape-quoted-string write-quoted ] bi*
+ ] assoc-each ;
+
+PRIVATE>
+
+GENERIC: write-xml ( xml -- )
+
+<PRIVATE
+
+M: string write-xml
+ escape-string xml-pprint? get [
+ dup [ blank? ] all?
+ [ drop "" ]
+ [ nl 80 indent-string wrap-indented-string ] if
+ ] when write ;
+
+: write-tag ( tag -- )
+ ?indent CHAR: < write1
+ dup print-name attrs>> print-attrs ;
+
+: write-start-tag ( tag -- )
+ write-tag ">" write ;
+
+M: contained-tag write-xml
+ write-tag "/>" write ;
+
+: write-children ( tag -- )
+ indent children>> ?filter-children
+ [ write-xml ] each unindent ;
+
+: write-end-tag ( tag -- )
+ ?indent "</" write print-name CHAR: > write1 ;
+
+M: open-tag write-xml
+ xml-pprint? get [
+ {
+ [ write-start-tag ]
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]
+ [ write-children ]
+ [ write-end-tag ]
+ } cleave
+ ] dip xml-pprint? set ;
+
+M: unescaped write-xml
+ string>> write ;
+
+M: comment write-xml
+ "<!--" write text>> write "-->" write ;
+
+: write-decl ( decl name quot: ( decl -- slot ) -- )
+ "<!" write swap write bl
+ [ name>> write bl ]
+ swap '[ @ write ">" write ] bi ; inline
+
+M: element-decl write-xml
+ "ELEMENT" [ content-spec>> ] write-decl ;
+
+M: attlist-decl write-xml
+ "ATTLIST" [ att-defs>> ] write-decl ;
+
+M: notation-decl write-xml
+ "NOTATION" [ id>> ] write-decl ;
+
+M: entity-decl write-xml
+ "<!ENTITY " write
+ [ pe?>> [ " % " write ] when ]
+ [ name>> write " \"" write ] [
+ def>> f xml-pprint?
+ [ write-xml ] with-variable
+ "\">" write
+ ] tri ;
+
+M: system-id write-xml
+ "SYSTEM" write bl system-literal>> write-quoted ;
+
+M: public-id write-xml
+ "PUBLIC" write bl
+ [ pubid-literal>> write-quoted bl ]
+ [ system-literal>> write-quoted ] bi ;
+
+: write-internal-subset ( dtd -- )
+ [
+ "[" write indent
+ directives>> [ ?indent write-xml ] each
+ unindent ?indent "]" write
+ ] when* ;
+
+M: doctype-decl write-xml
+ ?indent "<!DOCTYPE " write
+ [ name>> write bl ]
+ [ external-id>> [ write-xml bl ] when* ]
+ [ internal-subset>> write-internal-subset ">" write ] tri ;
+
+M: directive write-xml
+ "<!" write text>> write CHAR: > write1 nl ;
+
+M: instruction write-xml
+ "<?" write text>> write "?>" write ;
+
+M: number write-xml
+ "Numbers are not allowed in XML" throw ;
+
+M: sequence write-xml
+ [ write-xml ] each ;
+
+M: prolog write-xml
+ "<?xml version=" write
+ [ version>> write-quoted ]
+ [ drop " encoding=\"UTF-8\"" write ]
+ [ standalone>> [ " standalone=\"yes\"" write ] when ] tri
+ "?>" write ;
+
+M: xml write-xml
+ {
+ [ prolog>> write-xml ]
+ [ before>> write-xml ]
+ [ body>> write-xml ]
+ [ after>> write-xml ]
+ } cleave ;
+
+PRIVATE>
+
+: xml>string ( xml -- string )
+ [ write-xml ] with-string-writer ;
+
+: pprint-xml ( xml -- )
+ [
+ sensitive-tags [ [ assure-name ] map ] change
+ 0 indentation set
+ xml-pprint? on
+ write-xml
+ ] with-scope ;
+
+: pprint-xml>string ( xml -- string )
+ [ pprint-xml ] with-string-writer ;
projects / factor.git / blobdiff