xml.errors: using code generation to make XML error classes.

basis/xml/errors/debugger/debugger.factor

@@ -4,7 +4,7 @@ USING: accessors debugger io kernel prettyprint sequences
 xml.errors xml.writer ;
 IN: xml.errors.debugger
 
-M: xml-error-at error.
+M: xml-error error.
     "XML parsing error" print
     "Line: " write dup line>> .
     "Column: " write column>> . ;

basis/xml/errors/errors-docs.factor

@@ -19,15 +19,15 @@ HELP: notags
 { $xml-error "<?xml version='1.0'?>" } ;
 
 HELP: extra-attrs
-{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, " { $snippet "standalone" } ", " { $snippet "version" } " and " { $snippet "encoding" } ". Contains one slot, " { $snippet "attrs" } ", which is a hashtable of all the extra attributes' names. This is a subclass of " { $link xml-error-at } "." }
+{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, " { $snippet "standalone" } ", " { $snippet "version" } " and " { $snippet "encoding" } ". Contains one slot, " { $snippet "attrs" } ", which is a hashtable of all the extra attributes' names." }
 { $xml-error "<?xml version='1.0' reason='because I said so'?>\n<foo/>" } ;
 
 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, " { $snippet "name" } ", which contains the name of the undeclared namespace, and is a subclass of " { $link xml-error-at } "." }
+{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, " { $snippet "name" } ", which contains the name of the undeclared namespace." }
 { $xml-error "<a:b>c</a:b>" } ;
 
 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 " { $snippet "yes" } " or " { $snippet "no" } ". This is a subclass of " { $link xml-error-at } " 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 " { $snippet "yes" } " or " { $snippet "no" } ". This contains one slot, text, which contains offending value." }
 { $xml-error "<?xml version='1.0' standalone='maybe'?>\n<x/>" } ;
 
 HELP: unclosed
@@ -35,14 +35,14 @@ HELP: unclosed
 { $xml-error "<x>some text" } ;
 
 HELP: mismatched
-{ $class-description "XML parsing error describing mismatched tags. Contains two slots: " { $snippet "open" } " is the name of the opening tag and " { $snippet "close" } " is the name of the closing tag. This is a subclass of " { $link xml-error-at } " showing the location of the closing tag" }
+{ $class-description "XML parsing error describing mismatched tags. Contains two slots: " { $snippet "open" } " is the name of the opening tag and " { $snippet "close" } " is the name of the closing tag. This shows the location of the closing tag" }
 { $xml-error "<a></c>" } ;
 
 HELP: expected
-{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, " { $snippet "should-be" } ", which has the expected string, and " { $snippet "was" } ", which has the actual string." } ;
+{ $class-description "XML parsing error describing when an expected token was not present. Contains two slots, " { $snippet "should-be" } ", which has the expected string, and " { $snippet "was" } ", which has the actual string." } ;
 
 HELP: no-entity
-{ $class-description "XML parsing error describing the use of an undefined entity. This is a subclass of " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." }
+{ $class-description "XML parsing error describing the use of an undefined entity. Contains one slot, " { $snippet "thing" } ", containing a string representing the entity." }
 { $xml-error "<x>&foo;</x>" } ;
 
 
@@ -115,7 +115,7 @@ ARTICLE: "xml.errors" "XML parsing errors"
     attr-w/<
     misplaced-directive
 }
-"Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred."
+"Additionally, most of these errors are a kind of " { $link xml-error } " which provides more information about where the error occurred."
 $nl
 "Note that, in parsing an XML document, only the first error is reported." ;
 

basis/xml/errors/errors.factor

@@ -1,180 +1,110 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences vocabs.loader
+USING: accessors classes classes.tuple classes.tuple.parser
-xml.state ;
+classes.tuple.private combinators generalizations kernel math
+namespaces parser sequences vocabs.loader words xml.state ;
 IN: xml.errors
 
-TUPLE: xml-error-at line column ;
+<<
 
-: xml-error-at ( class -- obj )
+PREDICATE: generated-xml-error < tuple class-of "xml-error-class" word-prop ;
-    new
-        get-line >>line
-        get-column >>column ;
 
-TUPLE: expected < xml-error-at should-be was ;
+: define-xml-error-class ( class superclass slots -- )
+    { "line" "column" } prepend error-slots {
+        [ define-tuple-class ]
+        [ 2drop reset-generic ]
+        [ 2drop t "error-class" set-word-prop ]
+        [ 2drop t "xml-error-class" set-word-prop ]
+        [
+            [
+                length 1 - nip dupd
+                [ [ get-line get-column ] swap ndip boa throw ]
+                2curry
+            ]
+            [ 2drop all-slots 2 head* thrower-effect ] 3bi define-declared
+        ]
+    } 3cleave ;
 
-: expected ( should-be was -- * )
+SYNTAX: XML-ERROR:
-    \ expected xml-error-at
+    parse-tuple-definition pick save-location
-        swap >>was
+    define-xml-error-class ;
-        swap >>should-be throw ;
 
-TUPLE: unexpected-end < xml-error-at ;
+>>
 
-: unexpected-end ( -- * ) \ unexpected-end xml-error-at throw ;
+XML-ERROR: expected should-be was ;
 
-TUPLE: missing-close < xml-error-at ;
+XML-ERROR: unexpected-end ;
 
-: missing-close ( -- * ) \ missing-close xml-error-at throw ;
+XML-ERROR: missing-close ;
 
-TUPLE: disallowed-char < xml-error-at char ;
+XML-ERROR: disallowed-char char ;
-
-: disallowed-char ( char -- * )
-    \ disallowed-char xml-error-at swap >>char throw ;
 
 ERROR: multitags ;
 
 ERROR: pre/post-content string pre? ;
 
-TUPLE: no-entity < xml-error-at thing ;
+XML-ERROR: no-entity thing ;
 
-: no-entity ( string -- * )
+XML-ERROR: mismatched open close ;
-    \ no-entity xml-error-at swap >>thing throw ;
 
-TUPLE: mismatched < xml-error-at open close ;
+TUPLE: unclosed line column tags ;
-
-: mismatched ( open close -- * )
-    \ mismatched xml-error-at swap >>close swap >>open throw ;
-
-TUPLE: unclosed < xml-error-at tags ;
 
 : unclosed ( -- * )
-    \ unclosed xml-error-at
+    get-line get-column
-        xml-stack get rest-slice [ first name>> ] map >>tags
+    xml-stack get rest-slice [ first name>> ] map
-    throw ;
+    \ unclosed boa throw ;
 
-TUPLE: bad-uri < xml-error-at string ;
+XML-ERROR: bad-uri string ;
 
-: bad-uri ( string -- * )
+XML-ERROR: nonexist-ns name ;
-    \ bad-uri xml-error-at swap >>string throw ;
-
-TUPLE: nonexist-ns < xml-error-at name ;
-
-: nonexist-ns ( name-string -- * )
-    \ nonexist-ns xml-error-at swap >>name throw ;
 
 ! this should give which tag was unopened
-TUPLE: unopened < xml-error-at ;
+XML-ERROR: unopened ;
 
-: unopened ( -- * )
+XML-ERROR: not-yes/no text ;
-    \ unopened xml-error-at throw ;
-
-TUPLE: not-yes/no < xml-error-at text ;
-
-: not-yes/no ( text -- * )
-    \ not-yes/no xml-error-at swap >>text throw ;
 
 ! this should actually print the names
-TUPLE: extra-attrs < xml-error-at attrs ;
+XML-ERROR: extra-attrs attrs ;
 
-: extra-attrs ( attrs -- * )
+XML-ERROR: bad-version num ;
-    \ extra-attrs xml-error-at swap >>attrs throw ;
-
-TUPLE: bad-version < xml-error-at num ;
-
-: bad-version ( num -- * )
-    \ bad-version xml-error-at swap >>num throw ;
 
 ERROR: notags ;
 
-TUPLE: bad-prolog < xml-error-at prolog ;
+XML-ERROR: bad-prolog prolog ;
 
-: bad-prolog ( prolog -- * )
+XML-ERROR: capitalized-prolog name ;
-    \ bad-prolog xml-error-at swap >>prolog throw ;
 
-TUPLE: capitalized-prolog < xml-error-at name ;
+XML-ERROR: versionless-prolog ;
 
-: capitalized-prolog ( name -- capitalized-prolog )
+XML-ERROR: bad-directive dir ;
-    \ capitalized-prolog xml-error-at swap >>name throw ;
 
-TUPLE: versionless-prolog < xml-error-at ;
+XML-ERROR: bad-decl ;
 
-: versionless-prolog ( -- * )
+XML-ERROR: bad-external-id ;
-    \ versionless-prolog xml-error-at throw ;
 
-TUPLE: bad-directive < xml-error-at dir ;
+XML-ERROR: misplaced-directive dir ;
 
-: bad-directive ( directive -- * )
+XML-ERROR: bad-name name ;
-    \ bad-directive xml-error-at swap >>dir throw ;
 
-TUPLE: bad-decl < xml-error-at ;
+XML-ERROR: unclosed-quote ;
 
-: bad-decl ( -- * )
+XML-ERROR: quoteless-attr ;
-    \ bad-decl xml-error-at throw ;
 
-TUPLE: bad-external-id < xml-error-at ;
+XML-ERROR: attr-w/< ;
 
-: bad-external-id ( -- * )
+XML-ERROR: text-w/]]> ;
-    \ bad-external-id xml-error-at throw ;
 
-TUPLE: misplaced-directive < xml-error-at dir ;
+XML-ERROR: duplicate-attr key values ;
 
-: misplaced-directive ( directive -- * )
+XML-ERROR: bad-cdata ;
-    \ misplaced-directive xml-error-at swap >>dir throw ;
 
-TUPLE: bad-name < xml-error-at name ;
+XML-ERROR: not-enough-characters ;
 
-: bad-name ( name -- * )
+XML-ERROR: bad-doctype contents ;
-    \ bad-name xml-error-at swap >>name throw ;
 
-TUPLE: unclosed-quote < xml-error-at ;
+XML-ERROR: bad-encoding encoding ;
-
-: unclosed-quote ( -- * )
-    \ unclosed-quote xml-error-at throw ;
-
-TUPLE: quoteless-attr < xml-error-at ;
-
-: quoteless-attr ( -- * )
-    \ quoteless-attr xml-error-at throw ;
-
-TUPLE: attr-w/< < xml-error-at ;
-
-: attr-w/< ( -- * )
-    \ attr-w/< xml-error-at throw ;
-
-TUPLE: text-w/]]> < xml-error-at ;
-
-: text-w/]]> ( -- * )
-    \ text-w/]]> xml-error-at throw ;
-
-TUPLE: duplicate-attr < xml-error-at key values ;
-
-: duplicate-attr ( key values -- * )
-    \ duplicate-attr xml-error-at
-    swap >>values swap >>key throw ;
-
-TUPLE: bad-cdata < xml-error-at ;
-
-: bad-cdata ( -- * )
-    \ bad-cdata xml-error-at throw ;
-
-TUPLE: not-enough-characters < xml-error-at ;
-
-: not-enough-characters ( -- * )
-    \ not-enough-characters xml-error-at throw ;
-
-TUPLE: bad-doctype < xml-error-at contents ;
-
-: bad-doctype ( contents -- * )
-    \ bad-doctype xml-error-at swap >>contents throw ;
-
-TUPLE: bad-encoding < xml-error-at encoding ;
-
-: bad-encoding ( encoding -- * )
-    \ bad-encoding xml-error-at
-        swap >>encoding
-    throw ;
 
 UNION: xml-error
-    multitags notags pre/post-content xml-error-at ;
+    unclosed multitags notags pre/post-content generated-xml-error ;
 
 { "xml.errors" "debugger" } "xml.errors.debugger" require-when