Commit d3686111 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2005-03-06 23:09:24+00:00
parent 8337b304
......@@ -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
......
......@@ -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 =
......
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
......
open Encodings
exception Error of string
module Node: Set.OrderedType
type node = Node.t
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment