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

XML prettyprinter

db4
Daniel Ehrenberg 2007-12-29 01:33:21 -05:00
parent c936895160
commit 4a28fe910d
5 changed files with 94 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/html/elements/elements.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words ;
sequences strings words xml.writer ;
IN: html.elements
@ -123,7 +123,7 @@ SYMBOL: html
" " write-html
write-html
"='" write-html
write
escape-quoted-string write
"'" write-html ;
: define-attribute-word ( name -- )

6
extra/html/html.factor
View File

@ -142,7 +142,7 @@ M: html-block-stream stream-close ( quot style stream -- )
table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ chars>entities ] unless ;
html swap at [ escape-string ] unless ;
PRIVATE>
@ -151,13 +151,13 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- )
>r chars>entities r> delegate stream-write ;
>r escape-string r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ;
M: html-stream stream-format ( str style stream -- )
>r html over at [ >r chars>entities r> ] unless r>
>r html over at [ >r escape-string r> ] unless r>
format-html-span ;
M: html-stream make-block-stream ( style stream -- stream' )

2
extra/xml/test/templating.factor
View File

@ -40,4 +40,4 @@ M: object (r-ref) drop ;
sample-doc string>xml dup template xml>string
] with-scope ;
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test

6
extra/xml/test/test.factor
View File

@ -26,7 +26,7 @@ SYMBOL: xml-file
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
[ "that" ] [ xml-file get "this" swap at ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
@ -44,5 +44,7 @@ SYMBOL: xml-file
at swap "z" >r tuck r> swap set-at
T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test

99
extra/xml/writer/writer.factor
View File

@ -4,18 +4,60 @@ USING: hashtables kernel math namespaces sequences strings
io io.streams.string xml.data assocs ;
IN: xml.writer
: write-entities
SYMBOL: xml-pprint?
SYMBOL: sensitive-tags
SYMBOL: indentation
SYMBOL: indenter
" " indenter set-global
: sensitive? ( tag -- ? )
sensitive-tags get swap [ names-match? ] curry contains? ;
: ?indent ( -- )
xml-pprint? get [
nl indentation get indenter get <repetition> [ write ] each
] when ;
: indent ( -- )
xml-pprint? get [ 1 indentation +@ ] when ;
: unindent ( -- )
xml-pprint? get [ -1 indentation +@ ] when ;
: trim-whitespace ( string -- no-whitespace )
[ [ blank? not ] find drop 0 or ] keep
[ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
subseq ;
: ?filter-children ( children -- no-whitespace )
xml-pprint? get [
[ dup string? [ trim-whitespace ] when ] map
[ dup empty? swap string? and not ] subset
] when ;
: entities-out
H{
{ CHAR: < "&lt;" }
{ CHAR: > "&gt;" }
{ CHAR: & "&amp;" }
} ;
: quoted-entities-out
H{
{ CHAR: & "&amp;" }
{ CHAR: ' "&apos;" }
{ CHAR: " "&quot;" }
} ;
: chars>entities ( str -- str )
: escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities.
[ [ dup write-entities at [ % ] [ , ] ?if ] each ] "" make ;
[ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
: escape-string ( str -- newstr )
entities-out escape-string-by ;
: escape-quoted-string ( str -- newstr )
quoted-entities-out escape-string-by ;
: print-name ( name -- )
dup name-space f like
@ -27,27 +69,35 @@ IN: xml.writer
" " write
swap print-name
"=\"" write
chars>entities write
escape-quoted-string write
"\"" write
] assoc-each ;
GENERIC: write-item ( object -- )
M: string write-item
chars>entities write ;
escape-string write ;
: write-tag ( tag -- )
CHAR: < write1
dup print-name tag-attrs print-attrs ;
M: contained-tag write-item
CHAR: < write1
dup print-name tag-attrs print-attrs
"/>" write ;
write-tag "/>" write ;
: write-children ( tag -- )
indent tag-children ?filter-children
[ ?indent write-item ] each unindent ;
: write-end-tag ( tag -- )
?indent "</" write print-name CHAR: > write1 ;
M: open-tag write-item
CHAR: < write1
dup print-name
dup tag-attrs print-attrs
CHAR: > write1
dup tag-children [ write-item ] each
"</" write print-name CHAR: > write1 ;
xml-pprint? [ [
over sensitive? not and xml-pprint? set
dup write-tag CHAR: > write1
dup write-children write-end-tag
] keep ] change ;
M: comment write-item
"<!--" write comment-text write "-->" write ;
@ -62,7 +112,7 @@ M: instruction write-item
"<?xml version=\"" write dup prolog-version write
"\" encoding=\"" write dup prolog-encoding write
prolog-standalone [ "\" standalone=\"yes" write ] when
"\"?>" write ;
"\"?>\n" write ;
: write-chunk ( seq -- )
[ write-item ] each ;
@ -79,3 +129,22 @@ M: instruction write-item
: xml>string ( xml -- string )
[ write-xml ] string-out ;
: with-xml-pprint ( sensitive-tags quot -- )
[
swap [ assure-name ] map sensitive-tags set
0 indentation set
xml-pprint? on
call
] with-scope ; inline
: pprint-xml-but ( xml sensitive-tags -- )
[ print-xml ] with-xml-pprint ;
: pprint-xml ( xml -- )
f pprint-xml-but ;
: pprint-xml>string-but ( xml sensitive-tags -- string )
[ xml>string ] with-xml-pprint ;
: pprint-xml>string ( xml -- string )
f pprint-xml>string-but ;