ABOUT: "xml.data"
ARTICLE: "xml.data" "XML data types"
-{ $vocab-link "xml.data" } " defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
+"The " { $vocab-link "xml.data" } " vocabulary defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
{ $subsection { "xml.data" "classes" } }
{ $subsection { "xml.data" "constructors" } }
"Simple words for manipulating names:"
{ $subsection <notation-decl> } ;
HELP: tag
-{ $class-description "tuple representing an XML tag, delegating to a " { $link
+{ $class-description "Tuple representing an XML tag, delegating to a " { $link
name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." }
{ $see-also <tag> name contained-tag xml } ;
{ "attrs" "an alist of names to strings" }
{ "children" sequence }
{ "tag" tag } }
-{ $description "constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified" }
+{ $description "Constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified." }
{ $see-also tag <contained-tag> } ;
HELP: name
-{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" }
+{ $class-description "Represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)." }
{ $see-also <name> tag } ;
HELP: <name>
{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }
{ "name" "an XML tag name" } }
-{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." }
+{ $description "Creates a name tuple with the namespace prefix space, the the given main part of the name, and the namespace URL given by url." }
{ $see-also name <tag> } ;
HELP: contained-tag
-{ $class-description "delegates to tag representing a tag like <a/> with no contents. The tag attributes are accessed with tag-attrs" }
+{ $class-description "This is a subclass of " { $link tag } " consisting of tags with no body, like " { $snippet "<a/>" } "." }
{ $see-also tag <contained-tag> } ;
HELP: <contained-tag>
{ $values { "name" "an XML tag name" }
{ "attrs" "an alist from names to strings" }
{ "tag" tag } }
-{ $description "creates an empty tag (like <a/>) with the specified name and tag attributes. This delegates to tag" }
+{ $description "Creates an empty tag (like " { $snippet "<a/>" } ") with the specified name and tag attributes." }
{ $see-also contained-tag <tag> } ;
HELP: xml
-{ $class-description "tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header <?xml...?>), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)" }
+{ $class-description "Tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header " { $snippet "<?xml...?>" } "), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)." }
{ $see-also <xml> tag prolog } ;
HELP: <xml>
{ $description "Creates an element declaration object, of the class " { $link element-decl } } ;
HELP: attlist-decl
-{ $class-description "Describes the class of element declarations, like <!ATTLIST pre xml:space (preserve) #FIXED 'preserve'>." } ;
+{ $class-description "Describes the class of element declarations, like " { $snippet "<!ATTLIST pre xml:space (preserve) #FIXED 'preserve'>" } "." } ;
HELP: <attlist-decl>
{ $values { "name" name } { "att-defs" string } { "attlist-decl" attlist-decl } }
{ $description "Creates an element declaration object, of the class " { $link attlist-decl } } ;
HELP: entity-decl
-{ $class-description "Describes the class of element declarations, like <!ENTITY foo 'bar'>." } ;
+{ $class-description "Describes the class of element declarations, like " { $snippet "<!ENTITY foo 'bar'>" } "." } ;
HELP: <entity-decl>
{ $values { "name" name } { "def" string } { "pe?" "t or f" } { "entity-decl" entity-decl } }
-{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like <!ENTITY % foo 'bar'> and f if the object is like <!ENTITY foo 'bar'>, that is, it can be used outside of the DTD." } ;
+{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like " { $snippet "<!ENTITY % foo 'bar'>" } " and f if the object is like " { $snippet "<!ENTITY foo 'bar'>" } ", that is, it can be used outside of the DTD." } ;
HELP: system-id
-{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as <!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } ;
+{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } } ;
HELP: <system-id>
{ $values { "system-literal" string } { "system-id" system-id } }
{ $description "Constructs a " { $link system-id } " tuple." } ;
HELP: public-id
-{ $class-description "Describes the class of public identifiers within an XML DTD directive, such as <!DOCTYPE open-hatch " { $emphasis "PUBLIC '-//Textuality//TEXT Standard open-hatch boilerplate//EN' 'http://www.textuality.com/boilerplate/OpenHatch.xml'" } ">" } ;
+{ $class-description "Describes the class of public identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE open-hatch " { $emphasis "PUBLIC '-//Textuality//TEXT Standard open-hatch boilerplate//EN' 'http://www.textuality.com/boilerplate/OpenHatch.xml'" } ">" } } ;
HELP: <public-id>
{ $values { "pubid-literal" string } { "system-literal" string } { "public-id" public-id } }
{ $description "Constructs a " { $link system-id } " tuple." } ;
HELP: notation-decl
-{ $class-description "Describes the class of element declarations, like <!NOTATION jpg SYSTEM './jpgviewer'>." } ;
+{ $class-description "Describes the class of element declarations, like " { $snippet "<!NOTATION jpg SYSTEM './jpgviewer'>" } "." } ;
HELP: <notation-decl>
{ $values { "name" string } { "id" id } { "notation-decl" notation-decl } }
USING: kernel namespaces xml.tokenize xml.state xml.name
xml.data accessors arrays make xml.char-classes fry assocs sequences
math xml.errors sets combinators io.encodings io.encodings.iana
-unicode.case xml.dtd strings xml.entities ;
+unicode.case xml.dtd strings xml.entities unicode.categories ;
IN: xml.elements
: take-interpolated ( quot -- interpolated )
interpolating? get [
drop get-char CHAR: > =
- [ next f ] [
- pass-blank " \t\r\n-" take-to
- pass-blank "->" expect
- ] if <interpolated>
+ [ next f ]
+ [ "->" take-string [ blank? ] trim ]
+ if <interpolated>
] [ call ] if ; inline
: interpolate-quote ( -- interpolated )
{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ;
HELP: extra-attrs
-{ $class-description "XML parsing error describing the case where the XML prolog (<?xml ...?>) contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link parsing-error } "." } ;
+{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link xml-error-at } "." } ;
HELP: nonexist-ns
-{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link parsing-error } "." } ;
+{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link xml-error-at } "." } ;
HELP: not-yes/no
-{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link parsing-error } " and contains one slot, text, which contains offending value." } ;
+{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link xml-error-at } " and contains one slot, text, which contains offending value." } ;
HELP: unclosed
{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ;
HELP: mismatched
-{ $class-description "XML parsing error describing mismatched tags, eg <a></c>. Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link parsing-error } " showing the location of the closing tag" } ;
+{ $class-description "XML parsing error describing mismatched tags, eg " { $snippet "<a></c>" } ". Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link xml-error-at } " showing the location of the closing tag" } ;
HELP: expected
-{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link parsing-error } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ;
+{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ;
HELP: no-entity
-{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link parsing-error } ". Contains one slot, thing, containing a string representing the entity." } ;
+{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } ;
HELP: pre/post-content
-{ $class-description "describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
+{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
HELP: unclosed-quote
-{ $class-description "describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
+{ $class-description "Describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
HELP: bad-name
-{ $class-description "describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
+{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
HELP: quoteless-attr
-{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ;
+{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } ;
-HELP: xml-parse-error
-{ $class-description "the exception class that all parsing errors in XML documents are in." } ;
+HELP: disallowed-char
+{ $class-description "Describes the error where a disallowed character occurs in an XML document." } ;
+
+HELP: missing-close
+{ $class-description "Describes the error where a particular closing token is missing." } ;
+
+HELP: unexpected-end
+{ $class-description "Describes the error where a document unexpectedly ends, and the XML parser expected it to continue." } ;
+
+HELP: duplicate-attr
+{ $class-description "Describes the error where there is more than one attribute of the same key." } ;
+
+HELP: bad-cdata
+{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } ;
+
+HELP: text-w/]]>
+{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } ;
+
+HELP: attr-w/<
+{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } ;
+
+HELP: misplaced-directive
+{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } ;
+
+HELP: xml-error
+{ $class-description "The exception class that all parsing errors in XML documents are in." } ;
ARTICLE: "xml.errors" "XML parsing errors"
- { $vocab-link "xml.errors" } " provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-parse-error } " but there are many classes contained in that:"
+"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } " but there are many classes contained in that:"
{ $subsection multitags }
{ $subsection notags }
{ $subsection extra-attrs }
{ $subsection unclosed-quote }
{ $subsection bad-name }
{ $subsection quoteless-attr }
- "Additionally, most of these errors are a kind of " { $link parsing-error } " which provides more information"
+ { $subsection disallowed-char }
+ { $subsection missing-close }
+ { $subsection unexpected-end }
+ { $subsection duplicate-attr }
+ { $subsection bad-cdata }
+ { $subsection text-w/]]> }
+ { $subsection attr-w/< }
+ { $subsection misplaced-directive }
+ "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information"
$nl
"Note that, in parsing an XML document, only the first error is reported." ;
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
+T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
T{ attr-w/< f 1 11 } "<x value='<'/>" xml-error-test
T{ text-w/]]> f 1 6 } "<x>]]></x>" xml-error-test
T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "<x this='a' this='b'/>" xml-error-test
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
-T{ pre/post-content f "&" t } "&32;<x/>" xml-error-test
+T{ pre/post-content f "&" t } " <x/>" xml-error-test
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
+T{ disallowed-char f 1 3 1 } "<x>\u000001</x>" xml-error-test
+T{ missing-close f 1 9 } "<!-- foo" xml-error-test
+T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test
namespaces io.streams.string ;
IN: xml.errors
-TUPLE: parsing-error line column ;
+TUPLE: xml-error-at line column ;
-: parsing-error ( class -- obj )
+: xml-error-at ( class -- obj )
new
get-line >>line
get-column >>column ;
-M: parsing-error summary ( obj -- str )
+M: xml-error-at summary ( obj -- str )
[
- "Parsing error" print
+ "XML parsing error" print
"Line: " write dup line>> .
"Column: " write column>> .
] with-string-writer ;
-TUPLE: expected < parsing-error should-be was ;
+TUPLE: expected < xml-error-at should-be was ;
: expected ( should-be was -- * )
- \ expected parsing-error
+ \ expected xml-error-at
swap >>was
swap >>should-be throw ;
M: expected summary ( obj -- str )
"Token present: " write was>> print
] with-string-writer ;
-TUPLE: unexpected-end < parsing-error ;
-: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;
+TUPLE: unexpected-end < xml-error-at ;
+: unexpected-end ( -- * ) \ unexpected-end xml-error-at throw ;
M: unexpected-end summary ( obj -- str )
[
call-next-method write
"File unexpectedly ended." print
] with-string-writer ;
-TUPLE: missing-close < parsing-error ;
-: missing-close ( -- * ) \ missing-close parsing-error throw ;
+TUPLE: missing-close < xml-error-at ;
+: missing-close ( -- * ) \ missing-close xml-error-at throw ;
M: missing-close summary ( obj -- str )
[
call-next-method write
"Missing closing token." print
] with-string-writer ;
-TUPLE: disallowed-char < parsing-error char ;
+TUPLE: disallowed-char < xml-error-at char ;
: disallowed-char ( char -- * )
- \ disallowed-char parsing-error swap >>char throw ;
+ \ disallowed-char xml-error-at swap >>char throw ;
M: disallowed-char summary
[ call-next-method ]
" the main tag." print
] with-string-writer ;
-TUPLE: no-entity < parsing-error thing ;
+TUPLE: no-entity < xml-error-at thing ;
: no-entity ( string -- * )
- \ no-entity parsing-error swap >>thing throw ;
+ \ no-entity xml-error-at swap >>thing throw ;
M: no-entity summary ( obj -- str )
[
"Entity does not exist: &" write thing>> write ";" print
] with-string-writer ;
-TUPLE: mismatched < parsing-error open close ;
+TUPLE: mismatched < xml-error-at open close ;
: mismatched ( open close -- * )
- \ mismatched parsing-error swap >>close swap >>open throw ;
+ \ mismatched xml-error-at swap >>close swap >>open throw ;
M: mismatched summary ( obj -- str )
[
"Closing tag: </" write close>> print-name ">" print
] with-string-writer ;
-TUPLE: unclosed < parsing-error tags ;
+TUPLE: unclosed < xml-error-at tags ;
: unclosed ( -- * )
- \ unclosed parsing-error
+ \ unclosed xml-error-at
xml-stack get rest-slice [ first name>> ] map >>tags
throw ;
tags>> [ " <" write print-name ">" print ] each
] with-string-writer ;
-TUPLE: bad-uri < parsing-error string ;
+TUPLE: bad-uri < xml-error-at string ;
: bad-uri ( string -- * )
- \ bad-uri parsing-error swap >>string throw ;
+ \ bad-uri xml-error-at swap >>string throw ;
M: bad-uri summary ( obj -- str )
[
"Bad URI:" print string>> .
] with-string-writer ;
-TUPLE: nonexist-ns < parsing-error name ;
+TUPLE: nonexist-ns < xml-error-at name ;
: nonexist-ns ( name-string -- * )
- \ nonexist-ns parsing-error swap >>name throw ;
+ \ nonexist-ns xml-error-at swap >>name throw ;
M: nonexist-ns summary ( obj -- str )
[
"Namespace " write name>> write " has not been declared" print
] with-string-writer ;
-TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
+TUPLE: unopened < xml-error-at ; ! this should give which tag was unopened
: unopened ( -- * )
- \ unopened parsing-error throw ;
+ \ unopened xml-error-at throw ;
M: unopened summary ( obj -- str )
[
"Closed an unopened tag" print
] with-string-writer ;
-TUPLE: not-yes/no < parsing-error text ;
+TUPLE: not-yes/no < xml-error-at text ;
: not-yes/no ( text -- * )
- \ not-yes/no parsing-error swap >>text throw ;
+ \ not-yes/no xml-error-at swap >>text throw ;
M: not-yes/no summary ( obj -- str )
[
] with-string-writer ;
! this should actually print the names
-TUPLE: extra-attrs < parsing-error attrs ;
+TUPLE: extra-attrs < xml-error-at attrs ;
: extra-attrs ( attrs -- * )
- \ extra-attrs parsing-error swap >>attrs throw ;
+ \ extra-attrs xml-error-at swap >>attrs throw ;
M: extra-attrs summary ( obj -- str )
[
attrs>> .
] with-string-writer ;
-TUPLE: bad-version < parsing-error num ;
+TUPLE: bad-version < xml-error-at num ;
: bad-version ( num -- * )
- \ bad-version parsing-error swap >>num throw ;
+ \ bad-version xml-error-at swap >>num throw ;
M: bad-version summary ( obj -- str )
[
M: notags summary ( obj -- str )
drop "XML document lacks a main tag" ;
-TUPLE: bad-prolog < parsing-error prolog ;
+TUPLE: bad-prolog < xml-error-at prolog ;
: bad-prolog ( prolog -- * )
- \ bad-prolog parsing-error swap >>prolog throw ;
+ \ bad-prolog xml-error-at swap >>prolog throw ;
M: bad-prolog summary ( obj -- str )
[
prolog>> write-prolog nl
] with-string-writer ;
-TUPLE: capitalized-prolog < parsing-error name ;
+TUPLE: capitalized-prolog < xml-error-at name ;
: capitalized-prolog ( name -- capitalized-prolog )
- \ capitalized-prolog parsing-error swap >>name throw ;
+ \ capitalized-prolog xml-error-at swap >>name throw ;
M: capitalized-prolog summary ( obj -- str )
[
" instead of <?xml...?>" print
] with-string-writer ;
-TUPLE: versionless-prolog < parsing-error ;
+TUPLE: versionless-prolog < xml-error-at ;
: versionless-prolog ( -- * )
- \ versionless-prolog parsing-error throw ;
+ \ versionless-prolog xml-error-at throw ;
M: versionless-prolog summary ( obj -- str )
[
"XML prolog lacks a version declaration" print
] with-string-writer ;
-TUPLE: bad-directive < parsing-error dir ;
+TUPLE: bad-directive < xml-error-at dir ;
: bad-directive ( directive -- * )
- \ bad-directive parsing-error swap >>dir throw ;
+ \ bad-directive xml-error-at swap >>dir throw ;
M: bad-directive summary ( obj -- str )
[
dir>> write
] with-string-writer ;
-TUPLE: bad-decl < parsing-error ;
+TUPLE: bad-decl < xml-error-at ;
: bad-decl ( -- * )
- \ bad-decl parsing-error throw ;
+ \ bad-decl xml-error-at throw ;
M: bad-decl summary ( obj -- str )
call-next-method "\nExtra content in directive" append ;
-TUPLE: bad-external-id < parsing-error ;
+TUPLE: bad-external-id < xml-error-at ;
: bad-external-id ( -- * )
- \ bad-external-id parsing-error throw ;
+ \ bad-external-id xml-error-at throw ;
M: bad-external-id summary ( obj -- str )
call-next-method "\nBad external ID" append ;
-TUPLE: misplaced-directive < parsing-error dir ;
+TUPLE: misplaced-directive < xml-error-at dir ;
: misplaced-directive ( directive -- * )
- \ misplaced-directive parsing-error swap >>dir throw ;
+ \ misplaced-directive xml-error-at swap >>dir throw ;
M: misplaced-directive summary ( obj -- str )
[
dir>> write-xml-chunk nl
] with-string-writer ;
-TUPLE: bad-name < parsing-error name ;
+TUPLE: bad-name < xml-error-at name ;
: bad-name ( name -- * )
- \ bad-name parsing-error swap >>name throw ;
+ \ bad-name xml-error-at swap >>name throw ;
M: bad-name summary ( obj -- str )
[ call-next-method ]
[ "Invalid name: " swap name>> "\n" 3append ]
bi append ;
-TUPLE: unclosed-quote < parsing-error ;
+TUPLE: unclosed-quote < xml-error-at ;
: unclosed-quote ( -- * )
- \ unclosed-quote parsing-error throw ;
+ \ unclosed-quote xml-error-at throw ;
M: unclosed-quote summary
call-next-method
"XML document ends with quote still open\n" append ;
-TUPLE: quoteless-attr < parsing-error ;
+TUPLE: quoteless-attr < xml-error-at ;
: quoteless-attr ( -- * )
- \ quoteless-attr parsing-error throw ;
+ \ quoteless-attr xml-error-at throw ;
M: quoteless-attr summary
call-next-method "Attribute lacks quotes around value\n" append ;
-TUPLE: attr-w/< < parsing-error ;
+TUPLE: attr-w/< < xml-error-at ;
: attr-w/< ( value -- * )
- \ attr-w/< parsing-error throw ;
+ \ attr-w/< xml-error-at throw ;
M: attr-w/< summary
call-next-method
"Attribute value contains literal <" append ;
-TUPLE: text-w/]]> < parsing-error ;
+TUPLE: text-w/]]> < xml-error-at ;
: text-w/]]> ( text -- * )
- \ text-w/]]> parsing-error throw ;
+ \ text-w/]]> xml-error-at throw ;
M: text-w/]]> summary
call-next-method
"Text node contains ']]>'" append ;
-TUPLE: duplicate-attr < parsing-error key values ;
+TUPLE: duplicate-attr < xml-error-at key values ;
: duplicate-attr ( key values -- * )
- \ duplicate-attr parsing-error
+ \ duplicate-attr xml-error-at
swap >>values swap >>key throw ;
M: duplicate-attr summary
call-next-method "\nDuplicate attribute" append ;
-TUPLE: bad-cdata < parsing-error ;
+TUPLE: bad-cdata < xml-error-at ;
: bad-cdata ( -- * )
- \ bad-cdata parsing-error throw ;
+ \ bad-cdata xml-error-at throw ;
M: bad-cdata summary
call-next-method "\nCDATA occurs before or after main tag" append ;
-TUPLE: not-enough-characters < parsing-error ;
+TUPLE: not-enough-characters < xml-error-at ;
: not-enough-characters ( -- * )
- \ not-enough-characters parsing-error throw ;
+ \ not-enough-characters xml-error-at throw ;
M: not-enough-characters summary ( obj -- str )
[
call-next-method write
"Not enough characters" print
] with-string-writer ;
-TUPLE: bad-doctype < parsing-error contents ;
+TUPLE: bad-doctype < xml-error-at contents ;
: bad-doctype ( contents -- * )
- \ bad-doctype parsing-error swap >>contents throw ;
+ \ bad-doctype xml-error-at swap >>contents throw ;
M: bad-doctype summary
call-next-method "\nDTD contains invalid object" append ;
-UNION: xml-parse-error
- multitags notags extra-attrs nonexist-ns bad-decl
- not-yes/no unclosed mismatched expected no-entity
- bad-prolog versionless-prolog capitalized-prolog
- bad-directive bad-name unclosed-quote quoteless-attr
- attr-w/< text-w/]]> duplicate-attr ;
+UNION: xml-error
+ multitags notags pre/post-content xml-error-at ;
--- /dev/null
+USING: help.markup help.syntax present multiline ;
+IN: xml.interpolate
+
+ABOUT: "xml.interpolate"
+
+ARTICLE: "xml.interpolate" "XML literal interpolation"
+"The " { $vocab-link "xml.interpolate" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
+{ $subsection POSTPONE: <XML }
+{ $subsection POSTPONE: [XML }
+"For a description of the common syntax of these two, see"
+{ $subsection { "xml.interpolate" "in-depth" } } ;
+
+HELP: <XML
+{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
+{ $description "This syntax allows the interpolation of XML documents. When evaluated, there is an XML document on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
+
+HELP: [XML
+{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
+{ $description "This syntax allows the interpolation of XML chunks. When evaluated, there is a sequence of XML elements (tags, strings, comments, etc) on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
+
+ARTICLE: { "xml.interpolate" "in-depth" } "XML interpolation syntax"
+"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
+$nl
+"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
+{ $example
+{" "one two three" " " split
+[ [XML <item><-></item> XML] ] map
+<XML <doc><-></doc> XML> pprint-xml>string "}
+{" <' <?xml version="1.0" encoding="UTF-8"?>
+<doc>
+ <item>
+ one
+ </item>
+ <item>
+ two
+ </item>
+ <item>
+ three
+ </item>
+</doc>'> "} }
+"Here is an example of the locals version:"
+{ $example
+{" [let |
+ number [ 3 ]
+ false [ f ]
+ url [ URL" http://factorcode.org/" ]
+ string [ "hello" ]
+ word [ \ drop ] |
+ <XML
+ <x
+ number=<-number->
+ false=<-false->
+ url=<-url->
+ string=<-string->
+ word=<-word-> />
+ XML> pprint-xml>string ] "}
+{" <' <?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>'> "} } ;
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.interpolate multiline kernel assocs
sequences accessors xml.writer xml.interpolate.private
-locals splitting ;
+locals splitting urls ;
IN: xml.interpolate.tests
[ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
- interpolated-doc
+ string>doc
[ second var>> ]
[ fourth "val" swap at var>> ]
[ extract-variables ] tri
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml>string
] unit-test
+
+[ {" <?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
+[ 3 f URL" http://factorcode.org/" "hello" \ drop
+ <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
+ pprint-xml>string ] unit-test
USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros
sequences.deep generalizations locals words combinators
-math ;
+math present ;
IN: xml.interpolate
<PRIVATE
-: interpolated-chunk ( string -- chunk )
+: string>chunk ( string -- chunk )
t interpolating? [ string>xml-chunk ] with-variable ;
-: interpolated-doc ( string -- xml )
+: string>doc ( string -- xml )
t interpolating? [ string>xml ] with-variable ;
DEFER: interpolate-sequence
: interpolate-attrs ( table attrs -- attrs )
- swap '[ dup interpolated? [ var>> _ at ] when ] assoc-map ;
+ swap '[
+ dup interpolated?
+ [ var>> _ at dup [ present ] when ] when
+ ] assoc-map [ nip ] assoc-filter ;
: interpolate-tag ( table tag -- tag )
[ nip name>> ]
swap attrs>> values
[ interpolated? ] filter
swap each ;
+M: xml (each-interpolated)
+ [ body>> ] dip (each-interpolated) ;
M: object (each-interpolated) 2drop ;
: each-interpolated ( xml quot -- )
] each-interpolated doc ;
MACRO: interpolate-xml ( string -- doc )
- interpolated-doc number<-> '[ _ interpolate-xml-doc ] ;
+ string>doc number<-> '[ _ interpolate-xml-doc ] ;
MACRO: interpolate-chunk ( string -- chunk )
- interpolated-chunk number<-> '[ _ interpolate-sequence ] ;
+ string>chunk number<-> '[ _ interpolate-sequence ] ;
: >search-hash ( seq -- hash )
[ dup search ] H{ } map>assoc ;
: extract-variables ( xml -- seq )
[ [ var>> , ] each-interpolated ] { } make ;
+: nenum ( ... n -- assoc )
+ narray <enum> ; inline
+
: collect ( accum seq -- accum )
{
{ [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
{ [ dup [ not ] all? ] [ ! fry
- length parsed \ narray parsed \ <enum> parsed
+ length parsed \ nenum parsed
] }
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
} cond ;
: parse-def ( accum delimiter word -- accum )
[
parse-multiline-string
- [ interpolated-chunk extract-variables collect ] keep
+ [ string>chunk extract-variables collect ] keep
parsed
] dip parsed ;
xml-file get T{ name f "" "this" "http://d.de" } swap at
] unit-test
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
-[ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
+[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
[ T{ comment f "This is where the fun begins!" } ] [
xml-file get before>> [ comment? ] find nip
] unit-test
projects / factor.git / commitdiff