[r2005-02-25 14:13:45 by afrisch] anyAttribute

Original author: afrisch
Date: 2005-02-25 14:13:45+00:00

schema/TODO

+- substitution groups
+- don't name schema, use namespaces
\ No newline at end of file

schema/schema_common.ml

@@ -428,3 +428,6 @@ let xsi_nil_qname = (Schema_xml.xsi,Utf8.mk "nil")
 let xsi_nil_atom = Atoms.V.of_qname xsi_nil_qname
 let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
 let xsi_nil_label = Ident.LabelPool.mk xsi_nil_qname
+
+let merge_attribute_uses l =
+  List.fold_left (fun (l,a) (l',a') -> (l @ l', a || a')) ([],false) l

schema/schema_common.mli

@@ -115,3 +115,6 @@ val xsi_nil_type: Types.t
 val xsi_nil_qname: Ns.qname
 val xsi_nil_atom: Atoms.V.t
 val xsi_nil_label: Ident.label
+
+
+val merge_attribute_uses: attribute_uses list -> attribute_uses

schema/schema_parser.ml

@@ -47,7 +47,8 @@ let element, complex =
       elt_name = name;
       elt_typdef = type_def;
       elt_cstr = constr;
-      elt_nillable = nillable }
+      elt_nillable = nillable
+ }
   in
   let complex name (type_def: type_definition) deriv attrs ct =
     incr counter;
@@ -56,7 +57,8 @@ let element, complex =
       ct_typdef = type_def;
       ct_deriv = deriv;
       ct_attrs = attrs;
-      ct_content = ct }
+      ct_content = ct;
+    }
   in
   (element, complex)
 
@@ -353,38 +355,36 @@ let schema_of_uri uri =
       attr_decl = att_decl;
       attr_use_cstr = value_constr }
       
-  and parse_attribute_uses derivation_type base n =
+  and parse_attribute_uses n =
     let uses1 = (* attribute uses from "attribute" children *)
-      List.map parse_attribute_use (_elems "xsd:attribute" n)
-    in
+      (List.map parse_attribute_use (_elems "xsd:attribute" n)),
+      (match _may_elem "xsd:anyAttribute" n with Some _ -> true | _ ->false) in
+
     let uses2 = (* attribute uses from "attributeGroup" children ref *)
-      List.concat (List.map
-		     (fun att_group ->
-			match _may_qname_attr "ref" att_group with
-			  | Some v -> (resolve_att_group v).ag_def
-			  | None -> []
-		     )
-		     (_elems "xsd:attributeGroup" n))
-    in
-    let uses3 = (* attribute uses from base type *)
-      match base with
-	| Complex { ct_attrs = uses } ->
-            (match derivation_type with
-               | `Extension -> uses
-               | `Restriction ->
-		   let ( &= ) u1 u2 = 
-		     (* by name equality over attribute uses *)
-		     (name_of_attribute_use u1 = name_of_attribute_use u2)
-		   in
-		   let defined_uses = uses1 @ uses2 in
-		   List.filter
-		     (fun use -> 
-			not (List.exists (fun u -> u &= use) defined_uses))
- (*                   && not (List.mem name prohibited_uses1) *) (* TODO prohibited attribute uses *)
-		     uses)
-	| _ -> []
-    in
-    uses1 @ uses2 @ uses3
+      List.map 
+	(fun n -> (parse_att_group n).ag_def)
+	(_elems "xsd:attributeGroup" n)  in
+
+    merge_attribute_uses (uses1::uses2)
+
+  and parse_attribute_uses_deriv derivation_type base n =
+(* TODO: check these rules *)
+    let duses = parse_attribute_uses n in
+    (* attribute uses from base type *)
+    match base, derivation_type with
+      | Complex { ct_attrs = uses }, `Extension -> duses
+      | Complex { ct_attrs = uses }, `Restriction ->
+	  let ( &= ) u1 u2 = 
+	    (* by name equality over attribute uses *)
+	    (name_of_attribute_use u1 = name_of_attribute_use u2)
+	  in
+	  let l = 
+	    List.filter
+	      (fun use -> not (List.exists (fun u -> u &= use) (fst duses)))
+	      (fst uses) in
+	  merge_attribute_uses [duses;(l,false)]
+      | _ -> duses
+	  
 
 
 
@@ -398,7 +398,7 @@ let schema_of_uri uri =
 	      | None -> assert false in
     let base = resolve_typ (_qname_attr "base" derivation) in
     let base = check_force base in
-    let uses = parse_attribute_uses derivation_type base derivation in
+    let uses = parse_attribute_uses_deriv derivation_type base derivation in
     (derivation,derivation_type,base,uses)
     
   and parse_complex_type_def n =
@@ -463,7 +463,7 @@ let schema_of_uri uri =
     base,derivation_type,uses,content_type
 
   and parse_other_content n =
