Commit 1d31f2a0 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2005-02-25 14:13:45+00:00
parent 12150868
- substitution groups
- don't name schema, use namespaces
\ No newline at end of file
...@@ -428,3 +428,6 @@ let xsi_nil_qname = (Schema_xml.xsi,Utf8.mk "nil") ...@@ -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_atom = Atoms.V.of_qname xsi_nil_qname
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom) let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_label = Ident.LabelPool.mk xsi_nil_qname 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
...@@ -115,3 +115,6 @@ val xsi_nil_type: Types.t ...@@ -115,3 +115,6 @@ val xsi_nil_type: Types.t
val xsi_nil_qname: Ns.qname val xsi_nil_qname: Ns.qname
val xsi_nil_atom: Atoms.V.t val xsi_nil_atom: Atoms.V.t
val xsi_nil_label: Ident.label val xsi_nil_label: Ident.label
val merge_attribute_uses: attribute_uses list -> attribute_uses
...@@ -47,7 +47,8 @@ let element, complex = ...@@ -47,7 +47,8 @@ let element, complex =
elt_name = name; elt_name = name;
elt_typdef = type_def; elt_typdef = type_def;
elt_cstr = constr; elt_cstr = constr;
elt_nillable = nillable } elt_nillable = nillable
}
in in
let complex name (type_def: type_definition) deriv attrs ct = let complex name (type_def: type_definition) deriv attrs ct =
incr counter; incr counter;
...@@ -56,7 +57,8 @@ let element, complex = ...@@ -56,7 +57,8 @@ let element, complex =
ct_typdef = type_def; ct_typdef = type_def;
ct_deriv = deriv; ct_deriv = deriv;
ct_attrs = attrs; ct_attrs = attrs;
ct_content = ct } ct_content = ct;
}
in in
(element, complex) (element, complex)
...@@ -353,38 +355,36 @@ let schema_of_uri uri = ...@@ -353,38 +355,36 @@ let schema_of_uri uri =
attr_decl = att_decl; attr_decl = att_decl;
attr_use_cstr = value_constr } 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 *) let uses1 = (* attribute uses from "attribute" children *)
List.map parse_attribute_use (_elems "xsd:attribute" n) (List.map parse_attribute_use (_elems "xsd:attribute" n)),
in (match _may_elem "xsd:anyAttribute" n with Some _ -> true | _ ->false) in
let uses2 = (* attribute uses from "attributeGroup" children ref *) let uses2 = (* attribute uses from "attributeGroup" children ref *)
List.concat (List.map List.map
(fun att_group -> (fun n -> (parse_att_group n).ag_def)
match _may_qname_attr "ref" att_group with (_elems "xsd:attributeGroup" n) in
| Some v -> (resolve_att_group v).ag_def
| None -> [] merge_attribute_uses (uses1::uses2)
)
(_elems "xsd:attributeGroup" n)) and parse_attribute_uses_deriv derivation_type base n =
in (* TODO: check these rules *)
let uses3 = (* attribute uses from base type *) let duses = parse_attribute_uses n in
match base with (* attribute uses from base type *)
| Complex { ct_attrs = uses } -> match base, derivation_type with
(match derivation_type with | Complex { ct_attrs = uses }, `Extension -> duses
| `Extension -> uses | Complex { ct_attrs = uses }, `Restriction ->
| `Restriction -> let ( &= ) u1 u2 =
let ( &= ) u1 u2 = (* by name equality over attribute uses *)
(* by name equality over attribute uses *) (name_of_attribute_use u1 = name_of_attribute_use u2)
(name_of_attribute_use u1 = name_of_attribute_use u2) in
in let l =
let defined_uses = uses1 @ uses2 in List.filter
List.filter (fun use -> not (List.exists (fun u -> u &= use) (fst duses)))
(fun use -> (fst uses) in
not (List.exists (fun u -> u &= use) defined_uses)) merge_attribute_uses [duses;(l,false)]
(* && not (List.mem name prohibited_uses1) *) (* TODO prohibited attribute uses *) | _ -> duses
uses)
| _ -> []
in
uses1 @ uses2 @ uses3
...@@ -398,7 +398,7 @@ let schema_of_uri uri = ...@@ -398,7 +398,7 @@ let schema_of_uri uri =
| None -> assert false in | None -> assert false in
let base = resolve_typ (_qname_attr "base" derivation) in let base = resolve_typ (_qname_attr "base" derivation) in
let base = check_force base 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) (derivation,derivation_type,base,uses)
and parse_complex_type_def n = and parse_complex_type_def n =
...@@ -463,7 +463,7 @@ let schema_of_uri uri = ...@@ -463,7 +463,7 @@ let schema_of_uri uri =
base,derivation_type,uses,content_type base,derivation_type,uses,content_type
and parse_other_content n = 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 mixed = bool_attr "mixed" n in
let content_type = let content_type =
match find_particle n with match find_particle n with
...@@ -557,17 +557,9 @@ let schema_of_uri uri = ...@@ -557,17 +557,9 @@ let schema_of_uri uri =
| _ -> assert false | _ -> assert false
and parse_att_group n = and parse_att_group n =
let name = get_name n in match _may_qname_attr "ref" n with
let uses1 = | Some v -> resolve_att_group v
List.map parse_attribute_use (_elems "xsd:attribute" n) | None -> { ag_name = get_name n; ag_def = parse_attribute_uses 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 }
and parse_model_group_def n = and parse_model_group_def n =
let name = get_name n in let name = get_name n in
......
...@@ -90,15 +90,20 @@ and element_declaration = ...@@ -90,15 +90,20 @@ and element_declaration =
elt_name: Ns.qname; elt_name: Ns.qname;
elt_typdef: type_ref; elt_typdef: type_ref;
elt_cstr: value_constraint option; elt_cstr: value_constraint option;
elt_nillable: bool } elt_nillable: bool;
}
and complex_type_definition = and complex_type_definition =
{ ct_uid: int; { ct_uid: int;
ct_name: Ns.qname option; ct_name: Ns.qname option;
ct_typdef: type_definition; ct_typdef: type_definition;
ct_deriv: derivation_type; ct_deriv: derivation_type;
ct_attrs: attribute_use list; ct_attrs: attribute_uses;
ct_content: content_type } ct_content: content_type;
}
and attribute_uses = attribute_use list * bool
(* true = allow other attribs *)
and type_definition = and type_definition =
| AnyType | AnyType
...@@ -122,7 +127,7 @@ type model_group_definition = ...@@ -122,7 +127,7 @@ type model_group_definition =
type attribute_group_definition = type attribute_group_definition =
{ ag_name : Ns.qname; { ag_name : Ns.qname;
ag_def : attribute_use list } ag_def : attribute_uses }
type schema = { type schema = {
targetNamespace: Ns.t; targetNamespace: Ns.t;
......
...@@ -90,15 +90,20 @@ and element_declaration = ...@@ -90,15 +90,20 @@ and element_declaration =
elt_name: Ns.qname; elt_name: Ns.qname;
elt_typdef: type_ref; elt_typdef: type_ref;
elt_cstr: value_constraint option; elt_cstr: value_constraint option;
elt_nillable: bool } elt_nillable: bool;
}
and complex_type_definition = and complex_type_definition =
{ ct_uid: int; { ct_uid: int;
ct_name: Ns.qname option; ct_name: Ns.qname option;
ct_typdef: type_definition; ct_typdef: type_definition;
ct_deriv: derivation_type; ct_deriv: derivation_type;
ct_attrs: attribute_use list; ct_attrs: attribute_uses;
ct_content: content_type } ct_content: content_type;
}
and attribute_uses = attribute_use list * bool
(* true = allow other attribs *)
and type_definition = and type_definition =
| AnyType | AnyType
...@@ -122,7 +127,7 @@ type model_group_definition = ...@@ -122,7 +127,7 @@ type model_group_definition =
type attribute_group_definition = type attribute_group_definition =
{ ag_name : Ns.qname; { ag_name : Ns.qname;
ag_def : attribute_use list } ag_def : attribute_uses }
type schema = { type schema = {
targetNamespace: Ns.t; targetNamespace: Ns.t;
......
...@@ -332,7 +332,7 @@ let next_tag ctx = ...@@ -332,7 +332,7 @@ let next_tag ctx =
| E_start_tag qname -> qname | E_start_tag qname -> qname
| _ -> raise Not_found | _ -> raise Not_found
let validate_attribute_uses attrs attr_uses = let validate_attribute_uses attrs (attr_uses,anyattr) =
let tbl = QTable.create 11 in let tbl = QTable.create 11 in
List.iter List.iter
(fun use -> QTable.add tbl (name_of_attribute_use use) use) (fun use -> QTable.add tbl (name_of_attribute_use use) use)
...@@ -340,18 +340,20 @@ let validate_attribute_uses attrs attr_uses = ...@@ -340,18 +340,20 @@ let validate_attribute_uses attrs attr_uses =
let attribs = ref [] in let attribs = ref [] in
List.iter List.iter
(fun (qname, value) -> (fun (qname, value) ->
let { attr_decl = { attr_typdef = st_def }; let value =
attr_use_cstr = constr } = try
try QTable.find tbl qname let a = QTable.find tbl qname in
with Not_found -> let value = validate_simple_type a.attr_decl.attr_typdef value in
error (sprintf "Unexpected attribute: %s" (match a.attr_use_cstr with (* check fixed constraint *)
(Ns.QName.to_string qname)) | 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 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 attribs := (qname, value) :: !attribs
) attrs.attrs; ) attrs.attrs;
if attrs.xsi_nil then if attrs.xsi_nil then
......
...@@ -1705,9 +1705,10 @@ module Schema_converter = ...@@ -1705,9 +1705,10 @@ module Schema_converter =
rexp regexp rexp regexp
(** @return a closed record *) (** @return a closed record *)
and attr_uses attr_uses = and attr_uses (attrs,other) =
(* TODO: produce directly internal types *) (* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *) (* (is it better ? we wouln't benefit from hash-consing) *)
print_endline ("Other = " ^ (if other then "true" else "false"));
let fields = let fields =
List.map List.map
(fun at -> (fun at ->
...@@ -1719,8 +1720,8 @@ module Schema_converter = ...@@ -1719,8 +1720,8 @@ module Schema_converter =
in in
let r = if at.attr_required then r else mk (IOptional r) in let r = if at.attr_required then r else mk (IOptional r) in
(LabelPool.mk at.attr_decl.attr_name, (r,None))) (LabelPool.mk at.attr_decl.attr_name, (r,None)))
attr_uses in attrs in
mk (IRecord (false, LabelMap.from_list_disj fields)) mk (IRecord (other, LabelMap.from_list_disj fields))
and att_decl att = and att_decl att =
let r = itype (simple_type att.attr_typdef) in let r = itype (simple_type att.attr_typdef) in
......
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