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. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations USING: io kernel namespaces prettyprint quotations
sequences strings words ; sequences strings words xml.writer ;
IN: html.elements IN: html.elements
@ -123,7 +123,7 @@ SYMBOL: html
" " write-html " " write-html
write-html write-html
"='" write-html "='" write-html
write escape-quoted-string write
"'" write-html ; "'" write-html ;
: define-attribute-word ( name -- ) : 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 ; table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string ) : do-escaping ( string style -- string )
html swap at [ chars>entities ] unless ; html swap at [ escape-string ] unless ;
PRIVATE> PRIVATE>
@ -151,13 +151,13 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ; >r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- ) 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' ) M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ; html-span-stream <html-sub-stream> ;
M: html-stream stream-format ( str style 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 ; format-html-span ;
M: html-stream make-block-stream ( style stream -- stream' ) 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 sample-doc string>xml dup template xml>string
] with-scope ; ] 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 ] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
[ "that" ] [ xml-file get "this" swap at ] 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 [ "<a b='c'/>" string>xml xml>string ] unit-test
[ "abcd" ] [ [ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml "<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 at swap "z" >r tuck r> swap set-at
T{ name f "blah" "z" f } swap at ] unit-test T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] 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 [ "<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 ; io io.streams.string xml.data assocs ;
IN: xml.writer 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{ H{
{ CHAR: < "&lt;" } { CHAR: < "&lt;" }
{ CHAR: > "&gt;" } { CHAR: > "&gt;" }
{ CHAR: & "&amp;" } { CHAR: & "&amp;" }
} ;
: quoted-entities-out
H{
{ CHAR: & "&amp;" }
{ CHAR: ' "&apos;" } { CHAR: ' "&apos;" }
{ CHAR: " "&quot;" } { CHAR: " "&quot;" }
} ; } ;
: chars>entities ( str -- str ) : escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities. #! 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 -- ) : print-name ( name -- )
dup name-space f like dup name-space f like
@ -27,27 +69,35 @@ IN: xml.writer
" " write " " write
swap print-name swap print-name
"=\"" write "=\"" write
chars>entities write escape-quoted-string write
"\"" write "\"" write
] assoc-each ; ] assoc-each ;
GENERIC: write-item ( object -- ) GENERIC: write-item ( object -- )
M: string write-item 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 M: contained-tag write-item
CHAR: < write1 write-tag "/>" write ;
dup print-name tag-attrs print-attrs
"/>" 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 M: open-tag write-item
CHAR: < write1 xml-pprint? [ [
dup print-name over sensitive? not and xml-pprint? set
dup tag-attrs print-attrs dup write-tag CHAR: > write1
CHAR: > write1 dup write-children write-end-tag
dup tag-children [ write-item ] each ] keep ] change ;
"</" write print-name CHAR: > write1 ;
M: comment write-item M: comment write-item
"<!--" write comment-text write "-->" write ; "<!--" write comment-text write "-->" write ;
@ -62,7 +112,7 @@ M: instruction write-item
"<?xml version=\"" write dup prolog-version write "<?xml version=\"" write dup prolog-version write
"\" encoding=\"" write dup prolog-encoding write "\" encoding=\"" write dup prolog-encoding write
prolog-standalone [ "\" standalone=\"yes" write ] when prolog-standalone [ "\" standalone=\"yes" write ] when
"\"?>" write ; "\"?>\n" write ;
: write-chunk ( seq -- ) : write-chunk ( seq -- )
[ write-item ] each ; [ write-item ] each ;
@ -79,3 +129,22 @@ M: instruction write-item
: xml>string ( xml -- string ) : xml>string ( xml -- string )
[ write-xml ] string-out ; [ 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 ;