[r2005-03-06 23:09:24 by afrisch] Error messages

Original author: afrisch
Date: 2005-03-06 23:09:24+00:00

schema/schema_parser.ml

@@ -9,7 +9,7 @@ open Schema_xml
 
 module QTable = Hashtbl.Make(Ns.QName)
 
-let validation_error s = raise (XSD_validation_error s)
+let error s = raise (XSD_validation_error s)
 
 let particle min max term first nullable =
   { part_min = min;
@@ -26,7 +26,7 @@ let particle_model min max mg =
 
 let check_force v =
   try Lazy.force v
-  with Lazy.Undefined -> failwith "Cyclic type definition"
+  with Lazy.Undefined -> error "Cyclic type definition"
 
 
 let bool_attr attr n =
@@ -36,7 +36,8 @@ let bool_attr attr n =
     | Some v -> (match Utf8.get_str v with
 	| "true" | "1" -> true
 	| "false" | "0" -> false
-	| _ -> failwith "Invalid boolean value")
+	| s -> 
+	    error ("Invalid boolean value (" ^ s ^ ") for attribute " ^ attr))
 
 (* element and complex type constructors which take cares of unique id *)
 let element, complex =
@@ -78,7 +79,7 @@ let parse_facets base n =
   let parse_nonneg n =
     let s = Utf8.get_str (_attr "value" n) in
     let i = int_of_string s in
-    if (i < 0) then failwith "Unexpected negative integer";
+    if (i < 0) then error "Unexpected negative integer";
     i
   in
   let aux facets n tag =
@@ -107,7 +108,7 @@ let parse_facets base n =
 		  | "collapse" -> `Collapse
 		  | "preserve" -> `Preserve
 		  | "replace" -> `Replace
-		  | _ -> assert false in
+		  | _ -> error "Unknown value for whiteSpace facet" in
           { facets with whiteSpace = (k,fixed) }
       | "xsd:maxInclusive" ->
           let value = _attr "value" n in
@@ -189,7 +190,7 @@ let schema_of_uri uri =
       let node = 
 	try QTable.find t2 qname
 	with Not_found ->
-	  validation_error ("Can't find declaration for " ^ k ^ " " ^
+	  error ("Can't find declaration for " ^ k ^ " " ^
 			      Ns.QName.to_string qname)
       in
       let decl = f node in
@@ -223,12 +224,12 @@ let schema_of_uri uri =
   let rec resolve_typ qname : Schema_types.type_definition lazy_t =
     try QTable.find typs qname
     with Not_found ->   
-      failwith ("Cannot find type " ^ (Ns.QName.to_string qname))
+      error ("Cannot find type " ^ (Ns.QName.to_string qname))
 
   and resolve_simple_typ qname =
     match check_force (resolve_typ qname) with
       | Simple st -> st
-      | _ -> failwith "Not a simple type"
+      | _ -> error "Not a simple type"
 
   and resolve_elt qname =
     resolve "element" elts elts_elems (parse_elt_decl true) qname
@@ -259,7 +260,7 @@ let schema_of_uri uri =
     match _may_elem "xsd:union" n with
       | Some union -> simple_union name (find_member_types union)
       | None ->
-	  failwith ("Unknown variety for simpleType at line " ^ (string_of_int (_line n)) ^ "  uri = " ^ uri)
+	  error ("Unknown variety for simpleType at line " ^ (string_of_int (_line n)) ^ "  uri = " ^ uri)
 
   (* look for a simple type def: try attribute "base", try "simpleType" child,
    * fail *)
@@ -269,7 +270,7 @@ let schema_of_uri uri =
       | None ->
 	  match _may_elem "xsd:simpleType" n with
 	    | Some v -> parse_simple_type v
-	    | None -> validation_error "no base simple type specified"
+	    | None -> error "no base simple type specified"
 		
   (* look for a simple type def: try attribute "itemType", try "simpleType"
    * child, fail *)
@@ -279,7 +280,7 @@ let schema_of_uri uri =
       | None ->
 	  match _may_elem "xsd:simpleType" n with
 	    | Some v -> parse_simple_type v
-	    | None -> validation_error "no itemType specified"
+	    | None -> error "no itemType specified"
 
   (* look for a list of simple type defs: try attribute "memberTypes", try
    * "simpleType" children, fail *)
@@ -296,7 +297,7 @@ let schema_of_uri uri =
       List.map parse_simple_type nodes
     in
     match members1 @ members2 with
-      | [] -> validation_error "no member types specified"
+      | [] -> error "no member types specified"
       | members -> members
 
 
@@ -394,7 +395,7 @@ let schema_of_uri uri =
 	| None ->
 	    match _may_elem "xsd:extension" content with
 	      | Some v -> (v, `Extension)