-    let uses = parse_attribute_uses `Restriction AnyType n in
+    let uses = parse_attribute_uses n in
     let mixed = bool_attr "mixed" n in
     let content_type =
       match find_particle n with
@@ -557,17 +557,9 @@ let schema_of_uri uri =
       | _ -> assert false
 	  
   and parse_att_group n =
-    let name = get_name n in
-    let uses1 =
-      List.map parse_attribute_use (_elems "xsd:attribute" n)
-    in
-    let uses2 =
-      List.concat 
-	(List.map 
-	   (fun name -> (resolve_att_group name).ag_def)
-	   (List.map (_qname_attr "ref") (_elems "xsd:attributeGroup" n)))
-    in
-    { ag_name = name; ag_def = uses1 @ uses2 }
+    match _may_qname_attr "ref" n with
+      | Some v -> resolve_att_group v
+      | None -> { ag_name = get_name n; ag_def = parse_attribute_uses n }
       
   and parse_model_group_def n =
     let name = get_name n in

schema/schema_types.ml

@@ -90,15 +90,20 @@ and element_declaration =
       elt_name: Ns.qname;
       elt_typdef: type_ref;
       elt_cstr: value_constraint option;
-      elt_nillable: bool }
+      elt_nillable: bool;
+    }
 
 and complex_type_definition =
     { ct_uid: int;
       ct_name: Ns.qname option;
       ct_typdef: type_definition;
       ct_deriv: derivation_type;
-      ct_attrs: attribute_use list;
-      ct_content: content_type }
+      ct_attrs: attribute_uses;
+      ct_content: content_type;
+    }
+
+and attribute_uses = attribute_use list * bool  
+  (* true = allow other attribs *)
 
 and type_definition =
   | AnyType
@@ -122,7 +127,7 @@ type model_group_definition =
 
 type attribute_group_definition =
     { ag_name : Ns.qname;
-      ag_def : attribute_use list }
+      ag_def : attribute_uses }
 
 type schema = {
   targetNamespace: Ns.t;

schema/schema_types.mli

@@ -90,15 +90,20 @@ and element_declaration =
       elt_name: Ns.qname;
       elt_typdef: type_ref;
       elt_cstr: value_constraint option;
-      elt_nillable: bool }
+      elt_nillable: bool;
+    }
 
 and complex_type_definition =
     { ct_uid: int;
       ct_name: Ns.qname option;
       ct_typdef: type_definition;
       ct_deriv: derivation_type;
-      ct_attrs: attribute_use list;
-      ct_content: content_type }
+      ct_attrs: attribute_uses;
+      ct_content: content_type;
+    }
+
+and attribute_uses = attribute_use list * bool  
+  (* true = allow other attribs *)
 
 and type_definition =
   | AnyType
@@ -122,7 +127,7 @@ type model_group_definition =
 
 type attribute_group_definition =
     { ag_name : Ns.qname;
-      ag_def : attribute_use list }
+      ag_def : attribute_uses }
 
 type schema = {
   targetNamespace: Ns.t;

schema/schema_validator.ml

@@ -332,7 +332,7 @@ let next_tag ctx =
     | E_start_tag qname -> qname
     | _ -> raise Not_found
 
-let validate_attribute_uses attrs attr_uses =
+let validate_attribute_uses attrs (attr_uses,anyattr) =
   let tbl = QTable.create 11 in
   List.iter
     (fun use -> QTable.add tbl (name_of_attribute_use use) use)
@@ -340,18 +340,20 @@ let validate_attribute_uses attrs attr_uses =
   let attribs = ref [] in
   List.iter
     (fun (qname, value) ->
-       let { attr_decl =  { attr_typdef = st_def };
-	     attr_use_cstr = constr } =
-         try QTable.find tbl qname
-         with Not_found ->
-           error (sprintf "Unexpected attribute: %s"
-		    (Ns.QName.to_string qname))
+       let value = 
+	 try
+	   let a = QTable.find tbl qname in
+	   let value = validate_simple_type a.attr_decl.attr_typdef value in
+	   (match a.attr_use_cstr with  (* check fixed constraint *)
+              | Some (`Fixed v) -> check_fixed v value
+              | _ -> ());
+	   QTable.remove tbl qname;
+	   value
+	 with Not_found ->
+	   if anyattr then Value.string_utf8 value
+	   else error 
+	     (sprintf "Unexpected attribute: %s" (Ns.QName.to_string qname))
        in
-       let value = validate_simple_type st_def value in
-       (match constr with  (* check fixed constraint *)
-          | Some (`Fixed v) -> check_fixed v value
-          | _ -> ());
-       QTable.remove tbl qname;
        attribs := (qname, value) :: !attribs
     ) attrs.attrs;
   if attrs.xsi_nil then

typing/typer.ml

@@ -1705,9 +1705,10 @@ module Schema_converter =
           rexp regexp	
 
       (** @return a closed record *)
-    and attr_uses attr_uses =
+    and attr_uses (attrs,other) =
 (* TODO: produce directly internal types *)
 (*  (is it better ?  we wouln't benefit from hash-consing) *)
+      print_endline ("Other = " ^ (if other then "true" else "false"));
       let fields = 
 	List.map 
           (fun at ->
@@ -1719,8 +1720,8 @@ module Schema_converter =
             in
             let r = if at.attr_required then r else mk (IOptional r) in
             (LabelPool.mk at.attr_decl.attr_name, (r,None)))
-          attr_uses in
-      mk (IRecord (false, LabelMap.from_list_disj fields))
+          attrs in
+      mk (IRecord (other, LabelMap.from_list_disj fields))
 
     and att_decl att =
       let r = itype (simple_type att.attr_typdef) in