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
c56184ef
Commit
c56184ef
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-02-25 14:13:45 by afrisch] anyAttribute
Original author: afrisch Date: 2005-02-25 14:13:45+00:00
parent
4ad83cba
Changes
8
Hide whitespace changes
Inline
Side-by-side
schema/TODO
0 → 100644
View file @
c56184ef
- substitution groups
- don't name schema, use namespaces
\ No newline at end of file
schema/schema_common.ml
View file @
c56184ef
...
...
@@ -428,3 +428,6 @@ let xsi_nil_qname = (Schema_xml.xsi,Utf8.mk "nil")
let
xsi_nil_atom
=
Atoms
.
V
.
of_qname
xsi_nil_qname
let
xsi_nil_type
=
Types
.
atom
(
Atoms
.
atom
xsi_nil_atom
)
let
xsi_nil_label
=
Ident
.
LabelPool
.
mk
xsi_nil_qname
let
merge_attribute_uses
l
=
List
.
fold_left
(
fun
(
l
,
a
)
(
l'
,
a'
)
->
(
l
@
l'
,
a
||
a'
))
([]
,
false
)
l
schema/schema_common.mli
View file @
c56184ef
...
...
@@ -115,3 +115,6 @@ val xsi_nil_type: Types.t
val
xsi_nil_qname
:
Ns
.
qname
val
xsi_nil_atom
:
Atoms
.
V
.
t
val
xsi_nil_label
:
Ident
.
label
val
merge_attribute_uses
:
attribute_uses
list
->
attribute_uses
schema/schema_parser.ml
View file @
c56184ef
...
...
@@ -47,7 +47,8 @@ let element, complex =
elt_name
=
name
;
elt_typdef
=
type_def
;
elt_cstr
=
constr
;
elt_nillable
=
nillable
}
elt_nillable
=
nillable
}
in
let
complex
name
(
type_def
:
type_definition
)
deriv
attrs
ct
=
incr
counter
;
...
...
@@ -56,7 +57,8 @@ let element, complex =
ct_typdef
=
type_def
;
ct_deriv
=
deriv
;
ct_attrs
=
attrs
;
ct_content
=
ct
}
ct_content
=
ct
;
}
in
(
element
,
complex
)
...
...
@@ -353,38 +355,36 @@ let schema_of_uri uri =
attr_decl
=
att_decl
;
attr_use_cstr
=
value_constr
}
and
parse_attribute_uses
derivation_type
base
n
=
and
parse_attribute_uses
n
=
let
uses1
=
(* attribute uses from "attribute" children *)
List
.
map
parse_attribute_use
(
_elems
"xsd:attribute"
n
)
in
(
List
.
map
parse_attribute_use
(
_elems
"xsd:attribute"
n
))
,
(
match
_may_elem
"xsd:anyAttribute"
n
with
Some
_
->
true
|
_
->
false
)
in
let
uses2
=
(* attribute uses from "attributeGroup" children ref *)
List
.
concat
(
List
.
map
(
fun
att_group
->
match
_may_qname_attr
"ref"
att_group
with
|
Some
v
->
(
resolve_att_group
v
)
.
ag_def
|
None
->
[]
)
(
_elems
"xsd:attributeGroup"
n
))
in
let
uses3
=
(* attribute uses from base type *)
match
base
with
|
Complex
{
ct_attrs
=
uses
}
->
(
match
derivation_type
with
|
`Extension
->
uses
|
`Restriction
->
let
(
&=
)
u1
u2
=
(* by name equality over attribute uses *)
(
name_of_attribute_use
u1
=
name_of_attribute_use
u2
)
in
let
defined_uses
=
uses1
@
uses2
in
List
.
filter
(
fun
use
->
not
(
List
.
exists
(
fun
u
->
u
&=
use
)
defined_uses
))
(* && not (List.mem name prohibited_uses1) *)
(* TODO prohibited attribute uses *)
uses
)
|
_
->
[]
in
uses1
@
uses2
@
uses3
List
.
map
(
fun
n
->
(
parse_att_group
n
)
.
ag_def
)
(
_elems
"xsd:attributeGroup"
n
)
in
merge_attribute_uses
(
uses1
::
uses2
)
and
parse_attribute_uses_deriv
derivation_type
base
n
=
(* TODO: check these rules *)
let
duses
=
parse_attribute_uses
n
in
(* attribute uses from base type *)
match
base
,
derivation_type
with
|
Complex
{
ct_attrs
=
uses
}
,
`Extension
->
duses
|
Complex
{
ct_attrs
=
uses
}
,
`Restriction
->
let
(
&=
)
u1
u2
=
(* by name equality over attribute uses *)
(
name_of_attribute_use
u1
=
name_of_attribute_use
u2
)
in
let
l
=
List
.
filter
(
fun
use
->
not
(
List
.
exists
(
fun
u
->
u
&=
use
)
(
fst
duses
)))
(
fst
uses
)
in
merge_attribute_uses
[
duses
;(
l
,
false
)]
|
_
->
duses
...
...
@@ -398,7 +398,7 @@ let schema_of_uri uri =
|
None
->
assert
false
in
let
base
=
resolve_typ
(
_qname_attr
"base"
derivation
)
in
let
base
=
check_force
base
in
let
uses
=
parse_attribute_uses
derivation_type
base
derivation
in
let
uses
=
parse_attribute_uses
_deriv
derivation_type
base
derivation
in
(
derivation
,
derivation_type
,
base
,
uses
)
and
parse_complex_type_def
n
=
...
...
@@ -463,7 +463,7 @@ let schema_of_uri uri =
base
,
derivation_type
,
uses
,
content_type
and
parse_other_content
n
=
let
uses
=
parse_attribute_uses
`Restriction
AnyType
n
in
let
uses
=
parse_attribute_uses
n
in
let
mixed
=
bool_attr
"mixed"
n
in
let
content_type
=
match
find_particle
n
with
...
...
@@ -557,17 +557,9 @@ let schema_of_uri uri =
|
_
->
assert
false
and
parse_att_group
n
=
let
name
=
get_name
n
in
let
uses1
=
List
.
map
parse_attribute_use
(
_elems
"xsd:attribute"
n
)
in
let
uses2
=
List
.
concat
(
List
.
map
(
fun
name
->
(
resolve_att_group
name
)
.
ag_def
)
(
List
.
map
(
_qname_attr
"ref"
)
(
_elems
"xsd:attributeGroup"
n
)))
in
{
ag_name
=
name
;
ag_def
=
uses1
@
uses2
}
match
_may_qname_attr
"ref"
n
with
|
Some
v
->
resolve_att_group
v
|
None
->
{
ag_name
=
get_name
n
;
ag_def
=
parse_attribute_uses
n
}
and
parse_model_group_def
n
=
let
name
=
get_name
n
in
...
...
schema/schema_types.ml
View file @
c56184ef
...
...
@@ -90,15 +90,20 @@ and element_declaration =
elt_name
:
Ns
.
qname
;
elt_typdef
:
type_ref
;
elt_cstr
:
value_constraint
option
;
elt_nillable
:
bool
}
elt_nillable
:
bool
;
}
and
complex_type_definition
=
{
ct_uid
:
int
;
ct_name
:
Ns
.
qname
option
;
ct_typdef
:
type_definition
;
ct_deriv
:
derivation_type
;
ct_attrs
:
attribute_use
list
;
ct_content
:
content_type
}
ct_attrs
:
attribute_uses
;
ct_content
:
content_type
;
}
and
attribute_uses
=
attribute_use
list
*
bool
(* true = allow other attribs *)
and
type_definition
=
|
AnyType
...
...
@@ -122,7 +127,7 @@ type model_group_definition =
type
attribute_group_definition
=
{
ag_name
:
Ns
.
qname
;
ag_def
:
attribute_use
list
}
ag_def
:
attribute_use
s
}
type
schema
=
{
targetNamespace
:
Ns
.
t
;
...
...
schema/schema_types.mli
View file @
c56184ef
...
...
@@ -90,15 +90,20 @@ and element_declaration =
elt_name
:
Ns
.
qname
;
elt_typdef
:
type_ref
;
elt_cstr
:
value_constraint
option
;
elt_nillable
:
bool
}
elt_nillable
:
bool
;
}
and
complex_type_definition
=
{
ct_uid
:
int
;
ct_name
:
Ns
.
qname
option
;
ct_typdef
:
type_definition
;
ct_deriv
:
derivation_type
;
ct_attrs
:
attribute_use
list
;
ct_content
:
content_type
}
ct_attrs
:
attribute_uses
;
ct_content
:
content_type
;
}
and
attribute_uses
=
attribute_use
list
*
bool
(* true = allow other attribs *)
and
type_definition
=
|
AnyType
...
...
@@ -122,7 +127,7 @@ type model_group_definition =
type
attribute_group_definition
=
{
ag_name
:
Ns
.
qname
;
ag_def
:
attribute_use
list
}
ag_def
:
attribute_use
s
}
type
schema
=
{
targetNamespace
:
Ns
.
t
;
...
...
schema/schema_validator.ml
View file @
c56184ef
...
...
@@ -332,7 +332,7 @@ let next_tag ctx =
|
E_start_tag
qname
->
qname
|
_
->
raise
Not_found
let
validate_attribute_uses
attrs
attr_uses
=
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
)
...
...
@@ -340,18 +340,20 @@ let validate_attribute_uses attrs attr_uses =
let
attribs
=
ref
[]
in
List
.
iter
(
fun
(
qname
,
value
)
->
let
{
attr_decl
=
{
attr_typdef
=
st_def
};
attr_use_cstr
=
constr
}
=
try
QTable
.
find
tbl
qname
with
Not_found
->
error
(
sprintf
"Unexpected attribute: %s"
(
Ns
.
QName
.
to_string
qname
))
let
value
=
try
let
a
=
QTable
.
find
tbl
qname
in
let
value
=
validate_simple_type
a
.
attr_decl
.
attr_typdef
value
in
(
match
a
.
attr_use_cstr
with
(* check fixed constraint *)
|
Some
(
`Fixed
v
)
->
check_fixed
v
value
|
_
->
()
);
QTable
.
remove
tbl
qname
;
value
with
Not_found
->
if
anyattr
then
Value
.
string_utf8
value
else
error
(
sprintf
"Unexpected attribute: %s"
(
Ns
.
QName
.
to_string
qname
))
in
let
value
=
validate_simple_type
st_def
value
in
(
match
constr
with
(* check fixed constraint *)
|
Some
(
`Fixed
v
)
->
check_fixed
v
value
|
_
->
()
);
QTable
.
remove
tbl
qname
;
attribs
:=
(
qname
,
value
)
::
!
attribs
)
attrs
.
attrs
;
if
attrs
.
xsi_nil
then
...
...
typing/typer.ml
View file @
c56184ef
...
...
@@ -1705,9 +1705,10 @@ module Schema_converter =
rexp
regexp
(** @return a closed record *)
and
attr_uses
attr
_uses
=
and
attr_uses
(
attr
s
,
other
)
=
(* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *)
print_endline
(
"Other = "
^
(
if
other
then
"true"
else
"false"
));
let
fields
=
List
.
map
(
fun
at
->
...
...
@@ -1719,8 +1720,8 @@ module Schema_converter =
in
let
r
=
if
at
.
attr_required
then
r
else
mk
(
IOptional
r
)
in
(
LabelPool
.
mk
at
.
attr_decl
.
attr_name
,
(
r
,
None
)))
attr
_use
s
in
mk
(
IRecord
(
false
,
LabelMap
.
from_list_disj
fields
))
attrs
in
mk
(
IRecord
(
other
,
LabelMap
.
from_list_disj
fields
))
and
att_decl
att
=
let
r
=
itype
(
simple_type
att
.
attr_typdef
)
in
...
...
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