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
f881fc81
Commit
f881fc81
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-20 21:05:15 by afrisch] Use lazy to resolve circularities
Original author: afrisch Date: 2005-02-20 21:05:16+00:00
parent
cc49ec29
Changes
7
Hide whitespace changes
Inline
Side-by-side
schema/schema_builtin.ml
View file @
f881fc81
...
...
@@ -425,11 +425,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
,
ref
(
Simple
base
))
Derived
(
Some
name
,
variety
,
facets
,
lazy
(
Simple
base
))
let
list'
name
itemname
=
let
(
name
,
itemname
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
itemname
)
in
let
(
base
,
_
,
_
)
=
QTable
.
find
builtins
itemname
in
let
base
=
ref
(
Simple
base
)
in
let
base
=
lazy
(
Simple
base
)
in
Derived
(
Some
name
,
List
base
,
no_facets
,
base
)
let
fill
()
=
(* fill "builtins" hashtbl *)
...
...
schema/schema_common.ml
View file @
f881fc81
...
...
@@ -67,13 +67,13 @@ let rec facets_of_simple_type_definition = function
|
Derived
(
_
,
_
,
facets
,
_
)
->
facets
let
rec
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
ref
(
Simple
st
))
|
(
Primitive
name
)
as
st
->
Atomic
(
lazy
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
get_simple_type
=
function
|
{
contents
=
Simple
c
}
->
c
|
{
contents
=
AnyType
}
->
Primitive
(
xsd
,
Utf8
.
mk
"anySimpleType"
)
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
...
...
@@ -82,7 +82,7 @@ let rec normalize_simple_type = function
|
Derived
(
_
,
variety
,
old_facets
,
base
)
->
Derived
(
name
,
variety
,
merge_facets
old_facets
new_facets
,
base
)
|
Primitive
_
as
st
->
let
b
=
ref
(
Simple
st
)
in
let
b
=
lazy
(
Simple
st
)
in
Derived
(
name
,
Atomic
b
,
new_facets
,
b
))
|
st
->
st
...
...
@@ -103,10 +103,10 @@ 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
!
elt_decl_ref
|
(
_
,
_
,
Elt
elt_decl_ref
,
_
)
->
name_of_element_declaration
(
Lazy
.
force
elt_decl_ref
)
|
_
->
assert
false
let
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
ref
(
Simple
st
))
|
(
Primitive
name
)
as
st
->
Atomic
(
lazy
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
simple_type_of_type
=
function
|
Simple
s
->
s
...
...
@@ -117,7 +117,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
(
ref
(
Simple
st
))
|
Simple
st
->
CT_simple
(
lazy
(
Simple
st
))
let
iter_types
schema
f
=
List
.
iter
f
schema
.
types
let
iter_attributes
schema
f
=
List
.
iter
f
schema
.
attributes
...
...
schema/schema_parser.ml
View file @
f881fc81
...
...
@@ -13,6 +13,7 @@ let validation_error s = raise (XSD_validation_error s)
let
xsd
=
Schema_xml
.
xsd
(*
let fake_type_def =
Complex
{ ct_uid = -1;
...
...
@@ -28,6 +29,8 @@ let fake_elt_decl =
elt_cstr = None }
let is_fake_type_def = (==) fake_type_def
let is_fake_elt_decl = (==) fake_elt_decl
*)
let
(
^^
)
x
y
=
Utf8
.
concat
x
y
(* element and complex type constructors which take cares of unique id *)
...
...
@@ -56,7 +59,7 @@ let split s = pcre_split ~rex:space_RE s
let
unqualify
s
=
snd
(
Ns
.
split_qname
s
)
let
hashtbl_deref
tbl
=
QTable
.
fold
(
fun
_
v
acc
->
!
v
::
acc
)
tbl
[]
let
hashtbl_deref
tbl
=
QTable
.
fold
(
fun
_
v
acc
->
(
Lazy
.
force
v
)
::
acc
)
tbl
[]
let
hashtbl_values
tbl
=
QTable
.
fold
(
fun
_
v
acc
->
v
::
acc
)
tbl
[]
let
parse_facets
base
n
=
...
...
@@ -154,8 +157,8 @@ let register_builtins typs =
(
fun
st_def
->
let
type_def
=
Simple
st_def
in
let
name
=
name_of_type_definition
type_def
in
QTable
.
replace
typs
name
(
ref
type_def
));
QTable
.
replace
typs
(
xsd
,
Utf8
.
mk
"anyType"
)
(
ref
AnyType
)
QTable
.
replace
typs
name
(
lazy
type_def
));
QTable
.
replace
typs
(
xsd
,
Utf8
.
mk
"anyType"
)
(
lazy
AnyType
)
(* Main parsing function *)
let
schema_of_uri
uri
=
...
...
@@ -207,12 +210,12 @@ let schema_of_uri uri =
|
None
->
None
in
let
get_name
n
=
(
targetNamespace
,
_attr
"name"
n
)
in
let
rec
resolve_typ
qname
=
let
rec
resolve_typ
qname
:
Schema_types
.
type_definition
lazy_t
=
try
QTable
.
find
typs
qname
with
Not_found
->
failwith
(
"Cannot find type "
^
(
Ns
.
QName
.
to_string
qname
))
and
resolve_simple_typ
qname
=
and
resolve_simple_typ
qname
:
Schema_types
.
type_definition
lazy_t
=
resolve_typ
qname
and
resolve_elt
qname
=
...
...
@@ -243,16 +246,16 @@ let schema_of_uri uri =
match
_may_elem
"xsd:list"
n
with
|
Some
list
->
let
items
=
find_item_type
list
in
Simple
(
Derived
(
name
,
List
items
,
no_facets
,
ref
(
Simple
anySimpleType
)))
Simple
(
Derived
(
name
,
List
items
,
no_facets
,
lazy
(
Simple
anySimpleType
)))
|
None
->
match
_may_elem
"xsd:union"
n
with
|
Some
union
->
let
members
=
find_member_types
union
in
Simple
(
Derived
(
name
,
Union
members
,
no_facets
,
ref
(
Simple
anySimpleType
)))
Simple
(
Derived
(
name
,
Union
members
,
no_facets
,
lazy
(
Simple
anySimpleType
)))
|
None
->
assert
false
failwith
(
"Unknown variety for simpleType at line "
^
(
string_of_int
(
_line
n
))
^
" uri = "
^
uri
)
and
parse_simple_type
n
=
ref
(
parse_simple_type_def
n
)
lazy
(
parse_simple_type_def
n
)
(* look for a simple type def: try attribute "base", try "simpleType" child,
* fail *)
...
...
@@ -295,10 +298,15 @@ let schema_of_uri uri =
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
}
}
->
lazy
(
match
Lazy
.
force
type_def
with
|
Simple
st_def
->
validate_simple_type
st_def
v
|
Complex
{
ct_content
=
CT_simple
c
}
->
(
match
Lazy
.
force
c
with
|
Simple
st_def
->
validate_simple_type
st_def
v
|
_
->
validate_simple_type
(
Primitive
(
xsd
,
Utf8
.
mk
"string"
))
v
)
|
_
->
validate_simple_type
(
Primitive
(
xsd
,
Utf8
.
mk
"string"
))
v
)
...
...
@@ -313,7 +321,7 @@ let schema_of_uri uri =
|
None
->
match
_may_qname_attr
"type"
n
with
|
Some
v
->
resolve_simple_typ
v
|
None
->
ref
(
Simple
anySimpleType
)
|
None
->
lazy
(
Simple
anySimpleType
)
and
parse_att_decl
global
n
=
let
local
=
_attr
"name"
n
in
...
...
@@ -388,9 +396,9 @@ let schema_of_uri uri =
|
Some
v
->
(
v
,
`Extension
)
|
None
->
assert
false
in
let
base
=
resolve_typ
(
_qname_attr
"base"
derivation
)
in
assert
(
!
base
!
=
fake_type_def
);
let
uses
=
parse_attribute_uses
derivation_type
!
base
derivation
in
(
derivation
,
derivation_type
,
!
base
,
uses
)
let
base
=
Lazy
.
force
base
in
let
uses
=
parse_attribute_uses
derivation_type
base
derivation
in
(
derivation
,
derivation_type
,
base
,
uses
)
and
parse_complex_type_def
n
=
let
name
=
may_name
n
in
...
...
@@ -404,7 +412,7 @@ let schema_of_uri uri =
in
Complex
(
complex
name
base
derivation_type
uses
content_type
)
and
parse_complex_type
n
=
ref
(
parse_complex_type_def
n
)
lazy
(
parse_complex_type_def
n
)
and
parse_simple_content
n
content
=
let
derivation
,
derivation_type
,
base
,
uses
=
get_derivation
content
in
...
...
@@ -415,10 +423,10 @@ let schema_of_uri uri =
match
_may_elem
"xsd:simpleType"
derivation
with
|
Some
s
->
parse_simple_type
s
|
None
->
base
in
CT_simple
(
ref
(
Simple
(
Derived
(
None
,
Restrict
,
parse_facets
base
n
,
base
))))
CT_simple
(
lazy
(
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
)
|
`Extension
,
(
Simple
_
as
st
)
->
CT_simple
(
lazy
st
)
|
_
->
assert
false
in
base
,
derivation_type
,
uses
,
content_type
...
...
@@ -490,7 +498,7 @@ let schema_of_uri uri =
|
None
->
match
_may_qname_attr
"type"
n
with
|
Some
v
->
resolve_typ
v
|
None
->
ref
AnyType
|
None
->
lazy
AnyType
and
parse_particle
n
=
let
min
,
max
=
parse_min_max
n
in
...
...
@@ -501,7 +509,7 @@ let schema_of_uri uri =
|
Some
ref
->
(
resolve_elt
ref
,
[
Some
ref
])
|
None
->
let
decl
=
parse_elt_decl
false
n
in
(
ref
decl
,
[
Some
(
name_of_element_declaration
decl
)
])
(
lazy
decl
,
[
Some
(
name_of_element_declaration
decl
)
])
in
(
min
,
max
,
Elt
elt_decl
,
first
)
|
"xsd:group"
->
...
...
@@ -553,18 +561,15 @@ let schema_of_uri uri =
let
name
=
get_name
n
in
if
(
QTable
.
mem
elts
name
)
then
validation_error
(
"Redefinition of element "
^
Ns
.
QName
.
to_string
name
);
let
r
=
ref
fake_elt_decl
in
QTable
.
add
elts
name
r
;
todo
:=
(
fun
()
->
r
:=
parse_elt_decl
true
n
)
::
!
todo
let
l
=
lazy
(
parse_elt_decl
true
n
)
in
QTable
.
add
elts
name
l
|
(
"xsd:simpleType"
|
"xsd:complexType"
)
as
s
->
let
name
=
get_name
n
in
if
(
QTable
.
mem
typs
name
)
then
validation_error
(
"Redefinition of type "
^
Ns
.
QName
.
to_string
name
);
let
r
=
ref
fake_type_def
in
QTable
.
add
typs
name
r
;
let
f
=
if
s
=
"xsd:simpleType"
then
parse_simple_type_def
else
parse_complex_type_def
in
todo
:=
(
fun
()
->
r
:=
f
n
)
::
!
todo
let
l
=
if
s
=
"xsd:simpleType"
then
lazy
(
parse_simple_type_def
n
)
else
lazy
(
parse_complex_type_def
n
)
in
QTable
.
add
typs
name
l
|
"xsd:attribute"
->
let
name
=
get_name
n
in
QTable
.
add
attr_elems
name
n
;
...
...
schema/schema_types.ml
View file @
f881fc81
...
...
@@ -42,7 +42,7 @@ type facets = {
and
value_ref
=
Value
.
t
Lazy
.
t
and
value_constraint
=
[
`Fixed
of
value_ref
|
`Default
of
value_ref
]
and
type_ref
=
type_definition
ref
and
type_ref
=
type_definition
Lazy
.
t
and
simple_type_definition
=
|
Primitive
of
Ns
.
qname
...
...
@@ -74,7 +74,7 @@ and attribute_use =
and
first
=
Ns
.
QName
.
t
option
list
and
term
=
|
Elt
of
element_declaration
ref
|
Elt
of
element_declaration
Lazy
.
t
|
Model
of
model_group
and
model_group
=
...
...
schema/schema_types.mli
View file @
f881fc81
...
...
@@ -42,7 +42,7 @@ type facets = {
and
value_ref
=
Value
.
t
Lazy
.
t
and
value_constraint
=
[
`Fixed
of
value_ref
|
`Default
of
value_ref
]
and
type_ref
=
type_definition
ref
and
type_ref
=
type_definition
Lazy
.
t
and
simple_type_definition
=
|
Primitive
of
Ns
.
qname
...
...
@@ -74,7 +74,7 @@ and attribute_use =
and
first
=
Ns
.
QName
.
t
option
list
and
term
=
|
Elt
of
element_declaration
ref
|
Elt
of
element_declaration
Lazy
.
t
|
Model
of
model_group
and
model_group
=
...
...
schema/schema_validator.ml
View file @
f881fc81
...
...
@@ -324,7 +324,7 @@ and validate_type context = function
|
Complex
ct_def
->
validate_complex_type
context
ct_def
and
validate_type_ref
context
x
=
validate_type
context
!
x
validate_type
context
(
Lazy
.
force
x
)
(** @return Value.t * Value.t (* attrs, content *) *)
and
validate_complex_type
context
ct
=
...
...
@@ -394,7 +394,7 @@ and validate_particle context particle =
(** @return Value.t list *)
and
validate_term
context
term
=
match
term
with
|
Elt
elt_decl_ref
->
[
validate_element
context
!
elt_decl_ref
]
|
Elt
elt_decl_ref
->
[
validate_element
context
(
Lazy
.
force
elt_decl_ref
)
]
|
Model
model_group
->
validate_model_group
context
model_group
(** @return (Value.t list * Utf8.t)
...
...
typing/typer.ml
View file @
f881fc81
...
...
@@ -1578,6 +1578,7 @@ module Schema_converter =
PRegexp
(
mk_len_regexp
~
max
:
v
base
)
|
_
->
PRegexp
base
(* This is not correct ! *)
let
mix_regexp
=
let
pcdata
=
PStar
(
PElem
(
PType
Builtin_defs
.
string
))
in
let
rec
aux
=
function
...
...
@@ -1594,7 +1595,7 @@ module Schema_converter =
simplify
(
PSeq
(
x2
,
y
))
|
re
->
re
in
fun
regexp
->
simplify
(
PSeq
(
pcdata
,
aux
regexp
))
fun
regexp
->
(*
simplify
*)
(
PSeq
(
pcdata
,
aux
regexp
))
(* conversion functions *)
...
...
@@ -1613,17 +1614,19 @@ module Schema_converter =
|
Derived
(
_
,
_
,
({
minInclusive
=
Some
_
}
as
facets
)
,
_
)
|
Derived
(
_
,
_
,
({
minExclusive
=
Some
_
}
as
facets
)
,
_
)
->
PType
(
Types
.
interval
(
Schema_common
.
get_interval
facets
))
|
Derived
(
_
,
Atomic
{
contents
=
Simple
(
Primitive
name
)}
,
facets
,
_
)
->
if
is_xsd
name
"string"
||
is_xsd
name
"anyURI"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PType
Builtin_defs
.
char
))
facets
else
if
is_xsd
name
"hexBinary"
||
is_xsd
name
"base64Binary"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PType
Builtin_defs
.
char_latin1
))
facets
else
(* no other interesting facet *)
PType
(
Schema_builtin
.
cd_type_of_builtin
name
)
|
Derived
(
_
,
Atomic
_
,
facets
,
_
)
->
assert
false
|
Derived
(
_
,
Atomic
c
,
facets
,
_
)
->
(
match
Lazy
.
force
c
with
|
Simple
(
Primitive
name
)
->
if
is_xsd
name
"string"
||
is_xsd
name
"anyURI"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PType
Builtin_defs
.
char
))
facets
else
if
is_xsd
name
"hexBinary"
||
is_xsd
name
"base64Binary"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PType
Builtin_defs
.
char_latin1
))
facets
else
(* no other interesting facet *)
PType
(
Schema_builtin
.
cd_type_of_builtin
name
)
|
_
->
assert
false
)
|
Derived
(
_
,
List
item
,
facets
,
_
)
->
mk_seq_derecurs
~
base
:
(
PElem
(
cd_type_of_simple_type_ref
~
schema
item
))
facets
...
...
@@ -1649,7 +1652,7 @@ module Schema_converter =
let
rec
regexp_of_term
~
schema
=
function
|
Model
group
->
regexp_of_model_group
~
schema
group
|
Elt
decl
->
PElem
(
cd_type_of_elt_decl
~
schema
!
decl
)
|
Elt
decl
->
PElem
(
cd_type_of_elt_decl
~
schema
(
Lazy
.
force
decl
)
)
and
regexp_of_model_group
~
schema
=
function
|
All
[]
|
Choice
[]
|
Sequence
[]
->
PEpsilon
...
...
@@ -1694,9 +1697,10 @@ module Schema_converter =
|
CT_empty
->
PType
Sequence
.
nil_type
|
CT_simple
st
->
cd_type_of_simple_type_ref
~
schema
st
|
CT_model
(
particle
,
mixed
)
->
if
mixed
then
Value
.
failwith'
"Mixed content models aren't supported"
;
(*
if mixed then
Value.failwith' "Mixed content models aren't supported";
*)
let
regexp
=
regexp_of_particle
~
schema
particle
in
let
regexp
=
if
mixed
then
mix_regexp
regexp
else
regexp
in
PRegexp
regexp
in
slot
.
pdescr
<-
...
...
@@ -1736,7 +1740,7 @@ module Schema_converter =
let
v
=
Lazy
.
force
v
in
PType
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
(
match
!
(
elt
.
elt_typdef
)
with
(
match
Lazy
.
force
elt
.
elt_typdef
with
|
AnyType
->
PType
(
Schema_builtin
.
cd_type_of_builtin
(
xsd
,
U
.
mk
"anyType"
))
|
Simple
st
->
...
...
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