extra/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 inspector
   5 namespaces io.streams.string xml.backend ;
   6 IN: xml.errors
   7
   8 TUPLE: multitags ;
   9 C: <multitags> multitags
  10 M: multitags summary ( obj -- str )
  11     drop "XML document contains multiple main tags" ;
  12
  13 TUPLE: pre/post-content string pre? ;
  14 C: <pre/post-content> pre/post-content
  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 : <no-entity> ( string -- error )
  26     \ no-entity parsing-error swap >>thing ;
  27 M: no-entity summary ( obj -- str )
  28     [
  29         dup call-next-method write
  30         "Entity does not exist: &" write thing>> write ";" print
  31     ] with-string-writer ;
  32
  33 TUPLE: xml-string-error < parsing-error string ; ! this should not exist
  34 : <xml-string-error> ( string -- xml-string-error )
  35     \ xml-string-error parsing-error swap >>string ;
  36 M: xml-string-error summary ( obj -- str )
  37     [
  38         dup call-next-method write
  39         string>> print
  40     ] with-string-writer ;
  41
  42 TUPLE: mismatched < parsing-error open close ;
  43 : <mismatched> ( open close -- error )
  44     \ mismatched parsing-error swap >>close swap >>open ;
  45 M: mismatched summary ( obj -- str )
  46     [
  47         dup call-next-method write
  48         "Mismatched tags" print
  49         "Opening tag: <" write dup open>> print-name ">" print
  50         "Closing tag: </" write close>> print-name ">" print
  51     ] with-string-writer ;
  52
  53 TUPLE: unclosed < parsing-error tags ;
  54 : <unclosed> ( -- unclosed )
  55     unclosed parsing-error
  56         xml-stack get rest-slice [ first opener-name ] map >>tags ;
  57 M: unclosed summary ( obj -- str )
  58     [
  59         dup call-next-method write
  60         "Unclosed tags" print
  61         "Tags: " print
  62         tags>> [ "  <" write print-name ">" print ] each
  63     ] with-string-writer ;
  64
  65 TUPLE: bad-uri < parsing-error string ;
  66 : <bad-uri> ( string -- bad-uri )
  67     \ bad-uri parsing-error swap >>string ;
  68 M: bad-uri summary ( obj -- str )
  69     [
  70         dup call-next-method write
  71         "Bad URI:" print string>> .
  72     ] with-string-writer ;
  73
  74 TUPLE: nonexist-ns < parsing-error name ;
  75 : <nonexist-ns> ( name-string -- nonexist-ns )
  76     \ nonexist-ns parsing-error swap >>name ;
  77 M: nonexist-ns summary ( obj -- str )
  78     [
  79         dup call-next-method write
  80         "Namespace " write name>> write " has not been declared" print
  81     ] with-string-writer ;
  82
  83 TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
  84 : <unopened> ( -- unopened )
  85     \ unopened parsing-error ;
  86 M: unopened summary ( obj -- str )
  87     [
  88         call-next-method write
  89         "Closed an unopened tag" print
  90     ] with-string-writer ;
  91
  92 TUPLE: not-yes/no < parsing-error text ;
  93 : <not-yes/no> ( text -- not-yes/no )
  94     \ not-yes/no parsing-error swap >>text ;
  95 M: not-yes/no summary ( obj -- str )
  96     [
  97         dup call-next-method write
  98         "standalone must be either yes or no, not \"" write
  99         text>> write "\"." print
 100     ] with-string-writer ;
 101
 102 ! this should actually print the names
 103 TUPLE: extra-attrs < parsing-error attrs ;
 104 : <extra-attrs> ( attrs -- extra-attrs )
 105     \ extra-attrs parsing-error swap >>attrs ;
 106 M: extra-attrs summary ( obj -- str )
 107     [
 108         dup call-next-method write
 109         "Extra attributes included in xml version declaration:" print
 110         attrs>> .
 111     ] with-string-writer ;
 112
 113 TUPLE: bad-version < parsing-error num ;
 114 : <bad-version> ( num -- error )
 115     \ bad-version parsing-error swap >>num ;
 116 M: bad-version summary ( obj -- str )
 117     [
 118         "XML version must be \"1.0\" or \"1.1\". Version here was " write
 119         num>> .
 120     ] with-string-writer ;
 121
 122 TUPLE: notags ;
 123 C: <notags> notags
 124 M: notags summary ( obj -- str )
 125     drop "XML document lacks a main tag" ;
 126
 127 TUPLE: bad-prolog < parsing-error prolog ;
 128 : <bad-prolog> ( prolog -- bad-prolog )
 129     \ bad-prolog parsing-error swap >>prolog ;
 130 M: bad-prolog summary ( obj -- str )
 131     [
 132         dup call-next-method write
 133         "Misplaced XML prolog" print
 134         prolog>> write-prolog nl
 135     ] with-string-writer ;
 136
 137 TUPLE: capitalized-prolog < parsing-error name ;
 138 : <capitalized-prolog> ( name -- capitalized-prolog )
 139     \ capitalized-prolog parsing-error swap >>name ;
 140 M: capitalized-prolog summary ( obj -- str )
 141     [
 142         dup call-next-method write
 143         "XML prolog name was partially or totally capitalized, using" print
 144         "<?" write name>> write "...?>" write
 145         " instead of <?xml...?>" print
 146     ] with-string-writer ;
 147
 148 TUPLE: versionless-prolog < parsing-error ;
 149 : <versionless-prolog> ( -- versionless-prolog )
 150     \ versionless-prolog parsing-error ;
 151 M: versionless-prolog summary ( obj -- str )
 152     [
 153         call-next-method write
 154         "XML prolog lacks a version declaration" print
 155     ] with-string-writer ;
 156
 157 TUPLE: bad-instruction < parsing-error instruction ;
 158 : <bad-instruction> ( instruction -- bad-instruction )
 159     \ bad-instruction parsing-error swap >>instruction ;
 160 M: bad-instruction summary ( obj -- str )
 161     [
 162         dup call-next-method write
 163         "Misplaced processor instruction:" print
 164         instruction>> write-item nl
 165     ] with-string-writer ;
 166
 167 TUPLE: bad-directive < parsing-error dir ;
 168 : <bad-directive> ( directive -- bad-directive )
 169     \ bad-directive parsing-error swap >>dir ;
 170 M: bad-directive summary ( obj -- str )
 171     [
 172         dup call-next-method write
 173         "Misplaced directive:" print
 174         bad-directive-dir write-item nl
 175     ] with-string-writer ;
 176
 177 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
 178        not-yes/no unclosed mismatched xml-string-error expected no-entity
 179        bad-prolog versionless-prolog capitalized-prolog bad-instruction
 180        bad-directive ;