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 state-parser accessors summary
   5 namespaces io.streams.string xml.backend ;
   6 IN: xml.errors
   7
   8 ERROR: multitags ;
   9
  10 M: multitags summary ( obj -- str )
  11     drop "XML document contains multiple main tags" ;
  12
  13 ERROR: pre/post-content string pre? ;
  14
  15 M: pre/post-content summary ( obj -- str )
  16     [
  17         "The text string:" print
  18         dup string>> .
  19         "was used " write
  20         pre?>> "before" "after" ? write
  21         " the main tag." print
  22     ] with-string-writer ;
  23
  24 TUPLE: no-entity < parsing-error thing ;
  25
  26 : no-entity ( string -- * )
  27     \ no-entity parsing-error swap >>thing throw ;
  28
  29 M: no-entity summary ( obj -- str )
  30     [
  31         dup call-next-method write
  32         "Entity does not exist: &" write thing>> write ";" print
  33     ] with-string-writer ;
  34
  35 TUPLE: xml-string-error < parsing-error string ; ! this should not exist
  36
  37 : xml-string-error ( string -- * )
  38     \ xml-string-error parsing-error swap >>string throw ;
  39
  40 M: xml-string-error summary ( obj -- str )
  41     [
  42         dup call-next-method write
  43         string>> print
  44     ] with-string-writer ;
  45
  46 TUPLE: mismatched < parsing-error open close ;
  47
  48 : mismatched ( open close -- * )
  49     \ mismatched parsing-error swap >>close swap >>open throw ;
  50
  51 M: mismatched summary ( obj -- str )
  52     [
  53         dup call-next-method write
  54         "Mismatched tags" print
  55         "Opening tag: <" write dup open>> print-name ">" print
  56         "Closing tag: </" write close>> print-name ">" print
  57     ] with-string-writer ;
  58
  59 TUPLE: unclosed < parsing-error tags ;
  60
  61 : unclosed ( -- * )
  62     \ unclosed parsing-error
  63         xml-stack get rest-slice [ first name>> ] map >>tags
  64     throw ;
  65
  66 M: unclosed summary ( obj -- str )
  67     [
  68         dup call-next-method write
  69         "Unclosed tags" print
  70         "Tags: " print
  71         tags>> [ "  <" write print-name ">" print ] each
  72     ] with-string-writer ;
  73
  74 TUPLE: bad-uri < parsing-error string ;
  75
  76 : bad-uri ( string -- * )
  77     \ bad-uri parsing-error swap >>string throw ;
  78
  79 M: bad-uri summary ( obj -- str )
  80     [
  81         dup call-next-method write
  82         "Bad URI:" print string>> .
  83     ] with-string-writer ;
  84
  85 TUPLE: nonexist-ns < parsing-error name ;
  86
  87 : nonexist-ns ( name-string -- * )
  88     \ nonexist-ns parsing-error swap >>name throw ;
  89
  90 M: nonexist-ns summary ( obj -- str )
  91     [
  92         dup call-next-method write
  93         "Namespace " write name>> write " has not been declared" print
  94     ] with-string-writer ;
  95
  96 TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
  97
  98 : unopened ( -- * )
  99     \ unopened parsing-error throw ;
 100
 101 M: unopened summary ( obj -- str )
 102     [
 103         call-next-method write
 104         "Closed an unopened tag" print
 105     ] with-string-writer ;
 106
 107 TUPLE: not-yes/no < parsing-error text ;
 108
 109 : not-yes/no ( text -- * )
 110     \ not-yes/no parsing-error swap >>text throw ;
 111
 112 M: not-yes/no summary ( obj -- str )
 113     [
 114         dup call-next-method write
 115         "standalone must be either yes or no, not \"" write
 116         text>> write "\"." print
 117     ] with-string-writer ;
 118
 119 ! this should actually print the names
 120 TUPLE: extra-attrs < parsing-error attrs ;
 121
 122 : extra-attrs ( attrs -- * )
 123     \ extra-attrs parsing-error swap >>attrs throw ;
 124
 125 M: extra-attrs summary ( obj -- str )
 126     [
 127         dup call-next-method write
 128         "Extra attributes included in xml version declaration:" print
 129         attrs>> .
 130     ] with-string-writer ;
 131
 132 TUPLE: bad-version < parsing-error num ;
 133
 134 : bad-version ( num -- * )
 135     \ bad-version parsing-error swap >>num throw ;
 136
 137 M: bad-version summary ( obj -- str )
 138     [
 139         "XML version must be \"1.0\" or \"1.1\". Version here was " write
 140         num>> .
 141     ] with-string-writer ;
 142
 143 ERROR: notags ;
 144
 145 M: notags summary ( obj -- str )
 146     drop "XML document lacks a main tag" ;
 147
 148 TUPLE: bad-prolog < parsing-error prolog ;
 149
 150 : bad-prolog ( prolog -- * )
 151     \ bad-prolog parsing-error swap >>prolog throw ;
 152
 153 M: bad-prolog summary ( obj -- str )
 154     [
 155         dup call-next-method write
 156         "Misplaced XML prolog" print
 157         prolog>> write-prolog nl
 158     ] with-string-writer ;
 159
 160 TUPLE: capitalized-prolog < parsing-error name ;
 161
 162 : capitalized-prolog ( name -- capitalized-prolog )
 163     \ capitalized-prolog parsing-error swap >>name throw ;
 164
 165 M: capitalized-prolog summary ( obj -- str )
 166     [
 167         dup call-next-method write
 168         "XML prolog name was partially or totally capitalized, using" print
 169         "<?" write name>> write "...?>" write
 170         " instead of <?xml...?>" print
 171     ] with-string-writer ;
 172
 173 TUPLE: versionless-prolog < parsing-error ;
 174
 175 : versionless-prolog ( -- * )
 176     \ versionless-prolog parsing-error throw ;
 177
 178 M: versionless-prolog summary ( obj -- str )
 179     [
 180         call-next-method write
 181         "XML prolog lacks a version declaration" print
 182     ] with-string-writer ;
 183
 184 TUPLE: bad-instruction < parsing-error instruction ;
 185
 186 : bad-instruction ( instruction -- * )
 187     \ bad-instruction parsing-error swap >>instruction throw ;
 188
 189 M: bad-instruction summary ( obj -- str )
 190     [
 191         dup call-next-method write
 192         "Misplaced processor instruction:" print
 193         instruction>> write-xml-chunk nl
 194     ] with-string-writer ;
 195
 196 TUPLE: bad-directive < parsing-error dir ;
 197
 198 : bad-directive ( directive -- * )
 199     \ bad-directive parsing-error swap >>dir throw ;
 200
 201 M: bad-directive summary ( obj -- str )
 202     [
 203         dup call-next-method write
 204         "Unknown directive:" print
 205         dir>> write
 206     ] with-string-writer ;
 207
 208 TUPLE: bad-doctype-decl < parsing-error ;
 209
 210 : bad-doctype-decl ( -- * )
 211     \ bad-doctype-decl parsing-error throw ;
 212
 213 M: bad-doctype-decl summary ( obj -- str )
 214     call-next-method "\nBad DOCTYPE" append ;
 215
 216 TUPLE: bad-external-id < parsing-error ;
 217
 218 : bad-external-id ( -- * )
 219     \ bad-external-id parsing-error throw ;
 220
 221 M: bad-external-id summary ( obj -- str )
 222     call-next-method "\nBad external ID" append ;
 223
 224 TUPLE: misplaced-directive < parsing-error dir ;
 225
 226 : misplaced-directive ( directive -- * )
 227     \ misplaced-directive parsing-error swap >>dir throw ;
 228
 229 M: misplaced-directive summary ( obj -- str )
 230     [
 231         dup call-next-method write
 232         "Misplaced directive:" print
 233         dir>> write-xml-chunk nl
 234     ] with-string-writer ;
 235
 236 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
 237        not-yes/no unclosed mismatched xml-string-error expected no-entity
 238        bad-prolog versionless-prolog capitalized-prolog bad-instruction
 239        bad-directive ;