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
2c40dd58
Commit
2c40dd58
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-24 17:04:46 by afrisch] Clean
Original author: afrisch Date: 2005-02-24 17:04:46+00:00
parent
82ba4946
Changes
1
Hide whitespace changes
Inline
Side-by-side
typing/typer.ml
View file @
2c40dd58
...
...
@@ -1567,7 +1567,6 @@ module Schema_converter =
(* TODO: better approx *)
let
xsd_any_type
=
Types
.
any
(* auxiliary functions *)
let
nil_type
=
itype
Sequence
.
nil_type
...
...
@@ -1589,15 +1588,13 @@ module Schema_converter =
|
None
->
seq
min_regexp
(
PStar
base
)
let
mk_seq_derecurs
base
facets
=
match
facets
with
|
{
length
=
Some
(
v
,
_
)
}
->
Sequence
.
repet
v
(
Some
v
)
base
|
{
minLength
=
Some
(
v
,
_
);
maxLength
=
None
}
->
Sequence
.
repet
v
None
base
|
{
minLength
=
None
;
maxLength
=
Some
(
v
,
_
)
}
->
Sequence
.
repet
1
(
Some
v
)
base
|
_
->
Sequence
.
repet
1
(
Some
1
)
base
let
min
,
max
=
match
facets
with
|
{
length
=
Some
(
v
,
_
)
}
->
v
,
Some
v
|
{
minLength
=
Some
(
v
,
_
);
maxLength
=
None
}
->
v
,
None
|
{
minLength
=
None
;
maxLength
=
Some
(
v
,
_
)
}
->
1
,
Some
v
|
{
minLength
=
Some
(
a
,_
);
maxLength
=
Some
(
b
,
_
)
}
->
a
,
Some
b
|
_
->
1
,
Some
1
in
Sequence
.
repet
min
max
base
let
pcdata
=
PStar
(
PElem
(
itype
(
Types
.
char
Chars
.
any
)))
let
mix_regexp
regexp
=
...
...
@@ -1612,10 +1609,7 @@ module Schema_converter =
in
seq
pcdata
(
seq
(
aux
regexp
)
pcdata
)
(* conversion functions *)
let
loop_detect
=
ref
[]
let
rec
cd_type_of_simple_type
=
function
let
rec
simple_type
=
function
|
{
st_name
=
Some
name
}
when
Schema_builtin
.
is
name
->
Schema_builtin
.
cd_type
(
Schema_builtin
.
get
name
)
...
...
@@ -1634,25 +1628,14 @@ module Schema_converter =
(* TODO: apply facets *)
Schema_builtin
.
cd_type
(
Schema_builtin
.
of_st
st
)
|
{
st_variety
=
List
item
;
st_facets
=
facets
}
->
mk_seq_derecurs
(
cd_type_of_
simple_type
item
)
facets
mk_seq_derecurs
(
simple_type
item
)
facets
|
{
st_variety
=
Union
members
;
st_facets
=
facets
}
->
let
members
=
List
.
map
cd_type_of_
simple_type
members
in
let
members
=
List
.
map
simple_type
members
in
List
.
fold_left
(
fun
acc
x
->
Types
.
cup
x
acc
)
Types
.
empty
members
(* and cd_type_of_simple_type_ref r =
if List.memq r !loop_detect then failwith "Loop between simple types"
else
(loop_detect := r :: !loop_detect;
let res =
cd_type_of_simple_type (Schema_common.get_simple_type r)
in
loop_detect := List.tl !loop_detect;
res)
*)
let
rec
regexp_of_term
=
function
|
Model
group
->
regexp_of_model_group
group
|
Elt
decl
->
PElem
(
cd_type_of_
elt_decl
decl
)
|
Elt
decl
->
PElem
(
elt_decl
decl
)
and
regexp_of_model_group
=
function
|
Choice
l
->
...
...
@@ -1666,33 +1649,28 @@ module Schema_converter =
seq
acc
(
regexp_of_particle
particle
))
eps
l
and
regexp_of_particle
p
=
mk_len_regexp
?
min
:
(
Some
p
.
part_min
)
?
max
:
p
.
part_max
(
regexp_of_term
p
.
part_term
)
and
resolve_
complex
ct
=
and
complex
ct
=
try
Hashtbl
.
find
complex_memo
ct
.
ct_uid
with
Not_found
->
let
slot
=
delayed
noloc
in
Hashtbl
.
add
complex_memo
ct
.
ct_uid
slot
;
slot
.
desc
<-
compute_complex
ct
;
slot
.
desc
<-
ITimes
(
attr_uses
ct
.
ct_attrs
,
content
ct
.
ct_content
)
;
slot
and
compute_complex
ct
=
let
content_ast_node
=
match
ct
.
ct_content
with
|
CT_empty
->
itype
Sequence
.
nil_type
|
CT_simple
st
->
itype
(
cd_type_of_simple_type
st
)
|
CT_model
(
particle
,
mixed
)
->
let
regexp
=
regexp_of_particle
particle
in
let
regexp
=
if
mixed
then
mix_regexp
regexp
else
regexp
in
rexp
regexp
in
ITimes
(
cd_type_of_attr_uses
ct
.
ct_attrs
,
content_ast_node
);
and
content
=
function
|
CT_empty
->
itype
Sequence
.
nil_type
|
CT_simple
st
->
itype
(
simple_type
st
)
|
CT_model
(
particle
,
mixed
)
->
let
regexp
=
regexp_of_particle
particle
in
let
regexp
=
if
mixed
then
mix_regexp
regexp
else
regexp
in
rexp
regexp
(** @return a closed record *)
and
cd_type_of_
attr_uses
attr_uses
=
and
attr_uses
attr_uses
=
(* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *)
let
fields
=
...
...
@@ -1702,58 +1680,51 @@ module Schema_converter =
match
at
.
attr_use_cstr
with
|
Some
(
`Fixed
v
)
->
itype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
itype
(
cd_type_of_
simple_type
at
.
attr_decl
.
attr_typdef
)
|
_
->
itype
(
simple_type
at
.
attr_decl
.
attr_typdef
)
in
let
r
=
if
at
.
attr_required
then
r
else
mk
(
IOptional
r
)
in
(
LabelPool
.
mk
at
.
attr_decl
.
attr_name
,
(
r
,
None
)))
attr_uses
in
mk
(
IRecord
(
false
,
LabelMap
.
from_list_disj
fields
))
and
cd_type_of_
att_decl
att
=
let
r
=
itype
(
cd_type_of_
simple_type
att
.
attr_typdef
)
in
and
att_decl
att
=
let
r
=
itype
(
simple_type
att
.
attr_typdef
)
in
mk
(
IRecord
(
false
,
LabelMap
.
from_list_disj
[(
LabelPool
.
mk
att
.
attr_name
,
(
r
,
None
))]))
and
cd_type_of_
elt_decl
elt
=
and
elt_decl
elt
=
let
atom_type
=
itype
(
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
of_qname
elt
.
elt_name
)))
in
let
content
=
match
elt
.
elt_cstr
with
|
Some
(
`Fixed
v
)
->
itype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
(
match
Lazy
.
force
elt
.
elt_typdef
with
|
AnyType
->
itype
xsd_any_type
|
Simple
st
->
mk
(
ITimes
(
itype
Types
.
empty_closed_record
,
itype
(
cd_type_of_simple_type
st
)))
|
Complex
ct
->
resolve_complex
ct
)
|
Some
(
`Fixed
v
)
->
itype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
complex_type_def
(
Lazy
.
force
elt
.
elt_typdef
)
in
mk
(
IXml
(
atom_type
,
content
))
and
complex_type_def
=
function
|
AnyType
->
itype
xsd_any_type
|
Simple
st
->
itype
(
Types
.
times
(
Types
.
cons
Types
.
empty_closed_record
)
(
Types
.
cons
(
simple_type
st
)))
|
Complex
ct
->
complex
ct
let
cd_type_of_
complex_type
ct
=
mk
(
IXml
(
itype
Types
.
any
,
resolve_
complex
ct
))
let
complex_type
ct
=
mk
(
IXml
(
itype
Types
.
any
,
complex
ct
))
let
cd_type_of_model_group
g
=
rexp
(
regexp_of_model_group
g
)
let
model_group
g
=
rexp
(
regexp_of_model_group
g
)
let
typ
r
=
check_delayed
()
;
IType
.
typ_descr
r
let
typ
r
=
check_delayed
()
;
IType
.
typ_descr
r
(* Schema_converter interface implementation.
* Shadows previous definitions.
*)
let
cd_type_of_type_def
=
function
let
type_def
=
function
|
AnyType
->
xsd_any_type
|
Simple
st
->
cd_type_of_
simple_type
st
|
Complex
ct
->
typ
(
cd_type_of_
complex_type
ct
)
let
cd_type_of_
elt_decl
x
=
typ
(
cd_type_of_
elt_decl
x
)
let
cd_type_of_
att_decl
x
=
typ
(
cd_type_of_
att_decl
x
)
let
cd_type_of_
attr_uses
x
=
typ
(
cd_type_of_
attr_uses
x
)
let
cd_type_of_
model_group
x
=
typ
(
cd_type_of_
model_group
x
)
|
Simple
st
->
simple_type
st
|
Complex
ct
->
typ
(
complex_type
ct
)
let
elt_decl
x
=
typ
(
elt_decl
x
)
let
att_decl
x
=
typ
(
att_decl
x
)
let
attr_uses
x
=
typ
(
attr_uses
x
)
let
model_group
x
=
typ
(
model_group
x
)
end
let
get_schema_names
env
=
UEnv
.
fold
(
fun
n
_
acc
->
n
::
acc
)
env
.
schemas
[]
...
...
@@ -1783,27 +1754,27 @@ let load_schema schema_name uri =
List
.
iter
(* Schema types -> CDuce types *)
(
fun
type_def
->
let
name
=
Schema_common
.
name_of_type_definition
type_def
in
let
cd_type
=
Schema_converter
.
cd_type_of_
type_def
type_def
in
let
cd_type
=
Schema_converter
.
type_def
type_def
in
log_schema_component
"type"
uri
name
cd_type
;
Hashtbl
.
add
!
schema_types
(
uri
,
name
)
cd_type
)
schema
.
Schema_types
.
types
;
List
.
iter
(* Schema attributes -> CDuce types *)
(
fun
att_decl
->
let
cd_type
=
Schema_converter
.
cd_type_of_
att_decl
att_decl
in
let
cd_type
=
Schema_converter
.
att_decl
att_decl
in
let
name
=
Schema_common
.
name_of_attribute_declaration
att_decl
in
log_schema_component
"attribute"
uri
name
cd_type
;
Hashtbl
.
add
!
schema_attributes
(
uri
,
name
)
cd_type
)
schema
.
Schema_types
.
attributes
;
List
.
iter
(* Schema elements -> CDuce types *)
(
fun
elt_decl
->
let
cd_type
=
Schema_converter
.
cd_type_of_
elt_decl
elt_decl
in
let
cd_type
=
Schema_converter
.
elt_decl
elt_decl
in
let
name
=
Schema_common
.
name_of_element_declaration
elt_decl
in
log_schema_component
"element"
uri
name
cd_type
;
Hashtbl
.
add
!
schema_elements
(
uri
,
name
)
cd_type
)
schema
.
Schema_types
.
elements
;
List
.
iter
(* Schema attribute groups -> CDuce types *)
(
fun
ag
->
let
cd_type
=
Schema_converter
.
cd_type_of_
attr_uses
ag
.
ag_def
let
cd_type
=
Schema_converter
.
attr_uses
ag
.
ag_def
in
log_schema_component
"attribute group"
uri
ag
.
ag_name
cd_type
;
Hashtbl
.
add
!
schema_attribute_groups
(
uri
,
ag
.
ag_name
)
cd_type
)
...
...
@@ -1811,7 +1782,7 @@ let load_schema schema_name uri =
List
.
iter
(* Schema model groups -> CDuce types *)
(
fun
mg
->
let
cd_type
=
Schema_converter
.
cd_type_of_
model_group
mg
.
mg_def
in
Schema_converter
.
model_group
mg
.
mg_def
in
log_schema_component
"model group"
uri
mg
.
mg_name
cd_type
;
Hashtbl
.
add
!
schema_model_groups
(
uri
,
mg
.
mg_name
)
cd_type
)
schema
.
Schema_types
.
model_groups
;
...
...
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