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
12751b7b
Commit
12751b7b
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-25 00:59:40 by afrisch] Schema element wildcards
Original author: afrisch Date: 2005-02-25 00:59:41+00:00
parent
2c40dd58
Changes
9
Hide whitespace changes
Inline
Side-by-side
schema/schema_common.ml
View file @
12751b7b
...
...
@@ -147,14 +147,21 @@ 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
|
WNot
ns
->
Atoms
.
diff
Atoms
.
any
(
Atoms
.
any_in_ns
ns
)
|
WOne
l
->
List
.
fold_left
(
fun
acc
ns
->
Atoms
.
cup
acc
(
Atoms
.
any_in_ns
ns
))
Atoms
.
empty
l
let
first_of_model_group
=
function
|
All
particles
|
Choice
particles
->
List
.
concat
(
List
.
map
first_of_particle
particles
)
List
.
fold_left
(
fun
acc
p
->
Atoms
.
cup
acc
(
first_of_particle
p
))
Atoms
.
empty
particles
|
Sequence
particles
->
let
rec
aux
=
function
|
hd
::
tl
when
nullable
hd
->
(
first_of_particle
hd
)
@
(
aux
tl
)
|
hd
::
tl
->
first_of_particle
hd
|
[]
->
[]
|
hd
::
tl
when
nullable
hd
->
Atoms
.
cup
(
first_of_particle
hd
)
(
aux
tl
)
|
hd
::
tl
->
first_of_particle
hd
|
[]
->
Atoms
.
empty
in
aux
particles
...
...
@@ -394,6 +401,7 @@ and print_particle ppf p =
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"
...
...
schema/schema_common.mli
View file @
12751b7b
...
...
@@ -62,9 +62,11 @@ 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
->
Ns
.
qname
list
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_model_group
:
model_group
->
Ns
.
qname
list
val
nullable_of_model_group
:
model_group
->
bool
(** {2 Facets} *)
...
...
schema/schema_parser.ml
View file @
12751b7b
...
...
@@ -53,7 +53,7 @@ let element, complex =
let
space_RE
=
pcre_regexp
" "
let
split
s
=
pcre_split
~
rex
:
space_RE
s
let
unqualify
s
=
snd
(
Ns
.
split_qname
s
)
(*
let unqualify s = snd (Ns.split_qname s)
*)
let
hashtbl_deref
tbl
=
QTable
.
fold
(
fun
_
v
acc
->
(
check_force
v
)
::
acc
)
tbl
[]
...
...
@@ -144,7 +144,8 @@ let rec first n f = function
|
x
::
l
->
match
f
x
n
with
None
->
first
n
f
l
|
x
->
x
let
find_particles
n
=
_filter_elems
[
"xsd:element"
;
"xsd:group"
;
"xsd:choice"
;
"xsd:sequence"
]
n
_filter_elems
[
"xsd:element"
;
"xsd:group"
;
"xsd:choice"
;
"xsd:sequence"
;
"xsd:any"
]
n
let
find_particle
n
=
first
n
_may_elem
[
"xsd:all"
;
"xsd:choice"
;
"xsd:group"
;
"xsd:sequence"
]
...
...
@@ -493,7 +494,8 @@ 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
]
(
min
=
0
)
in
let
elt
e
n
=
particle
min
max
(
Elt
e
)
(
Atoms
.
atom
(
Atoms
.
V
.
of_qname
n
))
(
min
=
0
)
in
match
_tag
n
with
|
"xsd:element"
->
(
match
_may_qname_attr
"ref"
n
with
...
...
@@ -504,8 +506,35 @@ let schema_of_uri uri =
|
"xsd:group"
->
model
(
resolve_model_group
(
_qname_attr
"ref"
n
))
.
mg_def
|
"xsd:all"
|
"xsd:sequence"
|
"xsd:choice"
->
model
(
parse_model_group
n
)
|
"xsd:any"
->
let
w
=
parse_wildcard
n
in
particle
min
max
(
Wildcard
w
)
w
.
wild_first
(
min
=
0
)
|
_
->
assert
false
and
parse_wildcard
n
=
let
c
=
parse_wildcard_cstr
n
in
{
wild_cstr
=
c
;
wild_process
=
parse_wildcard_process
n
;
wild_first
=
first_of_wildcard_constraint
c
}
and
parse_wildcard_process
n
=
match
_may_attr
"processContents"
n
with
|
Some
t
when
Utf8
.
get_str
t
=
"lax"
->
`Lax
|
Some
t
when
Utf8
.
get_str
t
=
"skip"
->
`Skip
|
Some
t
when
Utf8
.
get_str
t
=
"strict"
->
`Strict
|
None
->
`Strict
|
_
->
failwith
"Wildcard processContents attribute not recognized"
and
parse_wildcard_cstr
n
=
match
_may_attr
"namespace"
n
with
|
None
->
WAny
|
Some
ns
when
Utf8
.
get_str
ns
=
"##any"
->
WAny
|
Some
ns
when
Utf8
.
get_str
ns
=
"##other"
->
WNot
targetNamespace
|
Some
ns
->
WOne
(
List
.
map
parse_wildcard_ns
(
split
ns
))
and
parse_wildcard_ns
=
function
|
ns
when
Utf8
.
get_str
ns
=
"##targetNamespace"
->
targetNamespace
|
ns
when
Utf8
.
get_str
ns
=
"##local"
->
Ns
.
empty
|
ns
->
Ns
.
mk
ns
and
parse_model_group
n
=
match
_tag
n
with
|
"xsd:all"
->
...
...
schema/schema_types.ml
View file @
12751b7b
...
...
@@ -66,6 +66,7 @@ and attribute_use =
and
term
=
|
Elt
of
element_declaration
|
Model
of
model_group
|
Wildcard
of
wildcard
and
model_group
=
|
All
of
particle
list
...
...
@@ -81,7 +82,7 @@ and particle =
{
part_min
:
int
;
part_max
:
int
option
;
(* None = unbounded *)
part_term
:
term
;
part_first
:
Ns
.
qname
lis
t
;
part_first
:
Atoms
.
t
;
part_nullable
:
bool
}
and
element_declaration
=
...
...
@@ -103,6 +104,17 @@ and type_definition =
|
Simple
of
simple_type_definition
|
Complex
of
complex_type_definition
and
wildcard_constraint
=
|
WAny
|
WNot
of
Ns
.
t
|
WOne
of
Ns
.
t
list
and
wildcard
=
{
wild_cstr
:
wildcard_constraint
;
wild_process
:
[
`Lax
|
`Skip
|
`Strict
];
wild_first
:
Atoms
.
t
;
}
type
model_group_definition
=
{
mg_name
:
Ns
.
qname
;
mg_def
:
model_group
}
...
...
schema/schema_types.mli
View file @
12751b7b
...
...
@@ -66,6 +66,7 @@ and attribute_use =
and
term
=
|
Elt
of
element_declaration
|
Model
of
model_group
|
Wildcard
of
wildcard
and
model_group
=
|
All
of
particle
list
...
...
@@ -81,7 +82,7 @@ and particle =
{
part_min
:
int
;
part_max
:
int
option
;
(* None = unbounded *)
part_term
:
term
;
part_first
:
Ns
.
qname
lis
t
;
part_first
:
Atoms
.
t
;
part_nullable
:
bool
}
and
element_declaration
=
...
...
@@ -103,6 +104,17 @@ and type_definition =
|
Simple
of
simple_type_definition
|
Complex
of
complex_type_definition
and
wildcard_constraint
=
|
WAny
|
WNot
of
Ns
.
t
|
WOne
of
Ns
.
t
list
and
wildcard
=
{
wild_cstr
:
wildcard_constraint
;
wild_process
:
[
`Lax
|
`Skip
|
`Strict
];
wild_first
:
Atoms
.
t
;
}
type
model_group_definition
=
{
mg_name
:
Ns
.
qname
;
mg_def
:
model_group
}
...
...
schema/schema_validator.ml
View file @
12751b7b
...
...
@@ -120,6 +120,7 @@ let expect_start_tag ctx tag =
|
ev
->
error
(
sprintf
"Expected tag %s, found %s"
(
Ns
.
QName
.
to_string
tag
)
(
string_of_event
ev
))
let
expect_any_start_tag
ctx
=
match
next
ctx
with
|
E_start_tag
t
->
t
...
...
@@ -290,6 +291,15 @@ let rec validate_any_type ctx =
aux
()
;
(
Value
.
vrecord
attrs
,
get
ctx
)
let
validate_wildcard
ctx
w
=
let
qname
=
expect_any_start_tag
ctx
in
if
Atoms
.
contains
(
Atoms
.
V
.
of_qname
qname
)
w
.
wild_first
then
error
(
sprintf
"Tag %s is not accepted by the wildcard"
(
Ns
.
QName
.
to_string
qname
));
let
(
attrs
,
content
)
=
validate_any_type
ctx
in
expect_end_tag
ctx
;
xml
qname
attrs
content
let
check_fixed
~
ctx
fixed
value
=
if
not
(
Value
.
equal
fixed
value
)
then
error
~
ctx
(
sprintf
"Expected fixed value: %s; found %s"
...
...
@@ -389,7 +399,7 @@ and validate_particle ctx particle =
do_pcdata
ctx
;
match
peek
ctx
with
|
E_start_tag
qname
when
List
.
exists
(
Ns
.
QName
.
equal
qname
)
particle
.
part_first
->
when
Atoms
.
contains
(
Atoms
.
V
.
of_qname
qname
)
particle
.
part_first
->
validate_term
ctx
particle
.
part_term
;
cont_ok
()
|
ev
->
...
...
@@ -426,21 +436,19 @@ and validate_particle ctx particle =
and
validate_term
ctx
term
=
match
term
with
|
Elt
elt_decl_ref
->
append
ctx
(
validate_element
ctx
elt_decl_ref
)
|
Model
model_group
->
validate_model_group
ctx
model_group
|
Elt
elt
->
append
ctx
(
validate_element
ctx
elt
)
|
Model
mg
->
validate_model_group
ctx
mg
|
Wildcard
w
->
append
ctx
(
validate_wildcard
ctx
w
)
and
validate_choice
ctx
particles
=
(* TODO: Handle case when one of the choices is nullable *)
let
tbl
=
QTable
.
create
20
in
List
.
iter
(
fun
p
->
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
p
)
(
first_of_particle
p
))
particles
;
let
tbl
=
Atoms
.
mk_map
(
List
.
map
(
fun
p
->
first_of_particle
p
,
p
)
particles
)
in
do_pcdata
ctx
;
try
(
match
peek
ctx
with
|
E_start_tag
qname
->
let
particle
=
QTable
.
find
tbl
qname
in
let
particle
=
Atoms
.
get_map
(
Atoms
.
V
.
of_qname
qname
)
tbl
in
validate_particle
ctx
particle
|
_
->
raise
Not_found
)
with
Not_found
->
...
...
@@ -448,21 +456,16 @@ and validate_choice ctx particles =
and
validate_all_group
ctx
particles
=
let
tbl
=
QTable
.
create
20
in
let
slots
=
List
.
map
(
fun
p
->
let
slot
=
ref
None
in
let
first
=
first_of_particle
p
in
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
(
p
,
slot
))
first
;
(
nullable
p
,
slot
)
)
particles
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
let
contents
=
ref
Value
.
nil
in
let
rec
aux
()
=
match
peek
ctx
with
|
E_start_tag
qname
->
let
qname
=
next_tag
ctx
in
let
p
,
slot
=
QTable
.
find
tbl
qname
in
let
p
,
slot
=
Atoms
.
get_map
(
Atoms
.
V
.
of_qname
qname
)
tbl
in
(
match
!
slot
with
|
Some
x
->
()
|
None
->
...
...
@@ -474,10 +477,10 @@ and validate_all_group ctx particles =
do_pcdata
ctx
;
aux
()
;
List
.
iter
(
fun
(
nullable
,
slot
)
->
(
fun
(
p
,
slot
)
->
match
!
slot
with
|
Some
x
->
concat
ctx
x
|
None
when
nullable
->
()
|
None
when
nullable
p
->
()
|
None
->
error
"One particle of the all group is missing"
)
slots
...
...
types/builtin_defs.ml
View file @
12751b7b
...
...
@@ -71,16 +71,18 @@ let float_abs =
let
float
=
Types
.
abstract
(
Types
.
Abstract
.
atom
float_abs
)
let
any_xml
=
let
any_attr_node
=
Types
.
cons
(
Types
.
record'
(
true
,
LabelMap
.
empty
))
let
any_xml
,
any_xml_seq
,
any_xml_content
=
let
elt
=
Types
.
make
()
in
let
seq
=
Types
.
make
()
in
let
elt_d
=
Types
.
xml
(
Types
.
cons
atom
)
(
Types
.
cons
(
Types
.
times
(
Types
.
cons
(
Types
.
record'
(
true
,
LabelMap
.
empty
)))
seq
))
in
let
any_xml_content
=
Types
.
cons
(
Types
.
times
any_attr_node
seq
)
in
let
elt_d
=
Types
.
xml
(
Types
.
cons
atom
)
any_xml_content
in
let
elt_char_d
=
Types
.
cup
elt_d
char
in
let
seq_d
=
Types
.
cup
nil
(
Types
.
times
(
Types
.
cons
elt_char_d
)
seq
)
in
Types
.
define
elt
elt_d
;
Types
.
define
seq
seq_d
;
elt_d
elt_d
,
seq_d
,
any_xml_content
let
any_xml_with_tag
t
=
Types
.
xml
(
Types
.
cons
(
Types
.
atom
t
))
any_xml_content
types/builtin_defs.mli
View file @
12751b7b
...
...
@@ -43,3 +43,5 @@ val float: Types.t
val
float_abs
:
Types
.
Abstract
.
abs
val
any_xml
:
Types
.
t
val
any_xml_with_tag
:
Atoms
.
t
->
Types
.
t
typing/typer.ml
View file @
12751b7b
...
...
@@ -1636,6 +1636,10 @@ module Schema_converter =
let
rec
regexp_of_term
=
function
|
Model
group
->
regexp_of_model_group
group
|
Elt
decl
->
PElem
(
elt_decl
decl
)
|
Wildcard
w
->
PElem
(
wildcard
w
)
and
wildcard
w
=
itype
(
Builtin_defs
.
any_xml_with_tag
w
.
wild_first
)
and
regexp_of_model_group
=
function
|
Choice
l
->
...
...
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