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
6a26ef06
Commit
6a26ef06
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-22 15:33:36 by afrisch] Clean
Original author: afrisch Date: 2005-02-22 15:33:36+00:00
parent
a7461174
Changes
7
Hide whitespace changes
Inline
Side-by-side
schema/schema_common.ml
View file @
6a26ef06
...
...
@@ -103,7 +103,7 @@ 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
|
(
_
,
_
,
Elt
elt_decl_ref
,
_
)
->
name_of_element_declaration
(
Lazy
.
force
e
lt_decl_ref
)
|
{
part_term
=
Elt
e
}
->
name_of_element_declaration
(
Lazy
.
force
e
)
|
_
->
assert
false
let
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
lazy
(
Simple
st
))
...
...
@@ -146,8 +146,9 @@ let rec normalize_white_space =
let
anySimpleType
=
Primitive
(
xsd
,
Utf8
.
mk
"anySimpleType"
)
let
anyType
=
AnyType
let
first_of_particle
(
_
,
_
,
_
,
first
)
=
first
let
nullable
p
=
List
.
mem
None
(
first_of_particle
p
)
let
first_of_particle
p
=
p
.
part_first
let
nullable
p
=
p
.
part_nullable
let
first_of_model_group
=
function
|
All
particles
|
Choice
particles
->
List
.
concat
(
List
.
map
first_of_particle
particles
)
...
...
@@ -158,10 +159,11 @@ let first_of_model_group = function
|
[]
->
[]
in
aux
particles
let
rec
is_in_first
tag
=
function
|
[]
->
false
|
Some
tag'
::
rest
when
Ns
.
QName
.
equal
tag'
tag
->
true
|
_
::
rest
->
is_in_first
tag
rest
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:
...
...
@@ -430,8 +432,8 @@ 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
(
min
,
max
,
term
,_
)
=
print_term
ppf
term
and
print_particle
ppf
p
=
print_term
ppf
p
.
part_
term
and
print_term
ppf
=
function
|
Elt
e
->
Format
.
fprintf
ppf
"E%i"
((
Lazy
.
force
e
)
.
elt_uid
)
|
Model
m
->
print_model_group
ppf
m
schema/schema_common.mli
View file @
6a26ef06
...
...
@@ -61,10 +61,10 @@ val iter_attribute_groups:
schema
->
(
attribute_group_definition
->
unit
)
->
unit
val
iter_model_groups
:
schema
->
(
model_group_definition
->
unit
)
->
unit
val
first_of_particle
:
particle
->
first
val
first_of_model_group
:
model_group
->
first
val
is_in_first
:
Ns
.
qname
->
first
->
bool
val
first_of_particle
:
particle
->
Ns
.
qname
list
val
nullable
:
particle
->
bool
val
first_of_model_group
:
model_group
->
Ns
.
qname
list
val
nullable_of_model_group
:
model_group
->
bool
(** {2 Facets} *)
...
...
schema/schema_parser.ml
View file @
6a26ef06
...
...
@@ -11,6 +11,20 @@ module QTable = Hashtbl.Make(Ns.QName)
let
validation_error
s
=
raise
(
XSD_validation_error
s
)
let
particle
min
max
term
first
nullable
=
{
part_min
=
min
;
part_max
=
max
;
part_term
=
term
;
part_first
=
first
;
part_nullable
=
nullable
}
let
particle_model
min
max
mg
=
particle
min
max
(
Model
mg
)
(
first_of_model_group
mg
)
(
nullable_of_model_group
mg
)
let
xsd
=
Schema_xml
.
xsd
(*
...
...
@@ -65,23 +79,23 @@ let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
let
parse_facets
base
n
=
let
validate_base_type
v
=
lazy
(
Schema_validator
.
validate_simple_type
(
get_simple_type
base
)
v
)
in
let
validate_nonNegativeInteger
=
Schema_builtin
.
validate_builtin
(
xsd
,
Utf8
.
mk
"nonNegativeInteger"
)
let
parse_nonneg
n
=
let
s
=
Utf8
.
get_str
(
_attr
"value"
n
)
in
let
i
=
int_of_string
s
in
if
(
i
<
0
)
then
failwith
"Unexpected negative integer"
;
i
in
let
aux
facets
n
tag
=
let
fixed
=
_is_attr
"fixed"
n
"true"
in
match
tag
with
|
"xsd:length"
->
let
value
=
_attr
"value"
n
in
let
length
=
Value
.
get_integer
(
validate_nonNegativeInteger
value
)
in
let
length
=
parse_nonneg
n
in
{
facets
with
length
=
Some
(
length
,
fixed
)
}
|
"xsd:minLength"
->
let
value
=
_attr
"value"
n
in
let
length
=
Value
.
get_integer
(
validate_nonNegativeInteger
value
)
in
let
length
=
parse_nonneg
n
in
{
facets
with
minLength
=
Some
(
length
,
fixed
)
}
|
"xsd:maxLength"
->
let
value
=
_attr
"value"
n
in
let
length
=
Value
.
get_integer
(
validate_nonNegativeInteger
value
)
in
let
length
=
parse_nonneg
n
in
{
facets
with
maxLength
=
Some
(
length
,
fixed
)
}
|
"xsd:enumeration"
->
let
value
=
Value
.
string_utf8
(
_attr
"value"
n
)
in
...
...
@@ -134,12 +148,14 @@ let parse_att_value_constraint stype_def n =
let
parse_min_max
n
=
(
match
_may_attr
"minOccurs"
n
with
|
Some
v
->
I
nt
ervals
.
V
.
mk
(
Utf8
.
get_str
v
)
|
None
->
Intervals
.
V
.
one
)
,
|
Some
v
->
i
nt
_of_string
(
Utf8
.
get_str
v
)
|
None
->
1
)
,
(
match
_may_attr
"maxOccurs"
n
with
|
Some
v
when
Utf8
.
get_str
v
=
"unbounded"
->
None
|
Some
v
->
Some
(
Intervals
.
V
.
mk
(
Utf8
.
get_str
v
))
|
None
->
Some
Intervals
.
V
.
one
)
|
Some
v
->
(
match
Utf8
.
get_str
v
with
|
"unbounded"
->
None
|
v
->
Some
(
int_of_string
v
))
|
None
->
Some
1
)
let
rec
first
n
f
=
function
|
[]
->
None
...
...
@@ -453,10 +469,7 @@ let schema_of_uri uri =
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_model
(
particle_model
1
(
Some
1
)
model
,
mixed
)
|
CT_simple
_
->
assert
false
in
base
,
derivation_type
,
uses
,
content_type
...
...
@@ -502,22 +515,18 @@ let schema_of_uri uri =
and
parse_particle
n
=
let
min
,
max
=
parse_min_max
n
in
let
model
mg
=
particle_model
min
max
mg
in
let
elt
e
n
=
particle
min
max
(
Elt
e
)
[
n
]
false
in
match
_tag
n
with
|
"xsd:element"
->
let
elt_decl
,
first
=
match
_may_qname_attr
"ref"
n
with
|
Some
ref
->
(
resolve_elt
ref
,
[
Some
ref
])
|
None
->
let
decl
=
parse_elt_decl
false
n
in
(
lazy
decl
,
[
Some
(
name_of_element_declaration
decl
)
])
in
(
min
,
max
,
Elt
elt_decl
,
first
)
|
"xsd:group"
->
let
mg
=
resolve_model_group
(
_qname_attr
"ref"
n
)
in
(
min
,
max
,
Model
mg
.
mg_def
,
first_of_model_group
mg
.
mg_def
)
|
"xsd:all"
|
"xsd:sequence"
|
"xsd:choice"
->
let
model_group
=
parse_model_group
n
in
(
min
,
max
,
Model
model_group
,
first_of_model_group
model_group
)
(
match
_may_qname_attr
"ref"
n
with
|
Some
ref
->
elt
(
resolve_elt
ref
)
ref
|
None
->
let
decl
=
parse_elt_decl
false
n
in
elt
(
lazy
decl
)
(
name_of_element_declaration
decl
))
|
"xsd:group"
->
model
(
resolve_model_group
(
_qname_attr
"ref"
n
))
.
mg_def
|
"xsd:all"
|
"xsd:sequence"
|
"xsd:choice"
->
model
(
parse_model_group
n
)
|
_
->
assert
false
and
parse_model_group
n
=
...
...
schema/schema_types.ml
View file @
6a26ef06
...
...
@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *)
type
xs_nonNegativeInteger
=
Intervals
.
V
.
t
(* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type
derivation_type
=
[
`Extension
|
`Restriction
]
type
white_space_handling
=
[
`Preserve
|
`Replace
|
`Collapse
]
type
facets
=
{
length
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
minLength
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
maxLength
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
length
:
(
int
*
bool
)
option
;
(* length, fixed *)
minLength
:
(
int
*
bool
)
option
;
(* length, fixed *)
maxLength
:
(
int
*
bool
)
option
;
(* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration
:
value_ref
list
option
;
whiteSpace
:
white_space_handling
*
bool
;
(* handling, fixed *)
...
...
@@ -69,10 +66,6 @@ and 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 *)
and
first
=
Ns
.
QName
.
t
option
list
and
term
=
|
Elt
of
element_declaration
Lazy
.
t
|
Model
of
model_group
...
...
@@ -85,15 +78,14 @@ and model_group =
and
content_type
=
|
CT_empty
|
CT_simple
of
type_ref
|
CT_model
of
particle
*
bool
(* mixed *)
|
CT_model
of
particle
*
bool
(* mixed *)
and
particle
=
xs_nonNegativeInteger
*
(* minOccurs *)
xs_nonNegativeInteger
option
*
(* maxOccurs (None = "unbounded") *)
term
*
first
{
part_min
:
int
;
part_max
:
int
option
;
(* None = unbounded *)
part_term
:
term
;
part_first
:
Ns
.
qname
list
;
part_nullable
:
bool
}
and
element_declaration
=
{
elt_uid
:
int
;
...
...
schema/schema_types.mli
View file @
6a26ef06
...
...
@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *)
type
xs_nonNegativeInteger
=
Intervals
.
V
.
t
(* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type
derivation_type
=
[
`Extension
|
`Restriction
]
type
white_space_handling
=
[
`Preserve
|
`Replace
|
`Collapse
]
type
facets
=
{
length
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
minLength
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
maxLength
:
(
xs_nonNegativeInteger
*
bool
)
option
;
(* length, fixed *)
length
:
(
int
*
bool
)
option
;
(* length, fixed *)
minLength
:
(
int
*
bool
)
option
;
(* length, fixed *)
maxLength
:
(
int
*
bool
)
option
;
(* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration
:
value_ref
list
option
;
whiteSpace
:
white_space_handling
*
bool
;
(* handling, fixed *)
...
...
@@ -69,10 +66,6 @@ and 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 *)
and
first
=
Ns
.
QName
.
t
option
list
and
term
=
|
Elt
of
element_declaration
Lazy
.
t
|
Model
of
model_group
...
...
@@ -85,15 +78,14 @@ and model_group =
and
content_type
=
|
CT_empty
|
CT_simple
of
type_ref
|
CT_model
of
particle
*
bool
(* mixed *)
|
CT_model
of
particle
*
bool
(* mixed *)
and
particle
=
xs_nonNegativeInteger
*
(* minOccurs *)
xs_nonNegativeInteger
option
*
(* maxOccurs (None = "unbounded") *)
term
*
first
{
part_min
:
int
;
part_max
:
int
option
;
(* None = unbounded *)
part_term
:
term
;
part_first
:
Ns
.
qname
list
;
part_nullable
:
bool
}
and
element_declaration
=
{
elt_uid
:
int
;
...
...
schema/schema_validator.ml
View file @
6a26ef06
...
...
@@ -33,10 +33,8 @@ let ptbl_of_particles particles =
let
tbl
=
QTable
.
create
20
in
List
.
iter
(* fill table *)
(* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
(
fun
p
->
List
.
iter
(
function
None
->
()
|
Some
tag
->
QTable
.
add
tbl
tag
p
)
(
first_of_particle
p
))
(
fun
p
->
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
p
)
(
first_of_particle
p
))
particles
;
tbl
...
...
@@ -54,10 +52,6 @@ class type validation_context =
method
set_mixed
:
bool
->
unit
method
mixed
:
bool
(*
method ns: Ns.t
*)
end
let
validation_error
?
context
s
=
raise
(
XSI_validation_error
s
)
...
...
@@ -103,21 +97,20 @@ struct
* and no Concat, but just Pair *)
let
length
v
=
let
rec
aux
acc
=
function
|
Pair
(
_
,
rest
)
->
aux
(
Intervals
.
V
.
succ
acc
)
rest
|
v
when
v
=
Value
.
nil
->
Intervals
.
V
.
zero
|
_
->
assert
false
|
Pair
(
_
,
rest
)
->
aux
(
succ
acc
)
rest
|
_
->
0
in
aux
Intervals
.
V
.
zero
v
aux
0
v
let
length_valid
len
value
=
if
not
(
Intervals
.
V
.
equal
(
length
value
)
len
)
then
raise
(
Facet_error
"length"
)
if
(
length
value
!=
len
)
then
raise
(
Facet_error
"length"
)
let
minLength_valid
min_len
value
=
if
Intervals
.
V
.
lt
(
length
value
)
min_len
then
raise
(
Facet_error
"minLength"
)
if
(
length
value
<
min_len
)
then
raise
(
Facet_error
"minLength"
)
let
maxLength_valid
max_len
value
=
if
Intervals
.
V
.
gt
(
length
value
)
max_len
then
raise
(
Facet_error
"maxLength"
)
if
(
length
value
>
max_len
)
then
raise
(
Facet_error
"maxLength"
)
let
enumeration_valid
enum
value
=
if
not
(
List
.
exists
(
fun
x
->
Value
.
equal
value
(
Lazy
.
force
x
))
enum
)
...
...
@@ -341,13 +334,13 @@ and validate_content_type context content_type : Value.t =
validate_particle
context
particle
and
validate_particle
context
particle
=
let
(
min
,
max
,
term
,
first
)
=
particle
in
let
content
=
ref
Value
.
nil
in
let
concat
v
=
content
:=
Value
.
concat
!
content
v
in
let
rec
validate_once
~
cont_ok
~
cont_failure
=
match
context
#
peek
with
|
E_start_tag
qname
when
is_in_first
qname
first
->
concat
(
validate_term
context
term
);
|
E_start_tag
qname
when
List
.
exists
(
Ns
.
QName
.
equal
qname
)
particle
.
part_first
->
concat
(
validate_term
context
particle
.
part_term
);
cont_ok
()
|
E_char_data
utf8_data
when
context
#
mixed
->
concat
(
string_utf8
utf8_data
);
...
...
@@ -356,10 +349,10 @@ and validate_particle context particle =
|
ev
->
cont_failure
ev
in
let
rec
required
=
function
|
v
when
Intervals
.
V
.
equal
v
Intervals
.
V
.
zero
->
()
|
n
(* when n > 0 *)
->
|
0
->
()
|
n
->
validate_once
~
cont_ok
:
(
fun
()
->
required
(
Intervals
.
V
.
pred
n
))
~
cont_ok
:
(
fun
()
->
required
(
pred
n
))
~
cont_failure
:
(
fun
event
->
validation_error
~
context
(
sprintf
"Unexpected content: %s"
(
string_of_event
event
)))
...
...
@@ -369,10 +362,10 @@ and validate_particle context particle =
validate_once
~
cont_ok
:
(
fun
()
->
optional
None
)
~
cont_failure
:
(
fun
_
->
()
)
|
Some
v
when
Intervals
.
V
.
equal
v
Intervals
.
V
.
zero
->
()
|
Some
n
(* when n > 0 *)
->
|
Some
0
->
()
|
Some
n
->
validate_once
~
cont_ok
:
(
fun
()
->
optional
(
Some
(
Intervals
.
V
.
pred
n
)))
~
cont_ok
:
(
fun
()
->
optional
(
Some
(
pred
n
)))
~
cont_failure
:
(
fun
_
->
()
)
in
let
rec
trailing_cdata
()
=
...
...
@@ -383,9 +376,11 @@ and validate_particle context particle =
trailing_cdata
()
|
_
->
()
in
required
min
;
required
particle
.
part_
min
;
optional
(
match
max
with
None
->
None
|
Some
v
->
Some
(
Intervals
.
V
.
sub
v
min
));
(
match
particle
.
part_max
with
|
None
->
None
|
Some
v
->
Some
(
v
-
particle
.
part_min
));
if
context
#
mixed
then
trailing_cdata
()
;
!
content
...
...
@@ -518,10 +513,6 @@ class context ~stream ~schema =
(
string_of_event
ev
));
foo_qname
(* useless *)
(*
method ns = schema.targetNamespace
*)
end
(** {2 API} *)
...
...
typing/typer.ml
View file @
6a26ef06
...
...
@@ -1508,22 +1508,19 @@ module Schema_converter =
let
mk_len_regexp
?
min
?
max
base
=
let
rec
repeat_regexp
re
=
function
|
z
when
Intervals
.
V
.
is_zero
z
->
PEpsilon
|
n
when
Intervals
.
V
.
gt
n
Intervals
.
V
.
zero
->
seq
re
(
repeat_regexp
re
(
Intervals
.
V
.
pred
n
))
|
_
->
assert
false
|
0
->
PEpsilon
|
n
->
seq
re
(
repeat_regexp
re
(
pred
n
))
in
let
min
=
match
min
with
Some
min
->
min
|
_
->
Intervals
.
V
.
one
in
let
min
=
match
min
with
Some
min
->
min
|
_
->
1
in
let
min_regexp
=
repeat_regexp
base
min
in
match
max
with
|
Some
max
->
(* assert (max >= min); Need to use Bigint comparison ! -- AF *)
let
rec
aux
acc
=
function
|
z
when
Intervals
.
V
.
is_zero
z
->
acc
|
n
->
aux
(
PAlt
(
PEpsilon
,
(
seq
base
acc
)))
(
Intervals
.
V
.
pred
n
)
|
0
->
acc
|
n
->
aux
(
PAlt
(
PEpsilon
,
(
seq
base
acc
)))
(
pred
n
)
in
seq
min_regexp
(
aux
PEpsilon
(
Intervals
.
V
.
sub
max
min
))
seq
min_regexp
(
aux
PEpsilon
(
max
-
min
))
|
None
->
seq
min_regexp
(
PStar
base
)
(* given a base derecurs create a derecurs value representing a sequence
...
...
@@ -1621,8 +1618,9 @@ module Schema_converter =
seq
acc
(
regexp_of_particle
~
schema
particle
))
(
regexp_of_particle
~
schema
hd
)
tl
and
regexp_of_particle
~
schema
(
min
,
max
,
term
,
_
)
=
mk_len_regexp
?
min
:
(
Some
min
)
?
max
(
regexp_of_term
~
schema
term
)
and
regexp_of_particle
~
schema
p
=
mk_len_regexp
?
min
:
(
Some
p
.
part_min
)
?
max
:
p
.
part_max
(
regexp_of_term
~
schema
p
.
part_term
)
(** @return a pair composed by a type for the attributes (a record) and a
type for the content model (a sequence) *)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment