Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
76416684
Commit
76416684
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-02-17 17:01:05 by afrisch] Handle recursion in schema
Original author: afrisch Date: 2005-02-17 17:01:05+00:00
parent
7adc4fb0
Changes
8
Hide whitespace changes
Inline
Side-by-side
schema/schema_builtin.ml
View file @
76416684
...
...
@@ -422,10 +422,11 @@ let restrict' name basename new_facets =
let
facets
=
merge_facets
(
facets_of_simple_type_definition
base
)
new_facets
in
Derived
(
Some
name
,
variety
,
facets
,
base
)
Derived
(
Some
name
,
variety
,
facets
,
ref
(
Simple
base
)
)
let
list'
name
itemname
=
let
(
name
,
itemname
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
itemname
)
in
let
(
base
,
_
,
_
)
=
Hashtbl
.
find
builtins
itemname
in
let
base
=
ref
(
Simple
base
)
in
Derived
(
Some
name
,
List
base
,
no_facets
,
base
)
let
fill
()
=
(* fill "builtins" hashtbl *)
...
...
@@ -480,43 +481,43 @@ let fill () = (* fill "builtins" hashtbl *)
Builtin_defs
.
int
,
validate_integer
);
reg
"nonPositiveInteger"
(
restrict'
"nonPositiveInteger"
"integer"
{
no_facets
with
maxInclusive
=
Some
(
Value
.
Integer
zero
,
false
)
}
,
{
no_facets
with
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
zero
)
,
false
)
}
,
nonPositiveInteger_type
,
validate_nonPositiveInteger
);
reg
"negativeInteger"
(
restrict'
"negativeInteger"
"nonPositiveInteger"
{
no_facets
with
maxInclusive
=
Some
(
Value
.
Integer
minus_one
,
false
)
}
,
{
no_facets
with
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
minus_one
)
,
false
)
}
,
negativeInteger_type
,
validate_negativeInteger
);
reg
"nonNegativeInteger"
(
restrict'
"nonNegativeInteger"
"integer"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
zero
,
false
)
}
,
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
zero
)
,
false
)
}
,
nonNegativeInteger_type
,
validate_nonNegativeInteger
);
reg
"positiveInteger"
(
restrict'
"positiveInteger"
"nonNegativeInteger"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
one
,
false
)
}
,
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
one
)
,
false
)
}
,
positiveInteger_type
,
validate_positiveInteger
);
reg
"long"
(
restrict'
"long"
"integer"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
long_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
long_r
,
false
)}
,
minInclusive
=
Some
(
lazy
(
Value
.
Integer
long_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
long_r
)
,
false
)}
,
long_type
,
validate_long
);
reg
"int"
(
restrict'
"int"
"long"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
int_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
int_r
,
false
)}
,
minInclusive
=
Some
(
lazy
(
Value
.
Integer
int_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
int_r
)
,
false
)}
,
int_type
,
validate_int
);
reg
"short"
(
restrict'
"short"
"int"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
short_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
short_r
,
false
)}
,
minInclusive
=
Some
(
lazy
(
Value
.
Integer
short_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
short_r
)
,
false
)}
,
short_type
,
validate_short
);
reg
"byte"
(
restrict'
"byte"
"short"
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
byte_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
byte_r
,
false
)}
,
minInclusive
=
Some
(
lazy
(
Value
.
Integer
byte_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
byte_r
)
,
false
)}
,
byte_type
,
validate_short
);
reg
"normalizedString"
(
restrict'
"normalizedString"
"string"
...
...
schema/schema_common.ml
View file @
76416684
open
Printf
open
Encodings
...
...
@@ -22,6 +21,69 @@ let no_facets = {
*)
}
(** naive implementation: doesn't follow XML Schema constraints on facets
* merging. Here all new facets override old ones *)
let
merge_facets
old_facets
new_facets
=
let
maxInclusive
,
maxExclusive
=
match
new_facets
.
maxInclusive
,
new_facets
.
maxExclusive
with
|
None
,
None
->
old_facets
.
maxInclusive
,
old_facets
.
maxExclusive
|
Some
_
,
Some
_
->
assert
false
|
v
->
v
in
let
minInclusive
,
minExclusive
=
match
new_facets
.
minInclusive
,
new_facets
.
minExclusive
with
|
None
,
None
->
old_facets
.
minInclusive
,
old_facets
.
minExclusive
|
Some
_
,
Some
_
->
assert
false
|
v
->
v
in
{
old_facets
with
length
=
(
match
new_facets
.
length
with
|
None
->
old_facets
.
length
|
v
->
v
);
minLength
=
(
match
new_facets
.
minLength
with
|
None
->
old_facets
.
minLength
|
v
->
v
);
maxLength
=
(
match
new_facets
.
maxLength
with
|
None
->
old_facets
.
maxLength
|
v
->
v
);
enumeration
=
(
match
new_facets
.
enumeration
with
|
None
->
old_facets
.
enumeration
|
v
->
v
);
whiteSpace
=
new_facets
.
whiteSpace
;
maxInclusive
=
maxInclusive
;
maxExclusive
=
maxExclusive
;
minInclusive
=
minInclusive
;
minExclusive
=
minExclusive
;
}
let
rec
facets_of_simple_type_definition
=
function
|
Primitive
_
->
no_facets
|
Derived
(
_
,
_
,
facets
,
_
)
->
facets
let
rec
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
ref
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
get_simple_type
=
function
|
{
contents
=
Simple
c
}
->
c
|
{
contents
=
AnyType
}
->
Primitive
(
Utf8
.
mk
"xsd:anySimpleType"
)
|
_
->
assert
false
let
rec
normalize_simple_type
=
function
|
Derived
(
name
,
Restrict
,
new_facets
,
base
)
->
(
match
normalize_simple_type
(
get_simple_type
base
)
with
|
Derived
(
_
,
variety
,
old_facets
,
base
)
->
Derived
(
name
,
variety
,
merge_facets
old_facets
new_facets
,
base
)
|
Primitive
_
as
st
->
let
b
=
ref
(
Simple
st
)
in
Derived
(
name
,
Atomic
b
,
new_facets
,
b
))
|
_
->
assert
false
let
name_of_element_declaration
elt
=
elt
.
elt_name
let
name_of_simple_type_definition
=
function
|
Primitive
name
->
name
...
...
@@ -42,7 +104,7 @@ let name_of_particle = function
|
(
_
,
_
,
Elt
elt_decl_ref
,
_
)
->
name_of_element_declaration
!
elt_decl_ref
|
_
->
assert
false
let
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
st
|
(
Primitive
name
)
as
st
->
Atomic
(
ref
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
simple_type_of_type
=
function
|
Simple
s
->
s
...
...
@@ -53,10 +115,7 @@ let complex_type_of_type = function
let
content_type_of_type
=
function
|
AnyType
->
assert
false
|
Complex
{
ct_content
=
ct
}
->
ct
|
Simple
st
->
CT_simple
st
let
facets_of_simple_type_definition
=
function
|
Primitive
_
->
no_facets
|
Derived
(
_
,
_
,
facets
,
_
)
->
facets
|
Simple
st
->
CT_simple
(
ref
(
Simple
st
))
let
iter_types
schema
f
=
List
.
iter
f
schema
.
types
let
iter_attributes
schema
f
=
List
.
iter
f
schema
.
attributes
...
...
@@ -109,17 +168,18 @@ let get_interval facets =
* Value.t is an integer! (no other intervals are actually supported
* by the CDuce type system)
*)
let
getint
f
=
Value
.
get_integer
(
Lazy
.
force
f
)
in
let
min
=
match
facets
.
minInclusive
,
facets
.
minExclusive
with
|
Some
(
Value
.
Integer
i
,
_
)
,
None
->
Some
i
|
None
,
Some
(
Value
.
Integer
i
,
_
)
->
Some
(
Intervals
.
V
.
succ
i
)
|
Some
(
i
,
_
)
,
None
->
Some
(
getint
i
)
|
None
,
Some
(
i
,
_
)
->
Some
(
Intervals
.
V
.
succ
(
getint
i
)
)
|
None
,
None
->
None
|
_
->
assert
false
in
let
max
=
match
facets
.
maxInclusive
,
facets
.
maxExclusive
with
|
Some
(
Value
.
Integer
i
,
_
)
,
None
->
Some
i
|
None
,
Some
(
Value
.
Integer
i
,
_
)
->
Some
(
Intervals
.
V
.
pred
i
)
|
Some
(
i
,
_
)
,
None
->
Some
(
getint
i
)
|
None
,
Some
(
i
,
_
)
->
Some
(
Intervals
.
V
.
pred
(
getint
i
)
)
|
None
,
None
->
None
|
_
->
assert
false
in
...
...
@@ -129,6 +189,7 @@ let get_interval facets =
|
None
,
Some
max
->
Intervals
.
left
max
|
None
,
None
->
Intervals
.
any
let
print_simple_type
fmt
=
function
|
Primitive
name
->
Format
.
fprintf
fmt
"%a"
Encodings
.
Utf8
.
dump
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
...
...
@@ -144,7 +205,8 @@ let print_type fmt = function
|
Simple
t
->
Format
.
fprintf
fmt
"S:%a"
print_simple_type
t
|
Complex
t
->
Format
.
fprintf
fmt
"C:%a"
print_complex_type
t
let
print_attribute
fmt
{
attr_name
=
name
;
attr_typdef
=
t
}
=
Format
.
fprintf
fmt
"@@%a:%a"
Utf8
.
dump
name
print_simple_type
t
Format
.
fprintf
fmt
"@@%a:%a"
Utf8
.
dump
name
print_simple_type
(
get_simple_type
t
)
let
print_element
fmt
{
elt_uid
=
id
;
elt_name
=
name
}
=
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Utf8
.
dump
name
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
...
...
@@ -189,51 +251,6 @@ let print_schema fmt schema =
Format
.
fprintf
fmt
"
\n
"
end
(** naive implementation: doesn't follow XML Schema constraints on facets
* merging. Here all new facets override old ones *)
let
merge_facets
old_facets
new_facets
=
let
maxInclusive
,
maxExclusive
=
match
new_facets
.
maxInclusive
,
new_facets
.
maxExclusive
with
|
None
,
None
->
old_facets
.
maxInclusive
,
old_facets
.
maxExclusive
|
Some
_
,
Some
_
->
assert
false
|
v
->
v
in
let
minInclusive
,
minExclusive
=
match
new_facets
.
minInclusive
,
new_facets
.
minExclusive
with
|
None
,
None
->
old_facets
.
minInclusive
,
old_facets
.
minExclusive
|
Some
_
,
Some
_
->
assert
false
|
v
->
v
in
{
old_facets
with
length
=
(
match
new_facets
.
length
with
|
None
->
old_facets
.
length
|
v
->
v
);
minLength
=
(
match
new_facets
.
minLength
with
|
None
->
old_facets
.
minLength
|
v
->
v
);
maxLength
=
(
match
new_facets
.
maxLength
with
|
None
->
old_facets
.
maxLength
|
v
->
v
);
enumeration
=
(
match
new_facets
.
enumeration
with
|
None
->
old_facets
.
enumeration
|
v
->
v
);
whiteSpace
=
new_facets
.
whiteSpace
;
maxInclusive
=
maxInclusive
;
maxExclusive
=
maxExclusive
;
minInclusive
=
minInclusive
;
minExclusive
=
minExclusive
;
}
let
restrict
base
new_facets
new_name
=
let
variety
=
variety_of_simple_type_definition
base
in
let
facets
=
merge_facets
(
facets_of_simple_type_definition
base
)
new_facets
in
Derived
(
new_name
,
variety
,
facets
,
base
)
let
get_type
name
schema
=
List
.
find
...
...
schema/schema_common.mli
View file @
76416684
...
...
@@ -23,6 +23,8 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
val
get_simple_type
:
type_ref
->
simple_type_definition
val
name_of_element_declaration
:
element_declaration
->
Utf8
.
t
val
name_of_type_definition
:
type_definition
->
Utf8
.
t
val
name_of_simple_type_definition
:
simple_type_definition
->
Utf8
.
t
...
...
@@ -65,10 +67,8 @@ val nullable: particle -> bool
val
merge_facets
:
facets
->
facets
->
facets
(** restrict base new_facets new_name
* Implements simple type derivition by restriction *)
val
restrict
:
simple_type_definition
->
facets
->
Utf8
.
t
option
->
simple_type_definition
val
normalize_simple_type
:
simple_type_definition
->
simple_type_definition
(** {2 Miscellaneous} *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
...
...
schema/schema_parser.ml
View file @
76416684
...
...
@@ -9,8 +9,6 @@ open Schema_xml
let
validation_error
s
=
raise
(
XSD_validation_error
s
)
module
NodeSet
=
Set
.
Make
(
Schema_xml
.
Node
)
let
fake_type_def
=
Complex
{
ct_uid
=
-
1
;
...
...
@@ -22,7 +20,7 @@ let fake_type_def =
let
fake_elt_decl
=
{
elt_uid
=
-
2
;
elt_name
=
Utf8
.
mk
" FAKE ELT "
;
elt_typdef
=
fake_type_def
;
elt_typdef
=
ref
fake_type_def
;
elt_cstr
=
None
}
let
is_fake_type_def
=
(
==
)
fake_type_def
let
is_fake_elt_decl
=
(
==
)
fake_elt_decl
...
...
@@ -58,7 +56,8 @@ let hashtbl_deref tbl = Hashtbl.fold (fun _ v acc -> !v :: acc) tbl []
let
hashtbl_values
tbl
=
Hashtbl
.
fold
(
fun
_
v
acc
->
v
::
acc
)
tbl
[]
let
parse_facets
base
n
=
let
validate_base_type
=
Schema_validator
.
validate_simple_type
base
in
let
validate_base_type
v
=
lazy
(
Schema_validator
.
validate_simple_type
(
get_simple_type
base
)
v
)
in
let
validate_nonNegativeInteger
=
Schema_builtin
.
validate_builtin
(
Utf8
.
mk
"xsd:nonNegativeInteger"
)
in
...
...
@@ -81,9 +80,9 @@ let parse_facets base n =
let
value
=
Value
.
string_utf8
(
_attr
"value"
n
)
in
let
value
=
validate_base_type
value
in
let
new_enumeration
=
(
match
facets
.
enumeration
with
|
None
->
Some
(
Value
.
ValueSet
.
singleton
value
)
|
Some
entries
->
Some
(
Value
.
ValueSet
.
add
value
entries
)
)
match
facets
.
enumeration
with
|
None
->
Some
[
value
]
|
Some
entries
->
Some
(
value
::
entries
)
in
{
facets
with
enumeration
=
new_enumeration
}
|
"xsd:whiteSpace"
->
...
...
@@ -123,7 +122,8 @@ let default_fixed n f =
|
None
->
None
let
parse_att_value_constraint
stype_def
n
=
default_fixed
n
(
validate_simple_type
stype_def
)
default_fixed
n
(
fun
v
->
lazy
(
validate_simple_type
(
get_simple_type
stype_def
)
v
))
let
parse_min_max
n
=
(
match
_may_attr
"minOccurs"
n
with
...
...
@@ -199,106 +199,24 @@ let schema_of_node root =
validation_error
(
"Can't resolve: "
^
Utf8
.
get_str
s
))
in
let
seen_nodes
=
ref
NodeSet
.
empty
in
let
already_seen
n
=
NodeSet
.
mem
n
!
seen_nodes
in
let
see
n
=
if
already_seen
n
then
validation_error
(
sprintf
"Types/Elements loop (line: %d)"
(
_line
n
))
else
seen_nodes
:=
NodeSet
.
add
n
!
seen_nodes
in
let
find_global_component
tag_pred
name
=
let
basename
=
Utf8
.
get_str
(
snd
(
Ns
.
split_qname
name
))
in
_find
(
fun
n
->
(
_has_tag
n
tag_pred
)
&&
(
_is_attr
"name"
n
basename
))
root
in
let
rec
register_typ
name
def
=
let
name
=
qualify
name
in
if
(
Hashtbl
.
mem
typs
name
)
&&
(
not
(
is_fake_type_def
!
(
Hashtbl
.
find
typs
name
)))
then
validation_error
(
"Redefinition of type: "
^
Utf8
.
get_str
name
);
let
type_def_ref
=
resolve_typ
~
fix_ns
:
false
~
now
:
false
name
in
type_def_ref
:=
def
and
register_elt
name
decl
=
let
name
=
qualify
name
in
if
(
Hashtbl
.
mem
elts
name
)
&&
(
not
(
is_fake_elt_decl
!
(
Hashtbl
.
find
elts
name
)))
then
validation_error
(
"Redefinition of element: "
^
Utf8
.
get_str
name
);
let
elt_decl_ref
=
resolve_elt
~
fix_ns
:
false
~
now
:
false
name
in
elt_decl_ref
:=
decl
and
register_att
name
decl
=
let
name
=
qualify
name
in
if
Hashtbl
.
mem
attrs
name
then
validation_error
(
"Redefinition of attribute: "
^
Utf8
.
get_str
name
);
Hashtbl
.
replace
attrs
name
decl
and
register_att_group
name
def
=
let
name
=
qualify
name
in
if
Hashtbl
.
mem
attr_groups
name
then
validation_error
(
"Redefinition of attribute group: "
^
Utf8
.
get_str
name
);
Hashtbl
.
replace
attr_groups
name
def
and
register_model_group
name
def
=
let
name
=
qualify
name
in
if
Hashtbl
.
mem
model_groups
name
then
validation_error
(
"Redefinition of model group: "
^
Utf8
.
get_str
name
);
Hashtbl
.
replace
model_groups
name
def
and
resolve_typ
?
(
fix_ns
=
true
)
~
now
name
=
let
name
=
if
fix_ns
then
fix_namespace
name
else
name
in
try
Hashtbl
.
find
typs
name
with
Not_found
->
let
type_def
=
if
now
then
(* resolve now: look for global type definitions *)
let
type_node
=
try
find_global_component
(
fun
tag
->
(
tag
=
"xsd:simpleType"
)
||
(
tag
=
"xsd:complexType"
))
name
with
Not_found
->
validation_error
(
"Can't find definition of type: "
^
Utf8
.
get_str
name
)
in
if
_tag
type_node
=
"xsd:simpleType"
then
Simple
(
parse_simple_type
type_node
)
else
(* _tag_name type_node = "xsd:complexType" *)
Complex
(
parse_complex_type
type_node
)
else
(* resolve later: return a fake type ref *)
fake_type_def
in
let
type_def_ref
=
ref
type_def
in
Hashtbl
.
replace
typs
name
type_def_ref
;
type_def_ref
and
resolve_simple_typ
?
(
fix_ns
=
true
)
name
=
match
!
(
resolve_typ
~
fix_ns
~
now
:
true
name
)
with
|
AnyType
->
Primitive
(
Utf8
.
mk
"xsd:anySimpleType"
)
|
Simple
st
->
st
|
Complex
_
->
assert
false
and
resolve_elt
?
(
fix_ns
=
true
)
~
now
name
=
let
name
=
if
fix_ns
then
fix_namespace
name
else
name
in
try
Hashtbl
.
find
elts
name
with
Not_found
->
let
elt_decl
=
if
now
then
(* resolve now: look for global element declarations *)
let
elt_node
=
try
find_global_component
((
=
)
"xsd:element"
)
name
with
Not_found
->
validation_error
(
"Can't find declaration of element: "
^
Utf8
.
get_str
name
)
in
parse_elt_decl
elt_node
else
(* resolve later: return a fake element declaration *)
fake_elt_decl
in
let
elt_decl_ref
=
ref
elt_decl
in
Hashtbl
.
replace
elts
name
elt_decl_ref
;
elt_decl_ref
let
rec
resolve_typ
name
=
try
Hashtbl
.
find
typs
(
fix_namespace
name
)
with
Not_found
->
assert
false
and
resolve_simple_typ
name
=
resolve_typ
name
and
resolve_elt
name
=
try
Hashtbl
.
find
elts
(
fix_namespace
name
)
with
Not_found
->
assert
false
and
resolve_att
?
(
fix_ns
=
true
)
name
=
let
name
=
if
fix_ns
then
fix_namespace
name
else
name
in
and
resolve_att
name
=
let
name
=
fix_namespace
name
in
try
Hashtbl
.
find
attrs
name
with
Not_found
->
let
node
=
...
...
@@ -311,8 +229,8 @@ let schema_of_node root =
Hashtbl
.
replace
attrs
name
att_decl
;
att_decl
and
resolve_att_group
?
(
fix_ns
=
true
)
name
=
let
name
=
if
fix_ns
then
fix_namespace
name
else
name
in
and
resolve_att_group
name
=
let
name
=
fix_namespace
name
in
try
Hashtbl
.
find
attr_groups
name
with
Not_found
->
let
node
=
...
...
@@ -325,8 +243,8 @@ let schema_of_node root =
Hashtbl
.
replace
attr_groups
name
att_group_decl
;
att_group_decl
and
resolve_model_group
?
(
fix_ns
=
true
)
name
=
let
name
=
if
fix_ns
then
fix_namespace
name
else
name
in
and
resolve_model_group
name
=
let
name
=
fix_namespace
name
in
try
Hashtbl
.
find
model_groups
name
with
Not_found
->
let
node
=
...
...
@@ -341,29 +259,28 @@ let schema_of_node root =
(* parse an xsd:simpleType element *)
and
parse_simple_type
n
=
see
n
;
let
name
=
_may_attr
"name"
n
in
match
_may_elem
"xsd:restriction"
n
with
|
Some
restriction
->
let
base
=
find_base_simple_type
restriction
in
let
facets
=
parse_facets
base
restriction
in
restrict
base
facets
name
re
f
(
Simple
(
Derived
(
name
,
Re
strict
,
facets
,
base
)))
|
None
->
match
_may_elem
"xsd:list"
n
with
|
Some
list
->
let
items
=
find_item_type
list
in
Derived
(
name
,
List
items
,
no_facets
,
anySimpleType
)
ref
(
Simple
(
Derived
(
name
,
List
items
,
no_facets
,
ref
(
Simple
anySimpleType
)
)))
|
None
->
match
_may_elem
"xsd:union"
n
with
|
Some
union
->
let
members
=
find_member_types
union
in
Derived
(
name
,
Union
members
,
no_facets
,
anySimpleType
)
ref
(
Simple
(
Derived
(
name
,
Union
members
,
no_facets
,
ref
(
Simple
anySimpleType
)
)))
|
None
->
assert
false
(* look for a simple type def: try attribute "base", try "simpleType" child,
* fail *)
and
find_base_simple_type
n
=
and
find_base_simple_type
n
:
Schema_types
.
type_ref
=
match
_may_attr
"base"
n
with
|
Some
v
->
resolve_simple_typ
v
|
None
->
...
...
@@ -398,13 +315,15 @@ let schema_of_node root =
|
members
->
members
and
parse_elt_value_constraint
type_def
n
=
let
validate_value
v
=
match
type_def
with
|
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
and
parse_elt_value_constraint
(
type_def
:
type_ref
)
n
=
let
validate_value
v
=
lazy
(
match
(
!
type_def
:
type_definition
)
with
|
Simple
st_def
|
Complex
{
ct_content
=
CT_simple
{
contents
=
Simple
st_def
}
}
->
validate_simple_type
st_def
v
|
_
->
validate_simple_type
(
Primitive
(
Utf8
.
mk
"xsd:string"
))
v
)
in
default_fixed
n
validate_value
...
...
@@ -416,10 +335,9 @@ let schema_of_node root =
|
None
->
match
_may_attr
"type"
n
with
|
Some
v
->
resolve_simple_typ
v
|
None
->
anySimpleType
|
None
->
ref
(
Simple
anySimpleType
)
and
parse_att_decl
n
=
see
n
;
let
typdef
=
find_simple_type
n
in
{
attr_name
=
_attr
"name"
n
;
attr_typdef
=
typdef
;
...
...
@@ -483,12 +401,11 @@ let schema_of_node root =
match
_may_elem
"xsd:extension"
content
with
|
Some
v
->
(
v
,
`Extension
)
|
None
->
assert
false
in
let
base
=
resolve_typ
~
now
:
true
(
_attr
"base"
derivation
)
in
let
base
=
resolve_typ
(
_attr
"base"
derivation
)
in
let
uses
=
parse_attribute_uses
derivation_type
!
base
derivation
in
(
derivation
,
derivation_type
,!
base
,
uses
)
and
parse_complex_type
n
=
see
n
;
and
parse_complex_type
n
:
type_ref
=
let
name
=
_may_attr
"name"
n
in
let
(
base
,
derivation_type
,
uses
,
content_type
)
=
match
_may_elem
"xsd:simpleContent"
n
with
...
...
@@ -498,7 +415,7 @@ let schema_of_node root =
|
Some
c
->
parse_complex_content
n
c
|
None
->
parse_other_content
n
in
complex
name
base
derivation_type
uses
content_type
ref
(
Complex
(
complex
name
base
derivation_type
uses
content_type
))
and
parse_simple_content
n
content
=
let
derivation
,
derivation_type
,
base
,
uses
=
get_derivation
content
in
...
...
@@ -509,18 +426,10 @@ let schema_of_node root =
match
_may_elem
"xsd:simpleType"
derivation
with
|
Some
s
->
parse_simple_type
s
|
None
->
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
CT_simple
(
ref
(
Simple
(
Derived
(
None
,
Restrict
,
parse_facets
base
n
,
base
))))
|
`Extension
,
Complex
{
ct_content
=
CT_simple
base
}
->
CT_simple
base
|
`Extension
,
(
Simple
_
as
st
)
->
CT_simple
(
ref
st
)
|
_
->
assert
false
in
base
,
derivation_type
,
uses
,
content_type
...
...
@@ -569,7 +478,6 @@ let schema_of_node root =
and
parse_elt_decl
n
:
element_declaration
=
see
n
;
match
_may_attr
"name"
n
with
|
None
->
validation_error
"missing element name"
|
Some
name
->
...
...
@@ -581,14 +489,14 @@ let schema_of_node root =
* child, try "type" attribute, return anyType *)
and
find_element_type
n
=
match
_may_elem
"xsd:simpleType"
n
with
|
Some
n
->
Simple
(
parse_simple_type
n
)
|
Some
n
->
parse_simple_type
n
|
None
->
match
_may_elem
"xsd:complexType"
n
with
|
Some
n
->
Complex
(
parse_complex_type
n
)
|
Some
n
->
parse_complex_type
n
|
None
->
match
_may_attr
"type"
n
with
|
Some
v
->
!
(
resolve_typ
~
now
:
true
v
)
|
None
->
AnyType
|
Some
v
->
resolve_typ
v
|
None
->
ref
AnyType