XML chunks are a separate datatype; XML tags are no longer assocs
parent
5402778655
commit
af9d70c65a
|
@ -70,8 +70,8 @@ TUPLE: entry title url description date ;
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
: atom-entry-link ( tag -- url/f )
|
: atom-entry-link ( tag -- url/f )
|
||||||
"link" tags-named [ "rel" swap at "alternate" = ] find nip
|
"link" tags-named [ "rel" attr "alternate" = ] find nip
|
||||||
dup [ "href" swap at >url ] when ;
|
dup [ "href" attr >url ] when ;
|
||||||
|
|
||||||
: atom1.0-entry ( tag -- entry )
|
: atom1.0-entry ( tag -- entry )
|
||||||
entry new
|
entry new
|
||||||
|
@ -95,7 +95,7 @@ TUPLE: entry title url description date ;
|
||||||
feed new
|
feed new
|
||||||
swap
|
swap
|
||||||
[ "title" tag-named children>string >>title ]
|
[ "title" tag-named children>string >>title ]
|
||||||
[ "link" tag-named "href" swap at >url >>url ]
|
[ "link" tag-named "href" attr >url >>url ]
|
||||||
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
|
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
|
|
|
@ -150,9 +150,11 @@ TUPLE: tag
|
||||||
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
|
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
|
||||||
tag boa ;
|
tag boa ;
|
||||||
|
|
||||||
! For convenience, tags follow the assoc protocol too (for attrs)
|
: attr ( tag name -- string )
|
||||||
CONSULT: assoc-protocol tag attrs>> ;
|
swap attrs>> at ;
|
||||||
INSTANCE: tag assoc
|
|
||||||
|
: set-attr ( tag value name -- )
|
||||||
|
rot attrs>> set-at ;
|
||||||
|
|
||||||
! They also follow the sequence protocol (for children)
|
! They also follow the sequence protocol (for children)
|
||||||
CONSULT: sequence-protocol tag children>> ;
|
CONSULT: sequence-protocol tag children>> ;
|
||||||
|
@ -217,8 +219,14 @@ M: xml like
|
||||||
PREDICATE: contained-tag < tag children>> not ;
|
PREDICATE: contained-tag < tag children>> not ;
|
||||||
PREDICATE: open-tag < tag children>> ;
|
PREDICATE: open-tag < tag children>> ;
|
||||||
|
|
||||||
UNION: xml-data
|
|
||||||
tag comment string directive instruction ;
|
|
||||||
|
|
||||||
TUPLE: unescaped string ;
|
TUPLE: unescaped string ;
|
||||||
C: <unescaped> unescaped
|
C: <unescaped> unescaped
|
||||||
|
|
||||||
|
UNION: xml-data
|
||||||
|
tag comment string directive instruction unescaped ;
|
||||||
|
|
||||||
|
TUPLE: xml-chunk seq ;
|
||||||
|
C: <xml-chunk> xml-chunk
|
||||||
|
|
||||||
|
CONSULT: sequence-protocol xml-chunk seq>> ;
|
||||||
|
INSTANCE: xml-chunk sequence
|
||||||
|
|
|
@ -65,11 +65,12 @@ IN: xml.elements
|
||||||
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
|
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
|
||||||
|
|
||||||
: prolog-version ( alist -- version )
|
: prolog-version ( alist -- version )
|
||||||
T{ name f "" "version" f } swap at
|
T{ name { space "" } { main "version" } } swap at
|
||||||
[ good-version ] [ versionless-prolog ] if* ;
|
[ good-version ] [ versionless-prolog ] if* ;
|
||||||
|
|
||||||
: prolog-encoding ( alist -- encoding )
|
: prolog-encoding ( alist -- encoding )
|
||||||
T{ name f "" "encoding" f } swap at "UTF-8" or ;
|
T{ name { space "" } { main "encoding" } } swap at
|
||||||
|
"UTF-8" or ;
|
||||||
|
|
||||||
: yes/no>bool ( string -- t/f )
|
: yes/no>bool ( string -- t/f )
|
||||||
{
|
{
|
||||||
|
@ -79,7 +80,7 @@ IN: xml.elements
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: prolog-standalone ( alist -- version )
|
: prolog-standalone ( alist -- version )
|
||||||
T{ name f "" "standalone" f } swap at
|
T{ name { space "" } { main "standalone" } } swap at
|
||||||
[ yes/no>bool ] [ f ] if* ;
|
[ yes/no>bool ] [ f ] if* ;
|
||||||
|
|
||||||
: prolog-attrs ( alist -- prolog )
|
: prolog-attrs ( alist -- prolog )
|
||||||
|
|
|
@ -2,14 +2,14 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test xml.interpolate multiline kernel assocs
|
USING: tools.test xml.interpolate multiline kernel assocs
|
||||||
sequences accessors xml.writer xml.interpolate.private
|
sequences accessors xml.writer xml.interpolate.private
|
||||||
locals splitting urls ;
|
locals splitting urls xml.data ;
|
||||||
IN: xml.interpolate.tests
|
IN: xml.interpolate.tests
|
||||||
|
|
||||||
[ "a" "c" { "a" "c" f } ] [
|
[ "a" "c" { "a" "c" f } ] [
|
||||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||||
string>doc
|
string>doc
|
||||||
[ second var>> ]
|
[ second var>> ]
|
||||||
[ fourth "val" swap at var>> ]
|
[ fourth "val" attr var>> ]
|
||||||
[ extract-variables ] tri
|
[ extract-variables ] tri
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -33,8 +33,9 @@ M: string push-item , ;
|
||||||
M: xml-data push-item , ;
|
M: xml-data push-item , ;
|
||||||
M: object push-item present , ;
|
M: object push-item present , ;
|
||||||
M: sequence push-item
|
M: sequence push-item
|
||||||
[ dup array? [ % ] [ , ] if ] each ;
|
dup xml-data? [ , ] [ [ push-item ] each ] if ;
|
||||||
M: number push-item present , ;
|
M: number push-item present , ;
|
||||||
|
M: xml-chunk push-item % ;
|
||||||
|
|
||||||
GENERIC: interpolate-item ( table item -- )
|
GENERIC: interpolate-item ( table item -- )
|
||||||
M: object interpolate-item nip , ;
|
M: object interpolate-item nip , ;
|
||||||
|
|
|
@ -19,7 +19,7 @@ SYMBOL: xml-file
|
||||||
[ "a" ] [ xml-file get space>> ] unit-test
|
[ "a" ] [ xml-file get space>> ] unit-test
|
||||||
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
|
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
|
||||||
[ "that" ] [
|
[ "that" ] [
|
||||||
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
xml-file get T{ name f "" "this" "http://d.de" } attr
|
||||||
] unit-test
|
] unit-test
|
||||||
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
||||||
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
|
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
|
||||||
|
@ -30,7 +30,7 @@ SYMBOL: xml-file
|
||||||
xml-file get after>> [ instruction? ] find nip text>>
|
xml-file get after>> [ instruction? ] find nip text>>
|
||||||
] unit-test
|
] unit-test
|
||||||
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
|
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
|
||||||
[ "that" ] [ xml-file get "this" swap at ] unit-test
|
[ "that" ] [ xml-file get "this" attr ] unit-test
|
||||||
[ "abcd" ] [
|
[ "abcd" ] [
|
||||||
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
|
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
|
||||||
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
|
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
|
||||||
|
@ -43,9 +43,11 @@ SYMBOL: xml-file
|
||||||
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
|
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
|
||||||
"c" get-id children>string
|
"c" get-id children>string
|
||||||
] unit-test
|
] unit-test
|
||||||
[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
|
[ "foo" ] [
|
||||||
at swap "z" [ tuck ] dip swap set-at
|
"<x y='foo'/>" string>xml
|
||||||
T{ name f "blah" "z" f } swap at ] unit-test
|
dup dup "y" attr "z" set-attr
|
||||||
|
T{ name { space "blah" } { main "z" } } attr
|
||||||
|
] unit-test
|
||||||
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
|
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
|
||||||
[ "<!-- B+, B, or B--->" string>xml ] must-fail
|
[ "<!-- B+, B, or B--->" string>xml ] must-fail
|
||||||
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
|
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
|
||||||
|
@ -58,5 +60,6 @@ SYMBOL: xml-file
|
||||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
|
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
|
||||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
|
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
|
||||||
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
|
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
|
||||||
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
|
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
|
||||||
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
|
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
|
||||||
|
[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
|
||||||
|
|
|
@ -1,16 +1,16 @@
|
||||||
USING: accessors assocs combinators continuations fry generalizations
|
USING: accessors assocs combinators continuations fry generalizations
|
||||||
io.pathnames kernel macros sequences stack-checker tools.test xml
|
io.pathnames kernel macros sequences stack-checker tools.test xml
|
||||||
xml.utilities xml.writer arrays ;
|
xml.utilities xml.writer arrays xml.data ;
|
||||||
IN: xml.tests.suite
|
IN: xml.tests.suite
|
||||||
|
|
||||||
TUPLE: xml-test id uri sections description type ;
|
TUPLE: xml-test id uri sections description type ;
|
||||||
|
|
||||||
: >xml-test ( tag -- test )
|
: >xml-test ( tag -- test )
|
||||||
xml-test new swap {
|
xml-test new swap {
|
||||||
[ "TYPE" swap at >>type ]
|
[ "TYPE" attr >>type ]
|
||||||
[ "ID" swap at >>id ]
|
[ "ID" attr >>id ]
|
||||||
[ "URI" swap at >>uri ]
|
[ "URI" attr >>uri ]
|
||||||
[ "SECTIONS" swap at >>sections ]
|
[ "SECTIONS" attr >>sections ]
|
||||||
[ children>> xml-chunk>string >>description ]
|
[ children>> xml-chunk>string >>description ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
|
@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot )
|
||||||
|
|
||||||
: failing-valids ( -- tests )
|
: failing-valids ( -- tests )
|
||||||
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
|
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
|
||||||
|
|
||||||
|
[ ] [ partition-xml-tests 2drop ] unit-test
|
||||||
|
|
|
@ -52,7 +52,6 @@ IN: xml.writer.tests
|
||||||
<x>&foo;</x>"} pprint-reprints-as
|
<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-chunk>string = ] unit-test
|
||||||
[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
|
|
||||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
||||||
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
||||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
|
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
|
||||||
|
|
|
@ -162,7 +162,8 @@ PRIVATE>
|
||||||
|
|
||||||
: read-xml-chunk ( stream -- seq )
|
: read-xml-chunk ( stream -- seq )
|
||||||
1 depth
|
1 depth
|
||||||
[ (read-xml-chunk) nip ] with-variable ;
|
[ (read-xml-chunk) nip ] with-variable
|
||||||
|
<xml-chunk> ;
|
||||||
|
|
||||||
: string>xml ( string -- xml )
|
: string>xml ( string -- xml )
|
||||||
t string-input?
|
t string-input?
|
||||||
|
|
|
@ -13,10 +13,10 @@ TAG: PROPS
|
||||||
parse-props-tag >>props drop ;
|
parse-props-tag >>props drop ;
|
||||||
|
|
||||||
TAG: IMPORT
|
TAG: IMPORT
|
||||||
"DELEGATE" swap at swap import-rule-set ;
|
"DELEGATE" attr swap import-rule-set ;
|
||||||
|
|
||||||
TAG: TERMINATE
|
TAG: TERMINATE
|
||||||
"AT_CHAR" swap at string>number >>terminate-char drop ;
|
"AT_CHAR" attr string>number >>terminate-char drop ;
|
||||||
|
|
||||||
RULE: SEQ seq-rule
|
RULE: SEQ seq-rule
|
||||||
shared-tag-attrs delegate-attr literal-start ;
|
shared-tag-attrs delegate-attr literal-start ;
|
||||||
|
|
|
@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-start
|
||||||
|
|
||||||
: tokenize-line ( line-context line rules -- line-context' seq )
|
: tokenize-line ( line-context line rules -- line-context' seq )
|
||||||
[
|
[
|
||||||
"MAIN" swap at -rot
|
"MAIN" attr -rot
|
||||||
init-token-marker
|
init-token-marker
|
||||||
mark-token-loop
|
mark-token-loop
|
||||||
mark-remaining
|
mark-remaining
|
||||||
|
|
Loading…
Reference in New Issue