[r2005-02-25 00:59:40 by afrisch] Schema element wildcards

Original author: afrisch
Date: 2005-02-25 00:59:41+00:00

schema/schema_common.ml

@@ -147,14 +147,21 @@ let anyType = AnyType
 let first_of_particle p = p.part_first
 let nullable p = p.part_nullable
 
+let first_of_wildcard_constraint = function
+  | WAny -> Atoms.any
+  | WNot ns -> Atoms.diff Atoms.any (Atoms.any_in_ns ns)
+  | WOne l -> 
+      List.fold_left (fun acc ns -> Atoms.cup acc (Atoms.any_in_ns ns))
+	Atoms.empty l
 let first_of_model_group = function
   | All particles | Choice particles ->
-      List.concat (List.map first_of_particle particles)
+      List.fold_left (fun acc p -> Atoms.cup acc (first_of_particle p))
+	Atoms.empty particles
   | Sequence particles ->
       let rec aux = function
-        | hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
-        | hd :: tl -> first_of_particle hd
-        | [] -> []
+        | hd::tl when nullable hd -> Atoms.cup (first_of_particle hd) (aux tl)
+        | hd::tl -> first_of_particle hd
+        | [] -> Atoms.empty
       in
       aux particles
 
@@ -394,6 +401,7 @@ and print_particle ppf p =
 and print_term ppf = function
   | Elt e -> Format.fprintf ppf "E%i" e.elt_uid
   | Model m -> print_model_group ppf m
+  | Wildcard _ -> Format.fprintf ppf "Wildcard"
 
 
 

schema/schema_common.mli

@@ -62,9 +62,11 @@ val iter_attribute_groups:
   schema -> (attribute_group_definition -> unit) -> unit
 val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
 
-val first_of_particle: particle -> Ns.qname list
+val first_of_wildcard_constraint: wildcard_constraint -> Atoms.t
+val first_of_particle: particle -> Atoms.t
+val first_of_model_group: model_group -> Atoms.t
+
 val nullable: particle -> bool
-val first_of_model_group: model_group -> Ns.qname list
 val nullable_of_model_group: model_group -> bool
 
 (** {2 Facets} *)

schema/schema_parser.ml

@@ -53,7 +53,7 @@ let element, complex =
 let space_RE = pcre_regexp " "
 let split s = pcre_split ~rex:space_RE s
 
-let unqualify s = snd (Ns.split_qname s)
+(*let unqualify s = snd (Ns.split_qname s)*)
 
 let hashtbl_deref tbl = 
   QTable.fold (fun _ v acc -> (check_force v) :: acc) tbl []
@@ -144,7 +144,8 @@ let rec first n f = function
   | x::l -> match f x n with None -> first n f l | x -> x
 
 let find_particles n =
-  _filter_elems ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence"] n
+  _filter_elems ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence";
+		 "xsd:any" ] n
 
 let find_particle n =
   first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"]
@@ -493,7 +494,8 @@ let schema_of_uri uri =
   and parse_particle n =
     let min, max = parse_min_max n in
     let model mg = particle_model min max mg in
