steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing everything I broke?

db4
Daniel Ehrenberg 2009-01-29 13:33:04 -06:00
parent 356ee5ced5
commit 6372395b8a
16 changed files with 108 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/farkup/farkup.factor
View File

@ -236,7 +236,7 @@ M: f (write-farkup) ;
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 ;

4
basis/html/components/components.factor
View File

@ -19,7 +19,7 @@ GENERIC: render* ( value name renderer -- xml )
[ f swap ]
if
] 2dip
render* write-xml-chunk
render* write-xml
[ render-error ] when* ;
<PRIVATE
@ -176,4 +176,4 @@ M: comparison render*
! HTML component
SINGLETON: html
M: html render* 2drop string>xml-chunk ;
M: html render* 2drop <unescaped> ;

29
basis/html/elements/elements.factor
View File

@ -1,11 +1,9 @@
! 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
@ -135,17 +133,18 @@ SYMBOL: html
"<!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>
[ 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> write </title>
call
<title><-></title>
<->
</head>
<body> call </body>
</html> ; inline
<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 ;

2
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -90,7 +90,7 @@ ERROR: unknown-chloe-tag tag ;
{ [ 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' )

1
basis/http/server/server.factor
View File

@ -12,6 +12,7 @@ io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.streams.string
io.servers.connection
io.timeouts
io.crlf

2
basis/lcs/diff2html/diff2html-tests.factor
View File

@ -3,4 +3,4 @@
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

2
basis/syndication/syndication.factor
View File

@ -81,7 +81,7 @@ TUPLE: entry title url description date ;
[
{ "content" "summary" } any-tag-named
dup children>> [ string? not ] contains?
[ children>> [ write-xml-chunk ] with-string-writer ]
[ children>> xml>string ]
[ children>string ] if >>description
]
[

4
basis/xml/errors/errors.factor
View File

@ -194,7 +194,7 @@ M: bad-prolog summary ( obj -- str )
[
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 ;
@ -258,7 +258,7 @@ M: misplaced-directive summary ( obj -- str )
[
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 ;

4
basis/xml/interpolate/interpolate-tests.factor
View File

@ -51,8 +51,8 @@ IN: xml.interpolate.tests
<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

4
basis/xml/interpolate/interpolate.factor
View File

@ -3,7 +3,7 @@
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
@ -95,7 +95,7 @@ M: xml-chunk interpolate-xml
} 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

4
basis/xml/tests/templating.factor
View File

@ -9,10 +9,10 @@ SYMBOL: ref-table
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 -- )

2
basis/xml/tests/xmltest.factor
View File

@ -11,7 +11,7 @@ TUPLE: xml-test id uri sections description type ;
[ "ID" attr >>id ]
[ "URI" attr >>uri ]
[ "SECTIONS" attr >>sections ]
[ children>> xml-chunk>string >>description ]
[ children>> xml>string >>description ]
} cleave ;
: parse-tests ( xml -- tests )

2
basis/xml/utilities/utilities.factor
View File

@ -38,7 +38,7 @@ IN: xml.utilities
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 ;

45
basis/xml/writer/writer-docs.factor
View File

@ -1,56 +1,41 @@
! 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" } ;
{ $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." } ;
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" } ;
{ 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

6
basis/xml/writer/writer-tests.factor
View File

@ -7,7 +7,7 @@ IN: xml.writer.tests
\ 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
@ -51,11 +51,11 @@ IN: xml.writer.tests
]>
<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

128
basis/xml/writer/writer.factor
View File

@ -5,14 +5,15 @@ assocs combinators io io.streams.string accessors
xml.data wrap xml.entities unicode.categories fry ;
IN: xml.writer
SYMBOL: xml-pprint?
SYMBOL: sensitive-tags
SYMBOL: indentation
SYMBOL: indenter
" " indenter set-global
<PRIVATE
SYMBOL: xml-pprint?
SYMBOL: indentation
: sensitive? ( tag -- ? )
sensitive-tags get swap '[ _ names-match? ] contains? ;
@ -49,22 +50,22 @@ PRIVATE>
<PRIVATE
: write-quoted ( string -- )
CHAR: " write1 write CHAR: " write1 ;
: print-attrs ( assoc -- )
[
" " write
swap print-name
"=\"" write
escape-quoted-string write
"\"" write
[ bl print-name "=" write ]
[ escape-quoted-string write-quoted ] bi*
] assoc-each ;
PRIVATE>
GENERIC: write-xml-chunk ( object -- )
GENERIC: write-xml ( object -- )
<PRIVATE
M: string write-xml-chunk
M: string write-xml
escape-string xml-pprint? get [
dup [ blank? ] all?
[ drop "" ]
@ -78,17 +79,17 @@ M: string write-xml-chunk
: write-start-tag ( tag -- )
write-tag ">" write ;
M: contained-tag write-xml-chunk
M: contained-tag write-xml
write-tag "/>" write ;
: write-children ( tag -- )
indent children>> ?filter-children
[ write-xml-chunk ] each unindent ;
[ write-xml ] each unindent ;
: write-end-tag ( tag -- )
?indent "</" write print-name CHAR: > write1 ;
M: open-tag write-xml-chunk
M: open-tag write-xml
xml-pprint? get [
{
[ sensitive? not xml-pprint? get and xml-pprint? set ]
@ -98,110 +99,95 @@ M: open-tag write-xml-chunk
} cleave
] dip xml-pprint? set ;
M: unescaped write-xml-chunk
M: unescaped write-xml
string>> write ;
M: comment write-xml-chunk
M: comment write-xml
"<!--" write text>> write "-->" write ;
M: element-decl write-xml-chunk
"<!ELEMENT " write
[ name>> write " " write ]
[ content-spec>> write ">" write ]
bi ;
: write-decl ( decl name quot: ( decl -- slot ) -- )
"<!" write swap write bl
[ name>> write bl ]
swap '[ @ write ">" write ] bi ; inline
M: attlist-decl write-xml-chunk
"<!ATTLIST " write
[ name>> write " " write ]
[ att-defs>> write ">" write ]
bi ;
M: element-decl write-xml
"ELEMENT" [ content-spec>> ] write-decl ;
M: notation-decl write-xml-chunk
"<!NOTATION " write
[ name>> write " " write ]
[ id>> write ">" write ]
bi ;
M: attlist-decl write-xml
"ATTLIST" [ att-defs>> ] write-decl ;
M: entity-decl write-xml-chunk
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-chunk ] with-variable
[ write-xml ] with-variable
"\">" write
] tri ;
M: system-id write-xml-chunk
"SYSTEM '" write system-literal>> write "'" write ;
M: system-id write-xml
"SYSTEM" write bl system-literal>> write-quoted ;
M: public-id write-xml-chunk
"PUBLIC '" write
[ pubid-literal>> write "' '" write ]
[ system-literal>> write "'" write ] bi ;
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-chunk ] each
directives>> [ ?indent write-xml ] each
unindent ?indent "]" write
] when* ;
M: doctype-decl write-xml-chunk
M: doctype-decl write-xml
?indent "<!DOCTYPE " write
[ name>> write " " write ]
[ external-id>> [ write-xml-chunk " " write ] when* ]
[ external-id>> [ write-xml " " write ] when* ]
[ internal-subset>> write-internal-subset ">" write ] tri ;
M: directive write-xml-chunk
M: directive write-xml
"<!" write text>> write CHAR: > write1 nl ;
M: instruction write-xml-chunk
M: instruction write-xml
"<?" write text>> write "?>" write ;
M: number write-xml-chunk
M: number write-xml
"Numbers are not allowed in XML" throw ;
M: sequence write-xml-chunk
[ write-xml-chunk ] each ;
M: sequence write-xml
[ write-xml ] each ;
PRIVATE>
M: prolog write-xml
"<?xml version=" write
[ version>> write-quoted ]
[ " encoding=" write encoding>> write-quoted ]
[ standalone>> [ " standalone=\"yes\"" write ] when ] tri
"?>" write ;
: write-prolog ( xml -- )
"<?xml version=\"" write dup version>> write
"\" encoding=\"" write dup encoding>> write
standalone>> [ "\" standalone=\"yes" write ] when
"\"?>" write ;
: write-xml ( xml -- )
M: xml write-xml
{
[ prolog>> write-prolog ]
[ before>> write-xml-chunk ]
[ body>> write-xml-chunk ]
[ after>> write-xml-chunk ]
[ prolog>> write-xml ]
[ before>> write-xml ]
[ body>> write-xml ]
[ after>> write-xml ]
} cleave ;
M: xml write-xml-chunk
body>> write-xml-chunk ;
PRIVATE>
: xml>string ( xml -- string )
[ write-xml ] with-string-writer ;
: xml-chunk>string ( object -- string )
[ write-xml-chunk ] with-string-writer ;
: pprint-xml-but ( xml sensitive-tags -- )
: pprint-xml ( xml -- )
[
[ assure-name ] map sensitive-tags set
sensitive-tags [ [ assure-name ] map ] change
0 indentation set
xml-pprint? on
write-xml
] with-scope ;
: pprint-xml ( xml -- )
f pprint-xml-but ;
: pprint-xml>string-but ( xml sensitive-tags -- string )
[ pprint-xml-but ] with-string-writer ;
: pprint-xml>string ( xml -- string )
f pprint-xml>string-but ;
[ pprint-xml ] with-string-writer ;