basis/xml/errors/errors.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml.data xml.writer kernel generic io prettyprint math
   4 debugger sequences xml.state accessors summary
   5 namespaces io.streams.string ;
   6 IN: xml.errors
   7
   8 TUPLE: xml-error-at line column ;
   9
  10 : xml-error-at ( class -- obj )
  11     new
  12         get-line >>line
  13         get-column >>column ;
  14 M: xml-error-at summary ( obj -- str )
  15     [
  16         "XML parsing error" print
  17         "Line: " write dup line>> .
  18         "Column: " write column>> .
  19     ] with-string-writer ;
  20
  21 TUPLE: expected < xml-error-at should-be was ;
  22 : expected ( should-be was -- * )
  23     \ expected xml-error-at
  24         swap >>was
  25         swap >>should-be throw ;
  26 M: expected summary ( obj -- str )
  27     [
  28         dup call-next-method write
  29         "Token expected: " write dup should-be>> print
  30         "Token present: " write was>> print
  31     ] with-string-writer ;
  32
  33 TUPLE: unexpected-end < xml-error-at ;
  34 : unexpected-end ( -- * ) \ unexpected-end xml-error-at throw ;
  35 M: unexpected-end summary ( obj -- str )
  36     [
  37         call-next-method write
  38         "File unexpectedly ended." print
  39     ] with-string-writer ;
  40
  41 TUPLE: missing-close < xml-error-at ;
  42 : missing-close ( -- * ) \ missing-close xml-error-at throw ;
  43 M: missing-close summary ( obj -- str )
  44     [
  45         call-next-method write
  46         "Missing closing token." print
  47     ] with-string-writer ;
  48
  49 TUPLE: disallowed-char < xml-error-at char ;
  50
  51 : disallowed-char ( char -- * )
  52     \ disallowed-char xml-error-at swap >>char throw ;
  53
  54 M: disallowed-char summary
  55     [ call-next-method ]
  56     [ char>> "Disallowed character in XML document: " swap suffix ] bi
  57     append ;
  58
  59 ERROR: multitags ;
  60
  61 M: multitags summary ( obj -- str )
  62     drop "XML document contains multiple main tags" ;
  63
  64 ERROR: pre/post-content string pre? ;
  65
  66 M: pre/post-content summary ( obj -- str )
  67     [
  68         "The text string:" print
  69         dup string>> .
  70         "was used " write
  71         pre?>> "before" "after" ? write
  72         " the main tag." print
  73     ] with-string-writer ;
  74
  75 TUPLE: no-entity < xml-error-at thing ;
  76
  77 : no-entity ( string -- * )
  78     \ no-entity xml-error-at swap >>thing throw ;
  79
  80 M: no-entity summary ( obj -- str )
  81     [
  82         dup call-next-method write
  83         "Entity does not exist: &" write thing>> write ";" print
  84     ] with-string-writer ;
  85
  86 TUPLE: mismatched < xml-error-at open close ;
  87
  88 : mismatched ( open close -- * )
  89     \ mismatched xml-error-at swap >>close swap >>open throw ;
  90
  91 M: mismatched summary ( obj -- str )
  92     [
  93         dup call-next-method write
  94         "Mismatched tags" print
  95         "Opening tag: <" write dup open>> print-name ">" print
  96         "Closing tag: </" write close>> print-name ">" print
  97     ] with-string-writer ;
  98
  99 TUPLE: unclosed < xml-error-at tags ;
 100
 101 : unclosed ( -- * )
 102     \ unclosed xml-error-at
 103         xml-stack get rest-slice [ first name>> ] map >>tags
 104     throw ;
 105
 106 M: unclosed summary ( obj -- str )
 107     [
 108         dup call-next-method write
 109         "Unclosed tags" print
 110         "Tags: " print
 111         tags>> [ "  <" write print-name ">" print ] each
 112     ] with-string-writer ;
 113
 114 TUPLE: bad-uri < xml-error-at string ;
 115
 116 : bad-uri ( string -- * )
 117     \ bad-uri xml-error-at swap >>string throw ;
 118
 119 M: bad-uri summary ( obj -- str )
 120     [
 121         dup call-next-method write
 122         "Bad URI:" print string>> .
 123     ] with-string-writer ;
 124
 125 TUPLE: nonexist-ns < xml-error-at name ;
 126
 127 : nonexist-ns ( name-string -- * )
 128     \ nonexist-ns xml-error-at swap >>name throw ;
 129
 130 M: nonexist-ns summary ( obj -- str )
 131     [
 132         dup call-next-method write
 133         "Namespace " write name>> write " has not been declared" print
 134     ] with-string-writer ;
 135
 136 TUPLE: unopened < xml-error-at ; ! this should give which tag was unopened
 137
 138 : unopened ( -- * )
 139     \ unopened xml-error-at throw ;
 140
 141 M: unopened summary ( obj -- str )
 142     [
 143         call-next-method write
 144         "Closed an unopened tag" print
 145     ] with-string-writer ;
 146
 147 TUPLE: not-yes/no < xml-error-at text ;
 148
 149 : not-yes/no ( text -- * )
 150     \ not-yes/no xml-error-at swap >>text throw ;
 151
 152 M: not-yes/no summary ( obj -- str )
 153     [
 154         dup call-next-method write
 155         "standalone must be either yes or no, not \"" write
 156         text>> write "\"." print
 157     ] with-string-writer ;
 158
 159 ! this should actually print the names
 160 TUPLE: extra-attrs < xml-error-at attrs ;
 161
 162 : extra-attrs ( attrs -- * )
 163     \ extra-attrs xml-error-at swap >>attrs throw ;
 164
 165 M: extra-attrs summary ( obj -- str )
 166     [
 167         dup call-next-method write
 168         "Extra attributes included in xml version declaration:" print
 169         attrs>> .
 170     ] with-string-writer ;
 171
 172 TUPLE: bad-version < xml-error-at num ;
 173
 174 : bad-version ( num -- * )
 175     \ bad-version xml-error-at swap >>num throw ;
 176
 177 M: bad-version summary ( obj -- str )
 178     [
 179         "XML version must be \"1.0\" or \"1.1\". Version here was " write
 180         num>> .
 181     ] with-string-writer ;
 182
 183 ERROR: notags ;
 184
 185 M: notags summary ( obj -- str )
 186     drop "XML document lacks a main tag" ;
 187
 188 TUPLE: bad-prolog < xml-error-at prolog ;
 189
 190 : bad-prolog ( prolog -- * )
 191     \ bad-prolog xml-error-at swap >>prolog throw ;
 192
 193 M: bad-prolog summary ( obj -- str )
 194     [
 195         dup call-next-method write
 196         "Misplaced XML prolog" print
 197         prolog>> write-xml nl
 198     ] with-string-writer ;
 199
 200 TUPLE: capitalized-prolog < xml-error-at name ;
 201
 202 : capitalized-prolog ( name -- capitalized-prolog )
 203     \ capitalized-prolog xml-error-at swap >>name throw ;
 204
 205 M: capitalized-prolog summary ( obj -- str )
 206     [
 207         dup call-next-method write
 208         "XML prolog name was partially or totally capitalized, using" print
 209         "<?" write name>> write "...?>" write
 210         " instead of <?xml...?>" print
 211     ] with-string-writer ;
 212
 213 TUPLE: versionless-prolog < xml-error-at ;
 214
 215 : versionless-prolog ( -- * )
 216     \ versionless-prolog xml-error-at throw ;
 217
 218 M: versionless-prolog summary ( obj -- str )
 219     [
 220         call-next-method write
 221         "XML prolog lacks a version declaration" print
 222     ] with-string-writer ;
 223
 224 TUPLE: bad-directive < xml-error-at dir ;
 225
 226 : bad-directive ( directive -- * )
 227     \ bad-directive xml-error-at swap >>dir throw ;
 228
 229 M: bad-directive summary ( obj -- str )
 230     [
 231         dup call-next-method write
 232         "Unknown directive:" print
 233         dir>> write
 234     ] with-string-writer ;
 235
 236 TUPLE: bad-decl < xml-error-at ;
 237
 238 : bad-decl ( -- * )
 239     \ bad-decl xml-error-at throw ;
 240
 241 M: bad-decl summary ( obj -- str )
 242     call-next-method "\nExtra content in directive" append ;
 243
 244 TUPLE: bad-external-id < xml-error-at ;
 245
 246 : bad-external-id ( -- * )
 247     \ bad-external-id xml-error-at throw ;
 248
 249 M: bad-external-id summary ( obj -- str )
 250     call-next-method "\nBad external ID" append ;
 251
 252 TUPLE: misplaced-directive < xml-error-at dir ;
 253
 254 : misplaced-directive ( directive -- * )
 255     \ misplaced-directive xml-error-at swap >>dir throw ;
 256
 257 M: misplaced-directive summary ( obj -- str )
 258     [
 259         dup call-next-method write
 260         "Misplaced directive:" print
 261         dir>> write-xml nl
 262     ] with-string-writer ;
 263
 264 TUPLE: bad-name < xml-error-at name ;
 265
 266 : bad-name ( name -- * )
 267     \ bad-name xml-error-at swap >>name throw ;
 268
 269 M: bad-name summary ( obj -- str )
 270     [ call-next-method ]
 271     [ "Invalid name: " swap name>> "\n" 3append ]
 272     bi append ;
 273
 274 TUPLE: unclosed-quote < xml-error-at ;
 275
 276 : unclosed-quote ( -- * )
 277     \ unclosed-quote xml-error-at throw ;
 278
 279 M: unclosed-quote summary
 280     call-next-method
 281     "XML document ends with quote still open\n" append ;
 282
 283 TUPLE: quoteless-attr < xml-error-at ;
 284
 285 : quoteless-attr ( -- * )
 286     \ quoteless-attr xml-error-at throw ;
 287
 288 M: quoteless-attr summary
 289     call-next-method "Attribute lacks quotes around value\n" append ;
 290
 291 TUPLE: attr-w/< < xml-error-at ;
 292
 293 : attr-w/< ( value -- * )
 294     \ attr-w/< xml-error-at throw ;
 295
 296 M: attr-w/< summary
 297     call-next-method
 298     "Attribute value contains literal <" append ;
 299
 300 TUPLE: text-w/]]> < xml-error-at ;
 301
 302 : text-w/]]> ( text -- * )
 303     \ text-w/]]> xml-error-at throw ;
 304
 305 M: text-w/]]> summary
 306     call-next-method
 307     "Text node contains ']]>'" append ;
 308
 309 TUPLE: duplicate-attr < xml-error-at key values ;
 310
 311 : duplicate-attr ( key values -- * )
 312     \ duplicate-attr xml-error-at
 313     swap >>values swap >>key throw ;
 314
 315 M: duplicate-attr summary
 316     call-next-method "\nDuplicate attribute" append ;
 317
 318 TUPLE: bad-cdata < xml-error-at ;
 319
 320 : bad-cdata ( -- * )
 321     \ bad-cdata xml-error-at throw ;
 322
 323 M: bad-cdata summary
 324     call-next-method "\nCDATA occurs before or after main tag" append ;
 325
 326 TUPLE: not-enough-characters < xml-error-at ;
 327 : not-enough-characters ( -- * )
 328     \ not-enough-characters xml-error-at throw ;
 329 M: not-enough-characters summary ( obj -- str )
 330     [
 331         call-next-method write
 332         "Not enough characters" print
 333     ] with-string-writer ;
 334
 335 TUPLE: bad-doctype < xml-error-at contents ;
 336 : bad-doctype ( contents -- * )
 337     \ bad-doctype xml-error-at swap >>contents throw ;
 338 M: bad-doctype summary
 339     call-next-method "\nDTD contains invalid object" append ;
 340
 341 UNION: xml-error
 342     multitags notags pre/post-content xml-error-at ;