-	      | None -> assert false in
+	      | None -> error "No extension element found" in
     let base = resolve_typ (_qname_attr "base" derivation) in
     let base = check_force base in
     let uses = parse_attribute_uses_deriv derivation_type base derivation in
@@ -519,7 +520,7 @@ let schema_of_uri uri =
       | "xsd:any" ->
 	  let w = parse_wildcard n in
 	  particle min max (Wildcard w) w.wild_first (min = 0)
-      | _ -> assert false
+      | _ -> error "Unexpected element for particle"
 	  
   and parse_wildcard n =
     let c = parse_wildcard_cstr n in
@@ -531,7 +532,7 @@ let schema_of_uri uri =
     | Some t when Utf8.get_str t = "skip" -> `Skip
     | Some t when Utf8.get_str t = "strict" -> `Strict
     | None -> `Strict
-    | _ -> failwith "Wildcard processContents attribute not recognized"
+    | _ -> error "Wildcard processContents attribute not recognized"
   and parse_wildcard_cstr n = match _may_attr "namespace" n with
     | None -> WAny
     | Some ns when Utf8.get_str ns = "##any" -> WAny
@@ -565,7 +566,7 @@ let schema_of_uri uri =
     let model_group_node =
       match first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:sequence"] with
 	| Some m -> m
-	| None -> assert false in
+	| None -> error "No model group" in
     let model_group = parse_model_group model_group_node in
     { mg_name = name; mg_def = model_group }
 
@@ -574,7 +575,7 @@ let schema_of_uri uri =
   let check_redef n table kind =
     let name = get_name n in
     if (QTable.mem elts name) then
-      validation_error ("Redefinition of " ^ kind ^ " " ^ 
+      error ("Redefinition of " ^ kind ^ " " ^ 
 			  Ns.QName.to_string name)
     else name
 

schema/schema_validator.ml

@@ -140,7 +140,7 @@ let get_bool v =
   match Utf8.get_str v with
     | "true" | "1" -> true
     | "false" | "0" -> false
-    | _ -> failwith "Invalid boolean value"
+    | _ -> error "Invalid boolean value"
 
 let get_attributes ctx =
   let rec aux attrs nil =

schema/schema_xml.ml

 open Encodings
 open Schema_pcre
 
+exception Error of string
+let error s = raise (Error s)
+
 type node =
   ('a Pxp_document.node Pxp_document.extension as 'a) Pxp_document.node
 
@@ -64,7 +67,7 @@ let _is_attr name n v =
 let _attr name n =
   match n#attribute name with
     | Pxp_types.Value v -> Utf8.mk v
-    | _ -> failwith ("Attribute " ^ name ^ " is missing")
+    | _ -> error ("Attribute " ^ name ^ " is missing")
 	
 let _may_elem e (n: node) =
   try Some (Pxp_document.find_element e n) with Not_found -> None
@@ -134,7 +137,7 @@ let _may_qname_attr name n =
 let _qname_attr name n =
   match _may_attr name n with
     | Some qname -> _resolve_qname n qname
-    | None -> assert false
+    | None -> error ("Cannot find qname attribute " ^ name)
 
 
 let xsd = Ns.mk xsd_namespace

schema/schema_xml.mli

 open Encodings
 
+exception Error of string
 module Node: Set.OrderedType
 type node = Node.t