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

[r2004-10-19 13:44:18 by afrisch] Restructuring...

Original author: afrisch
Date: 2004-10-19 13:44:18+00:00
parent 74f6ff55
......@@ -9,7 +9,7 @@ open Schema_validator
open Schema_xml
open Schema_xml.Pxp_helpers
let debug = false
let debug = true
let debug_print ?(n: pxp_node option) s =
if debug then
(match n with
......@@ -56,7 +56,7 @@ module NodeSet = Set.Make (OrderedNode)
(* element and complex type constructors which take cares of unique id *)
let element, complex =
let counter = ref 0 in
let element name (type_def: type_definition) constr =
let element name type_def constr =
incr counter;
{ elt_uid = !counter;
elt_name = name;
......@@ -220,11 +220,13 @@ let parse_att_value_constraint stype_def n =
(* parse an element value constraint *)
let parse_elt_value_constraint type_def n =
debug_print ~n "Schema_parser.parse_elt_value_constraint";
let validate_value =
let validate_value v =
match type_def with
| Simple st_def | Complex { ct_content = CT_simple st_def } ->
validate_simple_type st_def
| _ -> validate_simple_type (Primitive (Utf8.mk "xsd:string"))
| Simple st_def
| Complex { ct_content = CT_simple st_def } ->
validate_simple_type st_def v
| _ ->
validate_simple_type (Primitive (Utf8.mk "xsd:string")) v
in
if _has_attribute "default" n then
let value = Value.string_utf8 (_attribute "default" n) in
......@@ -319,113 +321,115 @@ let parse_min_max n =
let find_particles =
_elements' ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence"]
let find_particle n =
try
Some (_element' ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"] n)
with Not_found -> None
let get_derivation (resolver : resolver) content =
let (derivation,derivation_type) =
if _has_element "xsd:restriction" content then
(_element "xsd:restriction" content, `Restriction)
else (* _has_element "xsd:extension" *)
(_element "xsd:extension" content, `Extension) in
let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
let uses = parse_attribute_uses resolver derivation_type !base derivation in
(derivation,derivation_type,!base,uses)
let rec parse_complex_type (resolver: resolver) n =
let find_particle n =
try
Some (_element' ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"] n)
with Not_found -> None
in
debug_print ~n "Schema_parser.parse_complex_type";
resolver#see n;
let name =
if _has_attribute "name" n then Some (_attribute "name" n) else None
in
if _has_element "xsd:simpleContent" n then
let content = _element "xsd:simpleContent" n in
let derivation, derivation_type =
if _has_element "xsd:restriction" content then
(_element "xsd:restriction" content, `Restriction)
else (* _has_element "xsd:extension" *)
(_element "xsd:extension" content, `Extension)
in
let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
let uses = parse_attribute_uses resolver derivation_type !base derivation in
let content_type =
match derivation_type with
| `Restriction ->
(match !base with
| Complex { ct_content = CT_simple base } ->
let base =
if _has_element "xsd:simpleType" derivation then
parse_simple_type resolver
(_element "xsd:simpleType" derivation)
else
base
in
let new_facets = merge_facets' base (parse_facets base n) in
let restricted_simple_type_def =
(match base with
| Primitive name ->
Derived (None, variety_of_simple_type_definition base,
new_facets, base)
| Derived (_, variety, _, _) ->
Derived (None, variety, new_facets, base))
in
CT_simple restricted_simple_type_def
| _ -> assert false)
| `Extension ->
(match !base with
| Complex { ct_content = CT_simple base } -> CT_simple base
| Simple simple_type_def -> CT_simple simple_type_def
| _ -> assert false)
in
complex name !base derivation_type uses content_type
else if _has_element "xsd:complexContent" n then
let content = _element "xsd:complexContent" n in
let derivation, derivation_type =
if _has_element "xsd:restriction" content then
(_element "xsd:restriction" content, `Restriction)
else (* _has_element "xsd:extension" *)
(_element "xsd:extension" content, `Extension)
in
let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
let uses = parse_attribute_uses resolver derivation_type !base derivation in
let mixed =
(_has_attribute "mixed" content &&
(_attribute "mixed" content = Utf8.mk "true"))
|| (_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true"))
in
let particle_node = find_particle derivation in
let content_type =
match derivation_type with
| `Restriction ->
(match particle_node with
| None -> CT_empty
| Some p_node ->
let particle = parse_particle resolver p_node in
CT_model (particle, mixed))
| `Extension ->
let base_ct = content_type_of_type !base in (* TODO BUG HERE if base =
AnyType *)
(match particle_node with
| None -> base_ct
| Some pnode ->
let particle = parse_particle resolver pnode in
(match base_ct with
| CT_empty -> CT_model (particle, mixed)
| CT_model (p, _) ->
let model = Sequence (p::[particle]) in
CT_model
((Intervals.V.one, Some (Intervals.V.one), Model model,
first_of_model_group model),
mixed)
| CT_simple _ -> assert false))
in
complex name !base derivation_type uses content_type
else (* neither simpleContent nor complexContent *)
let base = anyType in
let uses = parse_attribute_uses resolver `Restriction base n in
let mixed =
_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true")
in
let content_type =
match find_particle n with
let (base,derivation_type,uses,content_type) =
if _has_element "xsd:simpleContent" n
then parse_simple_content resolver n
else
if _has_element "xsd:complexContent" n
then parse_complex_content resolver n
else parse_other_content resolver n
in
complex name base derivation_type uses content_type
and parse_simple_content resolver n =
let content = _element "xsd:simpleContent" n in
let derivation,derivation_type,base,uses = get_derivation resolver content in
let content_type =
match derivation_type,base with
| `Restriction, Complex { ct_content = CT_simple base } ->
let base =
if _has_element "xsd:simpleType" derivation then
parse_simple_type resolver
(_element "xsd:simpleType" derivation)
else
base
in
let new_facets = merge_facets' base (parse_facets base n) in
let restricted_simple_type_def =
match base with
| Primitive name ->
Derived (None, variety_of_simple_type_definition base,
new_facets, base)
| Derived (_, variety, _, _) ->
Derived (None, variety, new_facets, base)
in
CT_simple restricted_simple_type_def
| `Extension, Complex { ct_content = CT_simple base } -> CT_simple base
| `Extension, Simple simple_type_def -> CT_simple simple_type_def
| _ -> assert false
in
base,derivation_type,uses,content_type
and parse_complex_content resolver n =
let content = _element "xsd:complexContent" n in
let derivation,derivation_type,base,uses = get_derivation resolver content in
let mixed =
(_has_attribute "mixed" content &&
(_attribute "mixed" content = Utf8.mk "true"))
|| (_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true"))
in
let particle_node = find_particle derivation in
let content_type =
match derivation_type, particle_node with
| `Restriction, None -> CT_empty
| `Restriction, Some p_node ->
let particle = parse_particle resolver p_node in
CT_model (particle, mixed)
| `Extension, None ->
content_type_of_type base
(* TODO BUG HERE if base =
AnyType *)
| `Extension, Some p_node ->
let base_ct = content_type_of_type base in
let particle = parse_particle resolver p_node in
match base_ct with
| CT_empty ->
CT_model (particle, mixed)
| CT_model (p, _) ->
let model = Sequence (p::[particle]) in
CT_model
((Intervals.V.one, Some (Intervals.V.one), Model model,
first_of_model_group model),
mixed)
| CT_simple _ -> assert false
in
base,derivation_type,uses,content_type
and parse_other_content resolver n =
let uses = parse_attribute_uses resolver `Restriction AnyType n in
let mixed =
_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true")
in
let content_type =
match find_particle n with
| None -> CT_empty
| Some pnode ->
let particle = parse_particle resolver pnode in
CT_model (particle, mixed)
in
complex name anyType `Restriction uses content_type
in
AnyType,`Restriction,uses,content_type
and parse_elt_decl (resolver: resolver) n: element_declaration =
debug_print ~n "Schema_parser.parse_elt_decl";
......@@ -447,7 +451,7 @@ and find_element_type (resolver: resolver) n =
else if _has_attribute "type" n then
!(resolver#resolve_typ ~now:true (_attribute "type" n))
else
anyType
AnyType
and parse_particle (resolver: resolver) n =
debug_print ~n "Schema_parser.parse_particle";
......
......@@ -64,8 +64,8 @@ type attribute_use =
attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
type first = Utf8.t option list
type term =
......@@ -93,7 +93,7 @@ and particle =
and element_declaration =
{ elt_uid: int;
elt_name: Utf8.t;
mutable elt_typdef: type_definition;
elt_typdef: type_definition;
elt_cstr: value_constraint option }
and complex_type_definition =
......
......@@ -64,8 +64,8 @@ type attribute_use =
attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
type first = Utf8.t option list
type term =
......@@ -93,7 +93,7 @@ and particle =
and element_declaration =
{ elt_uid: int;
elt_name: Utf8.t;
mutable elt_typdef: type_definition;
elt_typdef: type_definition;
elt_cstr: value_constraint option }
and complex_type_definition =
......
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