parse-farkup (write-farkup) ;
: write-farkup ( string -- )
- farkup>xml write-xml-chunk ;
+ farkup>xml write-xml ;
: convert-farkup ( string -- string' )
[ write-farkup ] with-string-writer ;
[ f swap ]
if
] 2dip
- render* write-xml-chunk
+ render* write-xml
[ render-error ] when* ;
<PRIVATE
! HTML component
SINGLETON: html
-M: html render* 2drop string>xml-chunk ;
+M: html render* 2drop <unescaped> ;
-! cont-html v0.6
-!
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators present fry ;
+xml.data xml.interpolate urls math math.parser combinators
+present fry io.streams.string xml.writer ;
IN: html.elements
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title head-quot body-quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- spin
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head>
- <title> write </title>
- call
- </head>
- <body> call </body>
- </html> ; inline
+ [ with-string-writer <unescaped> ] bi@
+ <XML
+ <?xml version="1.0"?>
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title><-></title>
+ <->
+ </head>
+ <body><-></body>
+ </html>
+ XML> write-xml ;
: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
+ [XML <span class="error"><-></span> XML] write-xml ;
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
{ [ dup string? ] [ escape-string [write] ] }
{ [ dup comment? ] [ drop ] }
- [ [ write-xml-chunk ] [code-with] ]
+ [ [ write-xml ] [code-with] ]
} cond ;
: with-compiler ( quot -- quot' )
io.encodings.ascii
io.encodings.binary
io.streams.limited
+io.streams.string
io.servers.connection
io.timeouts
io.crlf
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
IN: lcs.diff2html.tests
-[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test
+[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
[
{ "content" "summary" } any-tag-named
dup children>> [ string? not ] contains?
- [ children>> [ write-xml-chunk ] with-string-writer ]
+ [ children>> xml>string ]
[ children>string ] if >>description
]
[
[
dup call-next-method write
"Misplaced XML prolog" print
- prolog>> write-prolog nl
+ prolog>> write-xml nl
] with-string-writer ;
TUPLE: capitalized-prolog < xml-error-at name ;
[
dup call-next-method write
"Misplaced directive:" print
- dir>> write-xml-chunk nl
+ dir>> write-xml nl
] with-string-writer ;
TUPLE: bad-name < xml-error-at name ;
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
-[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
-[ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
+[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
+[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
\ <XML must-infer
[ { } "" interpolate-xml ] must-infer
USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros
sequences.deep generalizations words combinators
-math present arrays ;
+math present arrays unicode.categories ;
IN: xml.interpolate
<PRIVATE
} cond ;
: parse-def ( accum delimiter quot -- accum )
- [ parse-multiline-string 1 short head* ] dip call
+ [ parse-multiline-string [ blank? ] trim ] dip call
[ extract-variables collect ] keep swap
[ number<-> parsed ] dip
[ \ interpolate-xml parsed ] when ; inline
GENERIC: (r-ref) ( xml -- )
M: tag (r-ref)
- sub-tag over at* [
+ dup sub-tag attr [
ref-table get at
>>children drop
- ] [ 2drop ] if ;
+ ] [ drop ] if* ;
M: object (r-ref) drop ;
: template ( xml -- )
[ "ID" attr >>id ]
[ "URI" attr >>uri ]
[ "SECTIONS" attr >>sections ]
- [ children>> xml-chunk>string >>description ]
+ [ children>> xml>string >>description ]
} cleave ;
: parse-tests ( xml -- tests )
tags@ swap [ tag-named? ] with filter ;
: tag-with-attr? ( elem attr-value attr-name -- ? )
- rot dup tag? [ at = ] [ 3drop f ] if ;
+ rot dup tag? [ swap attr = ] [ 3drop f ] if ;
: tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name '[ _ _ tag-with-attr? ] find nip ;
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup io strings ;
+USING: help.syntax help.markup io strings xml.data ;
IN: xml.writer
ABOUT: "xml.writer"
ARTICLE: "xml.writer" "Writing XML"
- "These words are used in implementing prettyprint"
- { $subsection write-xml-chunk }
- "These words are used to print XML normally"
- { $subsection xml>string }
+ "These words are used to print XML preserving whitespace in text nodes"
{ $subsection write-xml }
+ { $subsection xml>string }
"These words are used to prettyprint XML"
{ $subsection pprint-xml>string }
- { $subsection pprint-xml>string-but }
{ $subsection pprint-xml }
- { $subsection pprint-xml-but } ;
-
-HELP: write-xml-chunk
-{ $values { "object" "an XML element" } }
-{ $description "writes an XML element to " { $link output-stream } "." }
-{ $see-also write-xml-chunk write-xml } ;
+ "Certain variables can be changed to mainpulate prettyprinting"
+ { $subsection sensitive-tags }
+ { $subsection indenter }
+ "All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ;
HELP: xml>string
-{ $values { "xml" "an xml document" } { "string" "a string" } }
-{ $description "converts an XML document into a string" }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $values { "xml" "an XML document" } { "string" "a string" } }
+{ $description "This converts an XML document " { $link xml } " into a string. It can also be used to convert any piece of XML to a string, eg an " { $link xml-chunk } " or " { $link comment } "." }
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: pprint-xml>string
-{ $values { "xml" "an xml document" } { "string" "a string" } }
+{ $values { "xml" "an XML document" } { "string" "a string" } }
{ $description "converts an XML document into a string in a prettyprinted form." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: write-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document to " { $link output-stream } "." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: pprint-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document to " { $link output-stream } " in a prettyprinted form." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
-
-HELP: pprint-xml-but
-{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } }
-{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
-
-HELP: pprint-xml>string-but
-{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } }
-{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. Whitespace is also not preserved." } ;
-{ xml>string write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words
+{ xml>string write-xml pprint-xml pprint-xml>string } related-words
\ write-xml must-infer
\ xml>string must-infer
\ pprint-xml must-infer
-\ pprint-xml-but must-infer
+! Add a test for pprint-xml with sensitive-tags
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ "foo" ] [ T{ name { space "" } { main "foo" } } name>string ] unit-test
]>
<x>&foo;</x>"} pprint-reprints-as
-[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
+[ t ] [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\" >" dup string>xml-chunk xml>string = ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
-[ "<foo'>" ] [ "<foo'>" <unescaped> xml-chunk>string ] unit-test
+[ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
xml.data wrap xml.entities unicode.categories fry ;\r
IN: xml.writer\r
\r
-SYMBOL: xml-pprint?\r
SYMBOL: sensitive-tags\r
-SYMBOL: indentation\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? ] contains? ;\r
\r
\r
<PRIVATE\r
\r
+: write-quoted ( string -- )\r
+ CHAR: " write1 write CHAR: " write1 ;\r
+\r
: print-attrs ( assoc -- )\r
[\r
- " " write\r
- swap print-name\r
- "=\"" write\r
- escape-quoted-string write\r
- "\"" write\r
+ [ bl print-name "=" write ]\r
+ [ escape-quoted-string write-quoted ] bi*\r
] assoc-each ;\r
\r
PRIVATE>\r
\r
-GENERIC: write-xml-chunk ( object -- )\r
+GENERIC: write-xml ( object -- )\r
\r
<PRIVATE\r
\r
-M: string write-xml-chunk\r
+M: string write-xml\r
escape-string xml-pprint? get [\r
dup [ blank? ] all?\r
[ drop "" ]\r
: write-start-tag ( tag -- )\r
write-tag ">" write ;\r
\r
-M: contained-tag write-xml-chunk\r
+M: contained-tag write-xml\r
write-tag "/>" write ;\r
\r
: write-children ( tag -- )\r
indent children>> ?filter-children\r
- [ write-xml-chunk ] each unindent ;\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-chunk\r
+M: open-tag write-xml\r
xml-pprint? get [\r
{\r
[ sensitive? not xml-pprint? get and xml-pprint? set ]\r
} cleave\r
] dip xml-pprint? set ;\r
\r
-M: unescaped write-xml-chunk\r
+M: unescaped write-xml\r
string>> write ;\r
\r
-M: comment write-xml-chunk\r
+M: comment write-xml\r
"<!--" write text>> write "-->" write ;\r
\r
-M: element-decl write-xml-chunk\r
- "<!ELEMENT " write\r
- [ name>> write " " write ]\r
- [ content-spec>> write ">" write ]\r
- bi ;\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: attlist-decl write-xml-chunk\r
- "<!ATTLIST " write\r
- [ name>> write " " write ]\r
- [ att-defs>> write ">" write ]\r
- bi ;\r
+M: element-decl write-xml\r
+ "ELEMENT" [ content-spec>> ] write-decl ;\r
\r
-M: notation-decl write-xml-chunk\r
- "<!NOTATION " write\r
- [ name>> write " " write ]\r
- [ id>> write ">" write ]\r
- bi ;\r
+M: attlist-decl write-xml\r
+ "ATTLIST" [ att-defs>> ] write-decl ;\r
\r
-M: entity-decl write-xml-chunk\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-chunk ] with-variable\r
+ [ write-xml ] with-variable\r
"\">" write\r
] tri ;\r
\r
-M: system-id write-xml-chunk\r
- "SYSTEM '" write system-literal>> write "'" write ;\r
+M: system-id write-xml\r
+ "SYSTEM" write bl system-literal>> write-quoted ;\r
\r
-M: public-id write-xml-chunk\r
- "PUBLIC '" write\r
- [ pubid-literal>> write "' '" write ]\r
- [ system-literal>> write "'" write ] bi ;\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-chunk ] each\r
+ directives>> [ ?indent write-xml ] each\r
unindent ?indent "]" write\r
] when* ;\r
\r
-M: doctype-decl write-xml-chunk\r
+M: doctype-decl write-xml\r
?indent "<!DOCTYPE " write\r
[ name>> write " " write ]\r
- [ external-id>> [ write-xml-chunk " " write ] when* ]\r
+ [ external-id>> [ write-xml " " write ] when* ]\r
[ internal-subset>> write-internal-subset ">" write ] tri ;\r
\r
-M: directive write-xml-chunk\r
+M: directive write-xml\r
"<!" write text>> write CHAR: > write1 nl ;\r
\r
-M: instruction write-xml-chunk\r
+M: instruction write-xml\r
"<?" write text>> write "?>" write ;\r
\r
-M: number write-xml-chunk\r
+M: number write-xml\r
"Numbers are not allowed in XML" throw ;\r
\r
-M: sequence write-xml-chunk\r
- [ write-xml-chunk ] each ;\r
-\r
-PRIVATE>\r
+M: sequence write-xml\r
+ [ write-xml ] each ;\r
\r
-: write-prolog ( xml -- )\r
- "<?xml version=\"" write dup version>> write\r
- "\" encoding=\"" write dup encoding>> write\r
- standalone>> [ "\" standalone=\"yes" write ] when\r
- "\"?>" write ;\r
+M: prolog write-xml\r
+ "<?xml version=" write\r
+ [ version>> write-quoted ]\r
+ [ " encoding=" write encoding>> write-quoted ]\r
+ [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
+ "?>" write ;\r
\r
-: write-xml ( xml -- )\r
+M: xml write-xml\r
{\r
- [ prolog>> write-prolog ]\r
- [ before>> write-xml-chunk ]\r
- [ body>> write-xml-chunk ]\r
- [ after>> write-xml-chunk ]\r
+ [ prolog>> write-xml ]\r
+ [ before>> write-xml ]\r
+ [ body>> write-xml ]\r
+ [ after>> write-xml ]\r
} cleave ;\r
\r
-M: xml write-xml-chunk\r
- body>> write-xml-chunk ;\r
+PRIVATE>\r
\r
: xml>string ( xml -- string )\r
[ write-xml ] with-string-writer ;\r
\r
-: xml-chunk>string ( object -- string )\r
- [ write-xml-chunk ] with-string-writer ;\r
-\r
-: pprint-xml-but ( xml sensitive-tags -- )\r
+: pprint-xml ( xml -- )\r
[\r
- [ assure-name ] map sensitive-tags set\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 ( xml -- )\r
- f pprint-xml-but ;\r
-\r
-: pprint-xml>string-but ( xml sensitive-tags -- string )\r
- [ pprint-xml-but ] with-string-writer ;\r
-\r
: pprint-xml>string ( xml -- string )\r
- f pprint-xml>string-but ;\r
+ [ pprint-xml ] with-string-writer ;\r
projects / factor.git / commitdiff