More descriptive XML errors

basis/xml/errors/errors-tests.factor

@@ -6,22 +6,27 @@ IN: xml.errors.tests
     '[ _ string>xml ] swap '[ _ = ] must-fail-with ;
 
 T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
-T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "<x></y>" xml-error-test
+T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
+    "<x></y>" xml-error-test
 T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
 T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
 T{ unopened f 1 5 } "</x>" xml-error-test
-T{ not-yes/no f 1 41 "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
+T{ not-yes/no f 1 41 "maybe" }
+    "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
 T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
 } "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
-T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
+T{ bad-version f 1 28 "5 million" }
+    "<?xml version='5 million'?><x/>" xml-error-test
 T{ notags f } "" xml-error-test
 T{ multitags } "<x/><y/>" xml-error-test
-T{ bad-prolog  f 1 26 T{ prolog f "1.0" "UTF-8" f }
-} "<x/><?xml version='1.0'?>" xml-error-test
+T{ bad-prolog  f 1 26 T{ prolog f "1.0" "UTF-8" f } }
+    "<x/><?xml version='1.0'?>" xml-error-test
 T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
-xml-error-test
+    xml-error-test
 T{ pre/post-content f "x" t } "x<y/>" xml-error-test
 T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
-T{ bad-instruction f 1 11 T{ instruction f "xsl" }
-} "<x><?xsl?></x>" xml-error-test
+T{ bad-instruction f 1 11 T{ instruction f "xsl" } }
+    "<x><?xsl?></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 10 } "<x value=3/>" xml-error-test

basis/xml/errors/errors.factor

@@ -32,17 +32,6 @@ M: no-entity summary ( obj -- str )
         "Entity does not exist: &" write thing>> write ";" print
     ] with-string-writer ;
 
-TUPLE: xml-string-error < parsing-error string ; ! this should not exist
-
-: xml-string-error ( string -- * )
-    \ xml-string-error parsing-error swap >>string throw ;
-
-M: xml-string-error summary ( obj -- str )
-    [
-        dup call-next-method write
-        string>> print
-    ] with-string-writer ;
-
 TUPLE: mismatched < parsing-error open close ;
 
 : mismatched ( open close -- * )
@@ -233,7 +222,34 @@ M: misplaced-directive summary ( obj -- str )
         dir>> write-xml-chunk nl
     ] with-string-writer ;
 
+TUPLE: bad-name < parsing-error name ;
+
+: bad-name ( name -- * )
+    \ bad-name parsing-error 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 ;
+
+: unclosed-quote ( -- * )
+    \ unclosed-quote parsing-error throw ;
+
+M: unclosed-quote summary
+    call-next-method
+    "XML document ends with quote still open\n" append ;
+
+TUPLE: quoteless-attr < parsing-error ;
+
+: quoteless-attr ( -- * )
+    \ quoteless-attr parsing-error throw ;
+
+M: quoteless-attr summary
+    call-next-method "Attribute lacks quotes around value\n" append ;
+
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
-       not-yes/no unclosed mismatched xml-string-error expected no-entity
+       not-yes/no unclosed mismatched expected no-entity
        bad-prolog versionless-prolog capitalized-prolog bad-instruction
-       bad-directive ;
+       bad-directive bad-name unclosed-quote quoteless-attr ;

basis/xml/tokenize/tokenize.factor

@@ -58,7 +58,7 @@ SYMBOL: ns-stack
     over {
         [ first name-start? ]
         [ rest-slice [ name-char? ] with all? ]
-    } 2&& [ "Malformed name" xml-string-error ] unless ;
+    } 2&& [ bad-name ] unless ;
 
 : (parse-name) ( start -- str )
     version=1.0?
@@ -102,7 +102,7 @@ SYMBOL: ns-stack
 
 : parse-quot ( ch -- string )
     parse-char get-char
-    [ "XML file ends in a quote" xml-string-error ] unless ;
+    [ unclosed-quote ] unless ;
 
 : parse-text ( -- string )
     CHAR: < parse-char ;
@@ -115,11 +115,8 @@ SYMBOL: ns-stack
     parse-name swap ;
 
 : parse-attr-value ( -- seq )
-    get-char dup "'\"" member? [
-        next parse-quot
-    ] [
-        "Attribute lacks quote" xml-string-error
-    ] if ;
+    get-char dup "'\"" member?
+    [ next parse-quot ] [ quoteless-attr ] if ;
 
 : parse-attr ( -- )
     [ parse-name ] with-scope
@@ -358,6 +355,6 @@ SYMBOL: string-input?
         { f [ "" ] }
         [ dup blank?
           [ drop pass-blank utf8 decode-input-if CHAR: < expect make-tag ]
-          [ 1string ] if ! Replace with proper error
+          [ 1string ] if ! Replace with proper error?
         ]
     } case ;

basis/xml/xml-docs.factor

@@ -295,9 +295,6 @@ HELP: expected
 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." } ;
 
-HELP: xml-string-error
-{ $class-description "XML parsing error that delegates to " { $link parsing-error } " and represents an other, unspecified error, which is represented by the slot string, containing a string describing the error." } ;
-
 HELP: open-tag
 { $class-description "represents a tag that does have children, ie is not a contained tag" }
 { $notes "the constructor used for this class is simply " { $link <tag> } "." }
@@ -324,6 +321,15 @@ HELP: state-parse
 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" } ;
 
+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." } ;
+
+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." } ;
+
+HELP: quoteless-attr
+{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ;
+
 HELP: entities
 { $description "a hash table from default XML entity names (like &amp; and &lt;) to the characters they represent. This is automatically included when parsing any XML document." }
 { $see-also html-entities } ;
@@ -444,6 +450,9 @@ ARTICLE: { "xml" "errors" } "XML parsing errors"
     { $subsection expected }
     { $subsection no-entity }
     { $subsection pre/post-content }
+    { $subsection unclosed-quote }
+    { $subsection bad-name }
+    { $subsection quoteless-attr }
     "Additionally, most of these errors delegate to " { $link parsing-error } " in order to provide more information"
     $nl
     "Note that, in parsing an XML document, only the first error is reported." ;
@@ -456,7 +465,7 @@ ARTICLE: { "xml" "entities" } "XML entities"
     { $subsection with-html-entities } ;
 
 ARTICLE: "xml" "XML parser"
-"The " { $vocab-link "xml" } " vocabulary implements the XML 1.1 standard, converting strings of text into XML and vice versa."
+"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."
     { $subsection { "xml" "reading" } }
     { $subsection { "xml" "writing" } }
     { $subsection { "xml" "classes" } }