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
a0171f82
Commit
a0171f82
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-04 13:36:39 by afrisch] Clean
Original author: afrisch Date: 2005-03-04 13:39:08+00:00
parent
d5664653
Changes
8
Hide whitespace changes
Inline
Side-by-side
CHANGES
View file @
a0171f82
Since 0.2.2
- Warning for capture variables and projections that always return the empty
sequence.
- Bug fixes when printing location in source code.
- Major rewrite of the support for XML Schema
* removed print_schema directive
* removed the "kind" selector (e.g. S # t as element)
* include,import implemented
*
- removed the syntax "external {...}", replaced with
"unit.val with { ty1 ty2 ... }"
- removed the syntax H:val, replaced with H.val
- removed the syntax S#t, replaced with S.t
- overloaded the dot (record field acces, CDuce, OCaml, Schema units)
- identifiers (for types, values) are now qualified names
- A new tool cduce_mktop produce CDuce toplevels with embeded OCaml functions
- several bug fixes
- validate renamed to cduce_validate
- more efficient hash-consing of types
- better error message with script on stdin
- a dot in an identifier must be escaped with a backslash, e.g. x\.y
- improved #print_type (does not use the abbreviation for the printed type)
- float_of: String -> Float
- Language:
* Warning for capture variables and projections that always return the empty
sequence.
* Major rewrite of the support for XML Schema
* removed print_schema directive
* removed the "kind" selector (e.g. S # t as element)
* include,import implemented
* support wildcards any,anyAttrivbute
* support xsi:nil
* support xsd:decimal,xsd:float
* many bug fixes
* Removed the syntax "external {...}", replaced with
"unit.val with { ty1 ty2 ... }".
* Removed the syntax H:val, replaced with H.val.
* Removed the syntax S#t, replaced with S.t.
* Overloaded the dot (record field acces, CDuce, OCaml, Schema units).
A dot in an identifier must now be escaped with a backslash, e.g. x\.y
* Identifiers (for types, values) are now qualified names.
* float_of: String -> Float
- Tools:
* A new tool cduce_mktop produce customized CDuce toplevels with embedded
OCaml externals.
* validate renamed to cduce_validate
- Implementation:
* Various bug fixes
* More efficient hash-consing of types
* improved #print_type (does not use the abbreviation for the printed type)
0.2.2
...
...
schema/schema_common.ml
View file @
a0171f82
...
...
@@ -10,17 +10,12 @@ let no_facets = {
length
=
None
;
minLength
=
None
;
maxLength
=
None
;
(* pattern = []; *)
enumeration
=
None
;
whiteSpace
=
`Collapse
,
true
;
maxInclusive
=
None
;
maxExclusive
=
None
;
minInclusive
=
None
;
minExclusive
=
None
;
(*
totalDigits = None;
fractionDigits = None;
*)
}
(** naive implementation: doesn't follow XML Schema constraints on facets
...
...
@@ -62,31 +57,6 @@ let merge_facets old_facets new_facets =
minExclusive
=
minExclusive
;
}
let
rec
facets_of_simple_type_definition
st
=
st
.
st_facets
let
rec
variety_of_simple_type_definition
st
=
st
.
st_variety
(*
let get_simple_type c = match Lazy.force c with
| Simple c -> c
| AnyType -> Primitive (xsd,Utf8.mk "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 = lazy (Simple st) in
Derived (name,Atomic b,new_facets,b))
| st -> st
*)
let
name_of_element_declaration
elt
=
elt
.
elt_name
let
name_of_simple_type_definition
=
function
|
{
st_name
=
Some
name
}
->
name
|
_
->
raise
(
Invalid_argument
"anonymous simple type definition"
)
...
...
@@ -97,13 +67,7 @@ let name_of_type_definition = function
|
AnyType
->
(
xsd
,
Utf8
.
mk
"anyType"
)
|
Simple
st
->
name_of_simple_type_definition
st
|
Complex
ct
->
name_of_complex_type_definition
ct
let
name_of_attribute_declaration
a
=
a
.
attr_name
let
name_of_attribute_use
{
attr_decl
=
{
attr_name
=
name
}
}
=
name
let
name_of_attribute_group_definition
ag
=
ag
.
ag_name
let
name_of_model_group_definition
mg
=
mg
.
mg_name
let
name_of_particle
=
function
|
{
part_term
=
Elt
e
}
->
name_of_element_declaration
e
|
_
->
assert
false
let
simple_type_of_type
=
function
|
Simple
s
->
s
|
_
->
raise
(
Invalid_argument
"simple_type_of_type"
)
...
...
@@ -115,12 +79,6 @@ let content_type_of_type = function
|
Complex
{
ct_content
=
ct
}
->
ct
|
Simple
st
->
CT_simple
st
let
iter_types
schema
f
=
List
.
iter
f
schema
.
types
let
iter_attributes
schema
f
=
List
.
iter
f
schema
.
attributes
let
iter_elements
schema
f
=
List
.
iter
f
schema
.
elements
let
iter_attribute_groups
schema
f
=
List
.
iter
f
schema
.
attribute_groups
let
iter_model_groups
schema
f
=
List
.
iter
f
schema
.
model_groups
exception
XSD_validation_error
of
string
exception
XSI_validation_error
of
string
...
...
@@ -139,13 +97,6 @@ let rec normalize_white_space =
in
pcre_replace
~
rex
:
margins_RE
~
templ
:
(
Utf8
.
mk
"$1"
)
s'
(*
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
*)
let
anyType
=
AnyType
let
first_of_particle
p
=
p
.
part_first
let
nullable
p
=
p
.
part_nullable
let
first_of_wildcard_constraint
=
function
|
WAny
->
Atoms
.
any
...
...
@@ -155,156 +106,20 @@ let first_of_wildcard_constraint = function
Atoms
.
empty
l
let
first_of_model_group
=
function
|
All
particles
|
Choice
particles
->
List
.
fold_left
(
fun
acc
p
->
Atoms
.
cup
acc
(
first_of_particle
p
)
)
List
.
fold_left
(
fun
acc
p
->
Atoms
.
cup
acc
p
.
part_first
)
Atoms
.
empty
particles
|
Sequence
particles
->
let
rec
aux
=
function
|
hd
::
tl
when
nullable
hd
->
Atoms
.
cup
(
first_of_particle
hd
)
(
aux
tl
)
|
hd
::
tl
->
first_of_particle
hd
|
hd
::
tl
when
hd
.
part_
nullable
->
Atoms
.
cup
hd
.
part_first
(
aux
tl
)
|
hd
::
tl
->
hd
.
part_first
|
[]
->
Atoms
.
empty
in
aux
particles
let
nullable_of_model_group
=
function
|
All
particles
|
Sequence
particles
->
List
.
for_all
nullable
particles
|
Choice
particles
->
List
.
exists
nullable
particles
let
get_interval
facets
=
(* ASSUMPTION:
* not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
* not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
* Value.t is an integer! (no other intervals are actually supported
* by the CDuce type system)
*)
let
getint
f
=
Value
.
get_integer
f
in
let
min
=
match
facets
.
minInclusive
,
facets
.
minExclusive
with
|
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
(
i
,
_
)
,
None
->
Some
(
getint
i
)
|
None
,
Some
(
i
,
_
)
->
Some
(
Intervals
.
V
.
pred
(
getint
i
))
|
None
,
None
->
None
|
_
->
assert
false
in
match
min
,
max
with
|
Some
min
,
Some
max
->
Intervals
.
bounded
min
max
|
Some
min
,
None
->
Intervals
.
right
min
|
None
,
Some
max
->
Intervals
.
left
max
|
None
,
None
->
Intervals
.
any
let
print_simple_type
fmt
=
function
|
{
st_name
=
Some
name
}
->
Format
.
fprintf
fmt
"%a"
Ns
.
QName
.
print
name
|
_
->
Format
.
fprintf
fmt
"unnamed"
let
print_complex_type
fmt
=
function
|
{
ct_uid
=
id
;
ct_name
=
Some
name
}
->
Format
.
fprintf
fmt
"%d:%a"
id
Ns
.
QName
.
print
name
|
{
ct_uid
=
id
}
->
Format
.
fprintf
fmt
"%d:unnamed'"
id
let
print_type
fmt
=
function
|
AnyType
->
Format
.
fprintf
fmt
"xsd:anyType"
|
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"
Ns
.
QName
.
print
name
print_simple_type
t
let
print_element
fmt
{
elt_uid
=
id
;
elt_name
=
name
}
=
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Ns
.
QName
.
print
name
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
let
print_attribute_group
fmt
ag
=
Format
.
fprintf
fmt
"{agroup:%a}"
Ns
.
QName
.
print
ag
.
ag_name
let
print_model_group_def
fmt
mg
=
Format
.
fprintf
fmt
"{mgroup:%a}"
Ns
.
QName
.
print
mg
.
mg_name
let
print_schema
fmt
schema
=
let
defined_types
=
(* filter out built-in types *)
List
.
filter
(
fun
t
->
let
(
ns
,_
)
=
name_of_type_definition
t
in
not
(
Ns
.
equal
ns
xsd
))
schema
.
types
in
if
defined_types
<>
[]
then
begin
Format
.
fprintf
fmt
"Types: "
;
List
.
iter
(
fun
c
->
print_type
fmt
c
;
Format
.
fprintf
fmt
" "
)
defined_types
;
Format
.
fprintf
fmt
"
\n
"
end
;
if
schema
.
attributes
<>
[]
then
begin
Format
.
fprintf
fmt
"Attributes: "
;
List
.
iter
(
fun
c
->
print_attribute
fmt
c
;
Format
.
fprintf
fmt
" "
)
schema
.
attributes
;
Format
.
fprintf
fmt
"
\n
"
end
;
if
schema
.
elements
<>
[]
then
begin
Format
.
fprintf
fmt
"Elements: "
;
List
.
iter
(
fun
c
->
print_element
fmt
c
;
Format
.
fprintf
fmt
" "
)
schema
.
elements
;
Format
.
fprintf
fmt
"
\n
"
end
;
if
schema
.
attribute_groups
<>
[]
then
begin
Format
.
fprintf
fmt
"Attribute groups: "
;
List
.
iter
(
fun
c
->
print_attribute_group
fmt
c
;
Format
.
fprintf
fmt
" "
)
schema
.
attribute_groups
;
Format
.
fprintf
fmt
"
\n
"
end
;
if
schema
.
model_groups
<>
[]
then
begin
Format
.
fprintf
fmt
"Model groups: "
;
List
.
iter
(
fun
c
->
print_model_group_def
fmt
c
;
Format
.
fprintf
fmt
" "
)
schema
.
model_groups
;
Format
.
fprintf
fmt
"
\n
"
end
let
get_qual
name
table
get_name
=
List
.
find
(
fun
x
->
try
Ns
.
QName
.
equal
(
get_name
x
)
name
with
Invalid_argument
_
->
false
)
table
let
get_type
name
schema
=
get_qual
name
schema
.
types
name_of_type_definition
let
get_attribute
name
schema
=
get_qual
name
schema
.
attributes
name_of_attribute_declaration
let
get_element
name
schema
=
get_qual
name
schema
.
elements
name_of_element_declaration
let
get_attribute_group
name
schema
=
get_qual
name
schema
.
attribute_groups
name_of_attribute_group_definition
let
get_model_group
name
schema
=
get_qual
name
schema
.
model_groups
name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
let
get_component
kind
name
schema
=
let
rec
tries
=
function
|
[]
->
raise
Not_found
|
hd
::
tl
->
(
try
hd
()
with
Not_found
->
tries
tl
)
in
let
elt
()
=
Element
(
get_element
name
schema
)
in
let
typ
()
=
Type
(
get_type
name
schema
)
in
let
att
()
=
Attribute
(
get_attribute
name
schema
)
in
let
att_group
()
=
Attribute_group
(
get_attribute_group
name
schema
)
in
let
mod_group
()
=
Model_group
(
get_model_group
name
schema
)
in
match
kind
with
|
Some
`Element
->
elt
()
|
Some
`Type
->
typ
()
|
Some
`Attribute
->
att
()
|
Some
`Attribute_group
->
att_group
()
|
Some
`Model_group
->
mod_group
()
|
None
->
tries
[
elt
;
typ
;
att
;
att_group
;
mod_group
]
let
string_of_component_kind
(
kind
:
component_kind
)
=
match
kind
with
|
Some
`Type
->
"type"
|
Some
`Element
->
"element"
|
Some
`Attribute
->
"attribute"
|
Some
`Attribute_group
->
"attribute group"
|
Some
`Model_group
->
"model group"
|
None
->
"component"
(** Events *)
|
All
particles
|
Sequence
particles
->
List
.
for_all
(
fun
p
->
p
.
part_nullable
)
particles
|
Choice
particles
->
List
.
exists
(
fun
p
->
p
.
part_nullable
)
particles
type
to_be_visited
=
|
Fully
of
Value
.
t
(* xml values still to be visited *)
...
...
@@ -359,51 +174,6 @@ let string_of_event = function
sprintf
"@%s=%s"
(
Ns
.
QName
.
to_string
qname
)
(
Utf8
.
to_string
value
)
|
E_char_data
value
->
Utf8
.
to_string
value
(*
let test v =
let s = stream_of_value v in
let rec aux () =
(match Stream.peek s with
| None -> ()
| Some (E_start_tag qname) ->
Ns.QName.print Format.std_formatter qname
| Some (E_end_tag qname) ->
Format.fprintf Format.std_formatter "/";
Ns.QName.print Format.std_formatter qname
| Some (E_attribute (qname, value)) ->
Format.fprintf Format.std_formatter "@@";
Ns.QName.print Format.std_formatter qname;
Format.fprintf Format.std_formatter " ";
Encodings.Utf8.print Format.std_formatter value
| Some (E_char_data value) ->
Encodings.Utf8.print Format.std_formatter value);
Format.fprintf Format.std_formatter "\n";
(match Stream.peek s with
| None -> ()
| _ ->
Stream.junk s;
aux ())
in
aux ()
*)
let
rec
print_model_group
ppf
=
function
|
All
pl
->
Format
.
fprintf
ppf
"All(%a)"
print_particle_list
pl
|
Choice
pl
->
Format
.
fprintf
ppf
"Choice(%a)"
print_particle_list
pl
|
Sequence
pl
->
Format
.
fprintf
ppf
"Sequence(%a)"
print_particle_list
pl
and
print_particle_list
ppf
=
function
|
[]
->
()
|
[
p
]
->
print_particle
ppf
p
|
hd
::
tl
->
Format
.
fprintf
ppf
"%a;%a"
print_particle
hd
print_particle_list
tl
and
print_particle
ppf
p
=
print_term
ppf
p
.
part_term
and
print_term
ppf
=
function
|
Elt
e
->
Format
.
fprintf
ppf
"E%i"
e
.
elt_uid
|
Model
m
->
print_model_group
ppf
m
|
Wildcard
_
->
Format
.
fprintf
ppf
"Wildcard"
let
simple_restrict
name
base
new_facets
=
{
st_name
=
name
;
...
...
schema/schema_common.mli
View file @
a0171f82
(** Schema common functionalities depending only on Schema_types *)
open
Encodings
open
Schema_types
(** {2 Exceptions} *)
exception
XSD_validation_error
of
string
exception
XSI_validation_error
of
string
(** {2 XSD printer *)
val
print_schema
:
Format
.
formatter
->
schema
->
unit
val
print_type
:
Format
.
formatter
->
type_definition
->
unit
val
print_attribute
:
Format
.
formatter
->
attribute_declaration
->
unit
val
print_element
:
Format
.
formatter
->
element_declaration
->
unit
val
print_attribute_group
:
Format
.
formatter
->
attribute_group_definition
->
unit
val
print_model_group_def
:
Format
.
formatter
->
model_group_definition
->
unit
val
print_simple_type
:
Format
.
formatter
->
simple_type_definition
->
unit
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
->
Ns
.
qname
val
name_of_type_definition
:
type_definition
->
Ns
.
qname
val
name_of_simple_type_definition
:
simple_type_definition
->
Ns
.
qname
val
name_of_complex_type_definition
:
complex_type_definition
->
Ns
.
qname
val
name_of_attribute_declaration
:
attribute_declaration
->
Ns
.
qname
val
name_of_attribute_use
:
attribute_use
->
Ns
.
qname
val
name_of_attribute_group_definition
:
attribute_group_definition
->
Ns
.
qname
val
name_of_model_group_definition
:
model_group_definition
->
Ns
.
qname
val
name_of_particle
:
particle
->
Ns
.
qname
val
string_of_component_kind
:
component_kind
->
string
val
variety_of_simple_type_definition
:
simple_type_definition
->
variety
val
facets_of_simple_type_definition
:
simple_type_definition
->
facets
val
simple_type_of_type
:
type_definition
->
simple_type_definition
val
complex_type_of_type
:
type_definition
->
complex_type_definition
val
content_type_of_type
:
type_definition
->
content_type
(*
val get_type: Ns.qname -> schema -> type_definition
val get_attribute: Ns.qname -> schema -> attribute_declaration
val get_element: Ns.qname -> schema -> element_declaration
val get_attribute_group: Ns.qname -> schema -> attribute_group_definition
val get_model_group: Ns.qname -> schema -> model_group_definition
*)
val
get_component
:
component_kind
->
Ns
.
qname
->
schema
->
component
val
iter_types
:
schema
->
(
type_definition
->
unit
)
->
unit
val
iter_attributes
:
schema
->
(
attribute_declaration
->
unit
)
->
unit
val
iter_elements
:
schema
->
(
element_declaration
->
unit
)
->
unit
val
iter_attribute_groups
:
schema
->
(
attribute_group_definition
->
unit
)
->
unit
val
iter_model_groups
:
schema
->
(
model_group_definition
->
unit
)
->
unit
val
first_of_wildcard_constraint
:
wildcard_constraint
->
Atoms
.
t
val
first_of_particle
:
particle
->
Atoms
.
t
val
first_of_model_group
:
model_group
->
Atoms
.
t
val
nullable
:
particle
->
bool
val
first_of_wildcard_constraint
:
wildcard_constraint
->
Atoms
.
t
val
nullable_of_model_group
:
model_group
->
bool
(** {2 Facets} *)
val
merge_facets
:
facets
->
facets
->
facets
(*
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
to <`Collapse, true>, the mandatory value for all non string derived simple
types) *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
to <`Collapse, true>, the mandatory value for all non string derived simple
types) *)
val
no_facets
:
facets
val
anyType
:
type_definition
(** @return the integer interval corrisponding to boundary facets *)
val
get_interval
:
facets
->
Intervals
.
t
(** perform white space normalization according to XML recommendation *)
(** perform white space normalization according to XML recommendation *)
val
normalize_white_space
:
white_space_handling
->
Utf8
.
t
->
Utf8
.
t
(** {2 event interface on top of CDuce values} *)
...
...
@@ -97,12 +27,6 @@ val stream_of_value: Value.t -> event Stream.t
val
string_of_event
:
event
->
string
val
print_model_group
:
Format
.
formatter
->
model_group
->
unit
val
print_particle
:
Format
.
formatter
->
particle
->
unit
val
simple_restrict
:
Ns
.
qname
option
->
simple_type_definition
->
facets
->
simple_type_definition
val
simple_list
:
...
...
schema/schema_parser.ml
View file @
a0171f82
...
...
@@ -126,9 +126,6 @@ let parse_facets base n =
in
_fold_elems
n
no_facets
aux
let
merge_facets'
base
new_facets
=
merge_facets
(
facets_of_simple_type_definition
base
)
new_facets
let
default_fixed
n
f
=
match
_may_attr
"default"
n
with
|
Some
v
->
Some
(
`Default
(
f
v
))
...
...
@@ -377,7 +374,7 @@ let schema_of_uri uri =
|
Complex
{
ct_attrs
=
uses
}
,
`Restriction
->
let
(
&=
)
u1
u2
=
(* by name equality over attribute uses *)
(
name_of_attribute_use
u1
=
name_of_attribute_use
u2
)
(
u1
.
attr_decl
.
attr_name
=
u2
.
attr_decl
.
attr_name
)
in
let
l
=
List
.
filter
...
...
@@ -514,7 +511,7 @@ let schema_of_uri uri =
|
Some
ref
->
elt
(
resolve_elt
ref
)
ref
|
None
->
let
decl
=
parse_elt_decl
false
n
in
elt
decl
(
name_of_element_declaration
decl
)
)
elt
decl
decl
.
elt_name
)
|
"xsd:group"
->
model
(
resolve_model_group
(
_qname_attr
"ref"
n
))
.
mg_def
|
"xsd:all"
|
"xsd:sequence"
|
"xsd:choice"
->
model
(
parse_model_group
n
)
...
...
schema/schema_types.ml
View file @
a0171f82
...
...
@@ -143,19 +143,5 @@ type schema = {
type
event
=
|
E_start_tag
of
Ns
.
qname
|
E_end_tag
of
Ns
.
qname
|
E_attribute
of
Ns
.
qname
*
Encodings
.
Utf8
.
t
(* qualified name, value *)
|
E_attribute
of
Ns
.
qname
*
Encodings
.
Utf8
.
t
|
E_char_data
of
Encodings
.
Utf8
.
t
(** {2 Misc} *)
(* kind of a schema component *)
type
component_kind
=
[
`Type
|
`Element
|
`Attribute
|
`Attribute_group
|
`Model_group
]
option
type
component
=
|
Type
of
type_definition
|
Element
of
element_declaration
|
Attribute
of
attribute_declaration
|
Attribute_group
of
attribute_group_definition
|
Model_group
of
model_group_definition
schema/schema_types.mli
View file @
a0171f82
...
...
@@ -5,17 +5,8 @@
exceptions are available here. See Schema_common.
*)
(**
Glossary:
XSD XML Schema Document
PSV Post Schema Validation
PSVI Post Schema Validation Infoset
*)
open
Encodings
(** {2 XSD representation} *)
type
derivation_type
=
[
`Extension
|
`Restriction
]
type
white_space_handling
=
[
`Preserve
|
`Replace
|
`Collapse
]
...
...
@@ -138,24 +129,8 @@ type schema = {
model_groups
:
model_group_definition
list
;
}
(** {2 Events} see Schema_events module *)
type
event
=
|
E_start_tag
of
Ns
.
qname
|
E_end_tag
of
Ns
.
qname
|
E_attribute
of
Ns
.
qname
*
Encodings
.
Utf8
.
t
(* qualified name, value *)
|
E_attribute
of
Ns
.
qname
*
Encodings
.
Utf8
.
t
|
E_char_data
of
Encodings
.
Utf8
.
t
(** {2 Misc} *)
(* kind of a schema component *)
type
component_kind
=
[
`Type
|
`Element
|
`Attribute
|
`Attribute_group
|
`Model_group
]
option
type
component
=
|
Type
of
type_definition
|
Element
of
element_declaration
|
Attribute
of
attribute_declaration
|
Attribute_group
of
attribute_group_definition
|
Model_group
of
model_group_definition
schema/schema_validator.ml
View file @
a0171f82
...
...
@@ -333,7 +333,7 @@ let next_tag ctx =
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
)
(
fun
use
->
QTable
.
add
tbl
use
.
attr_decl
.
attr_name
use
)
attr_uses
;
let
attribs
=
ref
[]
in
List
.
iter
...
...
@@ -417,13 +417,6 @@ and validate_content_type ctx content_type =
get
ctx
and
validate_particle
ctx
particle
=
(*
Format.fprintf ppf "Particle first";
List.iter (fun n -> Format.fprintf ppf "%a;" Ns.QName.print n)
particle.part_first;
Format.fprintf ppf "@.";
*)
let
rec
validate_once
~
cont_ok
~
cont_failure
=
do_pcdata
ctx
;
match
peek
ctx
with
...
...
@@ -472,7 +465,7 @@ and validate_term ctx term =
and
validate_choice
ctx
particles
=
(* TODO: Handle case when one of the choices is nullable *)
let
tbl
=
Atoms
.
mk_map
(
List
.
map
(
fun
p
->
first_of_particle
p
,
p
)
particles
)
in
(
List
.
map
(
fun
p
->
p
.
part_first
,
p
)
particles
)
in
do_pcdata
ctx
;
try
(
match
peek
ctx
with
...
...
@@ -487,7 +480,7 @@ and validate_all_group ctx particles =
let
tbl
=
QTable
.
create
20
in
let
slots
=
List
.
map
(
fun
p
->
(
p
,
ref
None
))
particles
in
let
tbl
=
Atoms
.
mk_map
(
List
.
map
(
fun
(
p
,
slot
)
->
first_of_particle
p
,
(
p
,
slot
))
slots
)
in
(
List
.
map
(
fun
(
p
,
slot
)
->
p
.
part_first
,
(
p
,
slot
))
slots
)
in
let
contents
=
ref
Value
.
nil
in
let
rec
aux
()
=
...
...
@@ -509,7 +502,7 @@ and validate_all_group ctx particles =
(
fun
(
p
,
slot
)
->
match
!
slot
with
|
Some
x
->
concat
ctx
x
|
None
when
nullable
p
->
()
|
None
when
p
.
part_
nullable
->
()
|
None
->
error
"One particle of the all group is missing"
)
slots