-    let elt e n = particle min max (Elt e) [ n ] (min = 0) in
+    let elt e n = particle min max (Elt e) (Atoms.atom (Atoms.V.of_qname n )) 
+      (min = 0) in
     match _tag n with
       | "xsd:element" ->
 	  (match _may_qname_attr "ref" n with
@@ -504,8 +506,35 @@ let schema_of_uri uri =
       | "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
       | "xsd:all" | "xsd:sequence" | "xsd:choice" -> 
 	  model (parse_model_group n)
+      | "xsd:any" ->
+	  let w = parse_wildcard n in
+	  particle min max (Wildcard w) w.wild_first (min = 0)
       | _ -> assert false
 	  
+  and parse_wildcard n =
+    let c = parse_wildcard_cstr n in
+    { wild_cstr = c;
+      wild_process = parse_wildcard_process n;
+      wild_first = first_of_wildcard_constraint c }
+  and parse_wildcard_process n = match _may_attr "processContents" n with
+    | Some t when Utf8.get_str t = "lax" -> `Lax
+    | 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"
+  and parse_wildcard_cstr n = match _may_attr "namespace" n with
+    | None -> WAny
+    | Some ns when Utf8.get_str ns = "##any" -> WAny
+    | Some ns when Utf8.get_str ns = "##other" -> WNot targetNamespace
+    | Some ns -> WOne (List.map parse_wildcard_ns (split ns))
+  and parse_wildcard_ns = function
+    | ns when Utf8.get_str ns = "##targetNamespace" -> targetNamespace
+    | ns when Utf8.get_str ns = "##local" -> Ns.empty
+    | ns -> Ns.mk ns
+
+
+
+
   and parse_model_group n =
     match _tag n with
       | "xsd:all" ->

schema/schema_types.ml

@@ -66,6 +66,7 @@ and attribute_use =
 and term =
   | Elt of element_declaration
   | Model of model_group
+  | Wildcard of wildcard
 
 and model_group =
   | All of particle list
@@ -81,7 +82,7 @@ and particle =
     { part_min: int;
       part_max: int option;  (* None = unbounded *)
       part_term: term;
-      part_first: Ns.qname list;
+      part_first: Atoms.t;
       part_nullable: bool }
 
 and element_declaration =
@@ -103,6 +104,17 @@ and type_definition =
   | Simple of simple_type_definition
   | Complex of complex_type_definition
 
+and wildcard_constraint =
+  | WAny
+  | WNot of Ns.t
+  | WOne of Ns.t list
+
+and wildcard = {
+  wild_cstr: wildcard_constraint;
+  wild_process: [`Lax | `Skip | `Strict];
+  wild_first: Atoms.t;
+}
+
 type model_group_definition =
     { mg_name : Ns.qname;
       mg_def : model_group }

schema/schema_types.mli

@@ -66,6 +66,7 @@ and attribute_use =
 and term =
   | Elt of element_declaration
   | Model of model_group
+  | Wildcard of wildcard
 
 and model_group =
   | All of particle list
@@ -81,7 +82,7 @@ and particle =
     { part_min: int;
       part_max: int option;  (* None = unbounded *)
       part_term: term;
-      part_first: Ns.qname list;
+      part_first: Atoms.t;
       part_nullable: bool }
 
 and element_declaration =
@@ -103,6 +104,17 @@ and type_definition =
   | Simple of simple_type_definition
   | Complex of complex_type_definition
 
