Commit c56184ef authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2005-02-25 14:13:45+00:00
parent 4ad83cba
- 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")
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
......@@ -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
......@@ -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
......
......@@ -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;
......
......@@ -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;
......
......@@ -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
......
......@@ -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
......
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