+and wildcard_constraint =
+  | WAny
+  | WNot of Ns.t
+  | WOne of Ns.t list
+
+and wildcard = {
+  wild_cstr: wildcard_constraint;
+  wild_process: [`Lax | `Skip | `Strict];
+  wild_first: Atoms.t;
+}
+
 type model_group_definition =
     { mg_name : Ns.qname;
       mg_def : model_group }

schema/schema_validator.ml

@@ -120,6 +120,7 @@ let expect_start_tag ctx tag =
     | ev -> error (sprintf "Expected tag %s, found %s" 
 		     (Ns.QName.to_string tag) (string_of_event ev))
 
+
 let expect_any_start_tag ctx =
   match next ctx with
     | E_start_tag t -> t
@@ -290,6 +291,15 @@ let rec validate_any_type ctx =
   aux ();
   (Value.vrecord attrs, get ctx)
 
+let validate_wildcard ctx w =
+  let qname = expect_any_start_tag ctx in
+  if Atoms.contains (Atoms.V.of_qname qname) w.wild_first
+  then error (sprintf "Tag %s is not accepted by the wildcard" 
+		(Ns.QName.to_string qname));
+  let (attrs, content) = validate_any_type ctx in
+  expect_end_tag ctx;
+  xml qname attrs content
+
 let check_fixed ~ctx fixed value =
   if not (Value.equal fixed value) then
     error ~ctx (sprintf "Expected fixed value: %s; found %s"
@@ -389,7 +399,7 @@ and validate_particle ctx particle =
     do_pcdata ctx;
     match peek ctx with
     | E_start_tag qname 
-	when List.exists (Ns.QName.equal qname) particle.part_first ->
+	when Atoms.contains (Atoms.V.of_qname qname) particle.part_first ->
 	validate_term ctx particle.part_term;
         cont_ok ()
     | ev -> 
@@ -426,21 +436,19 @@ and validate_particle ctx particle =
 
 and validate_term ctx term =
   match term with
-  | Elt elt_decl_ref -> append ctx (validate_element ctx elt_decl_ref)
-  | Model model_group -> validate_model_group ctx model_group
+  | Elt elt -> append ctx (validate_element ctx elt)
+  | Model mg -> validate_model_group ctx mg
+  | Wildcard w -> append ctx (validate_wildcard ctx w)
 
 and validate_choice ctx particles =
 (* TODO: Handle case when one of the choices is nullable *)
-  let tbl = QTable.create 20 in
-  List.iter
-    (fun p -> 
-       List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
-    particles;
+  let tbl = Atoms.mk_map
+    (List.map (fun p -> first_of_particle p, p) particles) in
   do_pcdata ctx;
   try
     (match peek ctx with
        | E_start_tag qname -> 
-	   let particle = QTable.find tbl qname in
+	   let particle = Atoms.get_map (Atoms.V.of_qname qname) tbl in
 	   validate_particle ctx particle
        | _ -> raise Not_found)
   with Not_found ->
@@ -448,21 +456,16 @@ and validate_choice ctx particles =
 
 and validate_all_group ctx particles =
   let tbl = QTable.create 20 in
-  let slots =
-    List.map
-      (fun p ->
-	 let slot = ref None in
-	 let first = first_of_particle p in
-	 List.iter (fun tag -> QTable.add tbl tag (p,slot)) first;
-	 (nullable p, slot)
-      ) particles in
+  let slots = List.map (fun p -> (p, ref None)) particles in
+  let tbl = Atoms.mk_map
+    (List.map (fun (p,slot) -> first_of_particle p, (p,slot)) slots) in
   
   let contents = ref Value.nil in
   let rec aux () =
     match peek ctx with
       | E_start_tag qname -> 
 	  let qname = next_tag ctx in
-	  let p,slot = QTable.find tbl qname in
+	  let p,slot = Atoms.get_map (Atoms.V.of_qname qname) tbl in
 	  (match !slot with
 	    | Some x -> ()
 	    | None -> 
@@ -474,10 +477,10 @@ and validate_all_group ctx particles =
   do_pcdata ctx;
   aux ();
   List.iter
-    (fun (nullable,slot) ->
+    (fun (p,slot) ->
        match !slot with
 	 | Some x -> concat ctx x
-	 | None when nullable -> ()
+	 | None when nullable p -> ()
 	 | None -> error "One particle of the all group is missing"
     ) slots
 

types/builtin_defs.ml

@@ -71,16 +71,18 @@ let float_abs =
 let float =
   Types.abstract (Types.Abstract.atom float_abs)
 
-let any_xml = 
+let any_attr_node = Types.cons (Types.record' (true,LabelMap.empty)) 
+let any_xml,any_xml_seq,any_xml_content = 
   let elt = Types.make () in
   let seq = Types.make () in
-  let elt_d = Types.xml 
-    (Types.cons atom)
-    (Types.cons (Types.times
-                   (Types.cons (Types.record' (true,LabelMap.empty)))
-                   seq)) in
+  let any_xml_content = Types.cons (Types.times any_attr_node seq) in
+  let elt_d = Types.xml (Types.cons atom) any_xml_content in
   let elt_char_d = Types.cup elt_d char in
   let seq_d = Types.cup nil (Types.times (Types.cons elt_char_d) seq) in
   Types.define elt elt_d;
   Types.define seq seq_d;
-  elt_d
+  elt_d,seq_d,any_xml_content
+
+let any_xml_with_tag t =
+  Types.xml (Types.cons (Types.atom t)) any_xml_content
+    

types/builtin_defs.mli

@@ -43,3 +43,5 @@ val float: Types.t
 val float_abs: Types.Abstract.abs
 
 val any_xml : Types.t
+
+val any_xml_with_tag: Atoms.t -> Types.t

typing/typer.ml

@@ -1636,6 +1636,10 @@ module Schema_converter =
     let rec regexp_of_term = function
       | Model group -> regexp_of_model_group group
       | Elt decl -> PElem (elt_decl decl)
+      | Wildcard w -> PElem (wildcard w)
+
+    and wildcard w = 
+      itype (Builtin_defs.any_xml_with_tag w.wild_first)
 
     and regexp_of_model_group = function
       | Choice l ->