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
12d96cde
Commit
12d96cde
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-03-13 14:54:00 by afrisch] Clean
Original author: afrisch Date: 2005-03-13 14:54:00+00:00
parent
6788640d
Changes
5
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
12d96cde
...
...
@@ -131,9 +131,7 @@ SCHEMA_OBJS = \
schema/schema_builtin.cmo
\
schema/schema_validator.cmo
\
schema/schema_parser.cmo
\
NEW_SCHEMA_OBJS
=
\
schema/schema_components.cmo schema/schema_import.cmo
\
schema/schema_converter.cmo
OBJECTS
=
\
driver/config.cmo
\
...
...
@@ -154,13 +152,14 @@ OBJECTS = \
runtime/value.cmo
\
\
parser/location.cmo parser/url.cmo
\
$(SCHEMA_OBJS)
\
\
\
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo
\
\
types/externals.cmo
\
typing/typed.cmo typing/typer.cmo
\
\
$(SCHEMA_OBJS)
\
\
runtime/load_xml.cmo runtime/run_dispatch.cmo
\
runtime/explain.cmo
\
runtime/print_xml.cmo runtime/eval.cmo
\
...
...
@@ -222,8 +221,9 @@ OBJECTS += $(CQL_OBJECTS_RUN)
OBJECTS
+=
driver/run.cmo
CDUCE
=
$(OBJECTS)
driver/start.cmo
ALL_OBJECTS
=
$(OBJECTS)
$(NEW_SCHEMA_OBJS)
\
driver/start.cmo driver/examples.cmo driver/webiface.cmo driver/evaluator.cmo
\
ALL_OBJECTS
=
$(OBJECTS)
\
driver/start.cmo driver/examples.cmo
\
driver/webiface.cmo driver/evaluator.cmo
\
tools/validate.cmo
\
$(ML_INTERFACE_OBJS)
parser/cduce_curl.cmo
\
parser/cduce_netclient.cmo
\
...
...
@@ -239,11 +239,6 @@ cduce: $(CDUCE:.cmo=.$(EXTENSION))
@
echo
"Build
$@
"
$(HIDE)$(LINK)
$(INCLUDES)
-o
$@
$^
$(EXTRA_LINK_OPTS)
test_schema
:
$(OBJECTS:.cmo=.$(EXTENSION)) $(NEW_SCHEMA_OBJS:.cmo=.$(EXTENSION))
@
echo
"Build
$@
"
$(HIDE)$(LINK)
$(INCLUDES)
-o
$@
$^
$(EXTRA_LINK_OPTS)
cduce_packed.ml
:
$(CDUCE:.cmo=.ml)
rm
-f
cduce_packed.ml
ocaml tools/pack.ml
$^
>
cduce_packed.ml
...
...
depend
View file @
12d96cde
...
...
@@ -96,10 +96,10 @@ schema/schema_types.cmo: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/encodings.cmi
parser/location.cmi misc/ns
.cmi \
schema/schema_pcre.cmi
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx
parser/location.cmx misc/ns
.cmx \
schema/schema_pcre.cmx
schema/schema_xml.cmi
schema/schema_xml.cmo: misc/encodings.cmi
misc/ns.cmi schema/schema_pcre
.cmi \
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx
misc/ns.cmx schema/schema_pcre
.cmx \
schema/schema_xml.cmi
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
misc/ns.cmi schema/schema_pcre.cmi schema/schema_types.cmi \
schema/schema_xml.cmi types/types.cmi runtime/value.cmi \
...
...
@@ -155,21 +155,23 @@ typing/typed.cmo: types/ident.cmo parser/location.cmi misc/ns.cmi \
typing/typed.cmx: types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi misc/encodings.cmi types/externals.cmi misc/html.cmi \
types/ident.cmo parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi \
schema/schema_parser.cmi schema/schema_types.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi types/sequence.cmi \
misc/serialize.cmi typing/typed.cmo types/types.cmi runtime/value.cmi \
typing/typer.cmi
types/chars.cmi types/externals.cmi misc/html.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi types/sequence.cmi \
misc/serialize.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx misc/encodings.cmx types/externals.cmx misc/html.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx \
schema/schema_parser.cmx schema/schema_types.cmx \
types/chars.cmx types/externals.cmx misc/html.cmx types/ident.cmx \
parser/location.cmx misc/ns.cmx types/patterns.cmx types/sequence.cmx \
misc/serialize.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
schema/schema_converter.cmo: types/atoms.cmi types/builtin_defs.cmi \
types/ident.cmo misc/ns.cmi schema/schema_builtin.cmi \
schema/schema_common.cmi schema/schema_parser.cmi schema/schema_types.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi types/sequence.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
schema/schema_converter.cmx: types/atoms.cmx types/builtin_defs.cmx \
types/ident.cmx misc/ns.cmx schema/schema_builtin.cmx \
schema/schema_common.cmx schema/schema_parser.cmx schema/schema_types.cmx \
schema/schema_validator.cmx schema/schema_xml.cmx types/sequence.cmx \
misc/serialize.cmx typing/typed.cmx types/types.cmx runtime/value.cmx \
typing/typer.cmi
typing/typer.cmx types/types.cmx runtime/value.cmx
runtime/load_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi parser/url.cmi runtime/value.cmi \
runtime/load_xml.cmi
...
...
@@ -189,13 +191,11 @@ runtime/explain.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx runtime/run_dispatch.cmx \
types/types.cmx runtime/value.cmx runtime/explain.cmi
runtime/print_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
types/intervals.cmi parser/location.cmi misc/ns.cmi \
schema/schema_builtin.cmi types/sequence.cmi runtime/value.cmi \
runtime/print_xml.cmi
types/intervals.cmi misc/ns.cmi schema/schema_builtin.cmi \
types/sequence.cmi runtime/value.cmi runtime/print_xml.cmi
runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_builtin.cmx types/sequence.cmx runtime/value.cmx \
runtime/print_xml.cmi
types/intervals.cmx misc/ns.cmx schema/schema_builtin.cmx \
types/sequence.cmx runtime/value.cmx runtime/print_xml.cmi
runtime/eval.cmo: runtime/explain.cmi types/ident.cmo compile/lambda.cmi \
misc/ns.cmi types/patterns.cmi runtime/run_dispatch.cmi \
schema/schema_common.cmi typing/typer.cmi types/types.cmi \
...
...
@@ -270,18 +270,16 @@ ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
driver/librarian.cmx parser/location.cmx ocamliface/mltypes.cmx \
misc/ns.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
ocamliface/mlstub.cmi
parser/cduce_curl.cmo: driver/config.cmi parser/url.cmi
parser/cduce_curl.cmx: driver/config.cmx parser/url.cmx
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_pxp.cmi
parser/cduce_netclient.cmo: driver/config.cmi parser/location.cmi \
parser/url.cmi
parser/cduce_netclient.cmx: driver/config.cmx parser/location.cmx \
parser/url.cmx
runtime/cduce_expat.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi parser/url.cmi runtime/cduce_expat.cmi
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_expat.cmi
runtime/cduce_expat.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx parser/url.cmx runtime/cduce_expat.cmi
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_expat.cmi
query/query_aggregates.cmo: types/builtin_defs.cmi types/intervals.cmi \
compile/operators.cmi types/sequence.cmi runtime/value.cmi
query/query_aggregates.cmx: types/builtin_defs.cmx types/intervals.cmx \
...
...
@@ -329,11 +327,17 @@ parser/cduce_netclient.cmo: driver/config.cmi parser/location.cmi \
parser/cduce_netclient.cmx: driver/config.cmx parser/location.cmx \
parser/url.cmx
runtime/cduce_expat.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi parser/url.cmi runtime/cduce_expat.cmi
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_expat.cmi
runtime/cduce_expat.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx parser/url.cmx runtime/cduce_expat.cmi
schema/schema_types.cmi: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_expat.cmi
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_pxp.cmi
misc/pool.cmi: misc/custom.cmo
misc/encodings.cmi: misc/custom.cmo misc/serialize.cmi
misc/bool.cmi: misc/custom.cmo
...
...
schema/schema_converter.ml
0 → 100644
View file @
12d96cde
open
Ident
open
Schema_types
open
Schema_common
open
Schema_validator
open
Encodings
open
Typer
.
IType
let
xsd
=
Schema_xml
.
xsd
let
is_xsd
(
ns
,
l
)
local
=
(
Ns
.
equal
ns
xsd
)
&&
(
String
.
compare
(
Utf8
.
get_str
l
)
local
=
0
)
let
complex_memo
=
Hashtbl
.
create
213
let
rexp
re
=
rexp
(
simplify_regexp
re
)
(* TODO: better approx *)
let
xsd_any_type
=
Types
.
any
let
nil_type
=
itype
Sequence
.
nil_type
let
mk_len_regexp
?
min
?
max
base
=
let
rec
repeat_regexp
re
=
function
|
0
->
eps
|
n
->
seq
re
(
repeat_regexp
re
(
pred
n
))
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
|
0
->
acc
|
n
->
aux
(
alt
eps
(
seq
base
acc
))
(
pred
n
)
in
seq
min_regexp
(
aux
eps
(
max
-
min
))
|
None
->
seq
min_regexp
(
star
base
)
let
mk_seq_derecurs
base
facets
=
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
xsi_nil_field_map
=
LabelMap
.
singleton
xsi_nil_label
(
Types
.
cons
Builtin_defs
.
true_type
)
let
xsi_nil_field_map'
=
LabelMap
.
singleton
xsi_nil_label
(
itype
Builtin_defs
.
true_type
,
None
)
let
rec
simple_type
=
function
|
{
st_name
=
Some
name
}
when
Schema_builtin
.
is
name
->
Schema_builtin
.
cd_type
(
Schema_builtin
.
get
name
)
|
{
st_variety
=
Atomic
st
}
->
(* TODO: apply facets *)
Schema_builtin
.
cd_type
(
Schema_builtin
.
of_st
st
)
|
{
st_variety
=
List
item
;
st_facets
=
facets
}
->
mk_seq_derecurs
(
simple_type
item
)
facets
|
{
st_variety
=
Union
members
;
st_facets
=
facets
}
->
let
members
=
List
.
map
simple_type
members
in
List
.
fold_left
(
fun
acc
x
->
Types
.
cup
x
acc
)
Types
.
empty
members
let
rec
regexp_of_term
=
function
|
Model
group
->
regexp_of_model_group
group
|
Elt
decl
->
elem
(
elt_decl
decl
)
|
Wildcard
w
->
elem
(
wildcard
w
)
and
wildcard
w
=
itype
(
Builtin_defs
.
any_xml_with_tag
w
.
wild_first
)
and
regexp_of_model_group
=
function
|
Choice
l
->
List
.
fold_left
(
fun
acc
particle
->
alt
acc
(
regexp_of_particle
particle
))
emp
l
|
All
l
|
Sequence
l
->
List
.
fold_left
(
fun
acc
particle
->
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
get_complex
ct
=
try
Hashtbl
.
find
complex_memo
ct
.
ct_uid
with
Not_found
->
let
slot
=
delayed
()
in
let
attrs
=
attr_uses
ct
.
ct_attrs
in
let
r
=
times
attrs
slot
in
Hashtbl
.
add
complex_memo
ct
.
ct_uid
r
;
link
slot
(
content
ct
.
ct_content
);
r
and
complex
nil
ct
=
let
c
=
get_complex
ct
in
if
nil
then
let
(
o
,
fields
,
content
)
=
get_ct
c
in
let
fields
=
LabelMap
.
union_disj
fields
xsi_nil_field_map'
in
ior
c
(
times
(
record
o
fields
)
(
itype
Sequence
.
nil_type
))
else
c
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
rexp
(
if
mixed
then
mix
regexp
else
regexp
)
(** @return a closed record *)
and
attr_uses
(
attrs
,
other
)
=
(* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *)
let
fields
=
List
.
map
(
fun
at
->
let
r
=
match
at
.
attr_use_cstr
with
|
Some
(
`Fixed
v
)
->
itype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
itype
(
simple_type
at
.
attr_decl
.
attr_typdef
)
in
let
r
=
if
at
.
attr_required
then
r
else
optional
r
in
(
LabelPool
.
mk
at
.
attr_decl
.
attr_name
,
(
r
,
None
)))
attrs
in
record
other
(
LabelMap
.
from_list_disj
fields
)
and
att_decl
att
=
let
r
=
itype
(
simple_type
att
.
attr_typdef
)
in
record
false
(
LabelMap
.
from_list_disj
[(
LabelPool
.
mk
att
.
attr_name
,
(
r
,
None
))])
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
,
elt
.
elt_nillable
with
|
Some
(
`Fixed
_
)
,
true
->
failwith
"Fixed value constraint and nillable are incompatible"
|
Some
(
`Fixed
v
)
,
false
->
itype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
,
nil
->
complex_type_def
nil
(
Lazy
.
force
elt
.
elt_typdef
)
in
xml
atom_type
content
and
complex_type_def
nil
=
function
|
AnyType
->
itype
(
Types
.
times
(
Types
.
cons
Types
.
empty_open_record
)
(
Types
.
cons
xsd_any_type
))
|
Simple
st
->
let
nonnil
=
Types
.
times
(
Types
.
cons
Types
.
empty_closed_record
)
(
Types
.
cons
(
simple_type
st
))
in
let
t
=
if
nil
then
Types
.
cup
nonnil
(
Types
.
times
(
Types
.
cons
(
Types
.
record'
(
false
,
xsi_nil_field_map
)))
(
Types
.
cons
Sequence
.
nil_type
))
else
nonnil
in
itype
t
|
Complex
ct
->
complex
nil
ct
let
complex_type
ct
=
xml
(
itype
Types
.
any
)
(
complex
false
ct
)
let
model_group
g
=
rexp
(
regexp_of_model_group
g
)
let
type_def
=
function
|
AnyType
->
xsd_any_type
|
Simple
st
->
simple_type
st
|
Complex
ct
->
get_type
(
complex_type
ct
)
let
elt_decl
x
=
get_type
(
elt_decl
x
)
let
att_decl
x
=
get_type
(
att_decl
x
)
let
attr_uses
x
=
get_type
(
attr_uses
x
)
let
model_group
x
=
get_type
(
model_group
x
.
mg_def
)
let
attr_group
ag
=
attr_uses
ag
.
ag_def
let
load_schema
schema_name
uri
=
let
log_schema_component
kind
name
cd_type
=
if
not
(
Schema_builtin
.
is
name
)
then
begin
Types
.
Print
.
register_global
(
Types
.
CompUnit
.
mk
schema_name
)
name
cd_type
;
Format
.
fprintf
Format
.
std_formatter
"Registering schema %s: %a@."
kind
Ns
.
QName
.
print
name
;
end
in
let
env
=
ref
Env
.
empty
in
let
defs
kind
name
cd_type
v
lst
=
List
.
iter
(
fun
def
->
let
name
=
name
def
in
let
cd_type
=
cd_type
def
in
log_schema_component
kind
name
cd_type
;
env
:=
Env
.
add
(
Ident
.
ident
name
)
(
cd_type
,
v
def
)
!
env
)
lst
in
let
schema
=
Schema_parser
.
schema_of_uri
uri
in
(* defs "attribute" (fun a -> a.attr_name) att_decl
(fun _ _ -> assert false) schema.attributes; *)
defs
"attribute group"
(
fun
ag
->
ag
.
ag_name
)
attr_group
validate_attribute_group
schema
.
attribute_groups
;
defs
"model group"
(
fun
mg
->
mg
.
mg_name
)
model_group
validate_model_group
schema
.
model_groups
;
defs
"type"
name_of_type_definition
type_def
validate_type
schema
.
types
;
defs
"element"
(
fun
e
->
e
.
elt_name
)
elt_decl
validate_element
schema
.
elements
;
!
env
let
()
=
Typer
.
load_schema
:=
load_schema
typing/typer.ml
View file @
12d96cde
(* TODO:
- check whether it is worth using recursive hash-consing internally
*)
open
Location
open
Ast
open
Ident
...
...
@@ -27,15 +23,12 @@ exception WrongLabel of Types.descr * label
exception
UnboundId
of
id
*
bool
exception
UnboundExtId
of
Types
.
CompUnit
.
t
*
id
exception
Error
of
string
exception
Warning
of
string
*
Types
.
t
let
raise_loc
loc
exn
=
raise
(
Location
(
loc
,
`Full
,
exn
))
let
raise_loc_str
loc
ofs
exn
=
raise
(
Location
(
loc
,
`Char
ofs
,
exn
))
let
error
loc
msg
=
raise_loc
loc
(
Error
msg
)
type
item
=
|
Type
of
Types
.
t
|
Val
of
Types
.
t
...
...
@@ -53,17 +46,17 @@ type t = {
cu
:
ext
UEnv
.
t
;
}
let
hash
_
=
failwith
"Typer.hash"
let
compare
_
_
=
failwith
"Typer.compare"
let
dump
ppf
_
=
failwith
"Typer.dump"
let
equal
_
_
=
failwith
"Typer.equal"
let
check
_
=
failwith
"Typer.check"
let
load_schema
=
ref
(
fun
_
_
->
assert
false
)
let
from_comp_unit
=
ref
(
fun
_
->
assert
false
)
let
has_comp_unit
=
ref
(
fun
_
->
assert
false
)
let
has_ocaml_unit
=
ref
(
fun
_
->
false
)
let
has_static_external
=
ref
(
fun
_
->
assert
false
)
let
load_
schema
_fwd
=
ref
(
fun
x
uri
->
assert
false
)
let
schema
s
=
Hashtbl
.
create
13
let
type_schema
env
x
uri
=
!
load_schema_fwd
x
uri
;
if
not
(
Hashtbl
.
mem
schemas
uri
)
then
Hashtbl
.
add
schemas
uri
(
!
load_schema
x
uri
);
{
env
with
cu
=
UEnv
.
add
x
(
ESchema
uri
)
env
.
cu
}
(* TODO: filter out builtin defs ? *)
...
...
@@ -76,10 +69,12 @@ let serialize s env =
Ns
.
serialize_table
s
env
.
ns
;
let
schs
=
UEnv
.
fold
(
fun
name
cu
accu
->
match
cu
with
ESchema
uri
->
(
name
,
uri
)
::
accu
|
_
->
accu
)
UEnv
.
fold
(
fun
name
cu
accu
->
match
cu
with
ESchema
uri
->
(
name
,
uri
)
::
accu
|
_
->
accu
)
env
.
cu
[]
in
Serialize
.
Put
.
list
(
Serialize
.
Put
.
pair
U
.
serialize
Serialize
.
Put
.
string
)
s
schs
Serialize
.
Put
.
list
(
Serialize
.
Put
.
pair
U
.
serialize
Serialize
.
Put
.
string
)
s
schs
let
deserialize_item
s
=
match
Serialize
.
Get
.
bits
1
s
with
|
0
->
Type
(
Types
.
deserialize
s
)
...
...
@@ -87,7 +82,8 @@ let deserialize_item s = match Serialize.Get.bits 1 s with
|
_
->
assert
false
let
deserialize
s
=
let
ids
=
Serialize
.
Get
.
env
Id
.
deserialize
deserialize_item
Env
.
add
Env
.
empty
s
in
let
ids
=
Serialize
.
Get
.
env
Id
.
deserialize
deserialize_item
Env
.
add
Env
.
empty
s
in
let
ns
=
Ns
.
deserialize_table
s
in
let
schs
=
Serialize
.
Get
.
list
...
...
@@ -103,12 +99,6 @@ let empty_env = {
cu
=
UEnv
.
empty
;
}
let
from_comp_unit
=
ref
(
fun
(
cu
:
Types
.
CompUnit
.
t
)
->
assert
false
)
let
has_comp_unit
=
ref
(
fun
cu
->
assert
false
)
let
has_ocaml_unit
=
ref
(
fun
cu
->
false
)
let
has_static_external
=
ref
(
fun
_
->
assert
false
)
let
enter_cu
x
cu
env
=
{
env
with
cu
=
UEnv
.
add
x
(
ECDuce
cu
)
env
.
cu
}
...
...
@@ -232,14 +222,16 @@ let rec const env loc = function
the internal form *)
(* Schema *)
(* uri -> schema binding *)
let
schemas
=
Hashtbl
.
create
13
let
get_schema_names
env
=
UEnv
.
fold
(
fun
n
cu
acc
->
match
cu
with
ESchema
_
->
n
::
acc
|
_
->
acc
)
env
.
cu
[]
let
find_schema_component
uri
name
=
Env
.
find
(
Ident
.
ident
name
)
(
Hashtbl
.
find
schemas
uri
)
let
get_schema_validator
uri
name
=
snd
(
find_schema_component
uri
name
)
let
find_schema_descr
uri
(
name
:
Ns
.
qname
)
=
try
fst
(
find_schema_component
uri
name
)
with
Not_found
->
...
...
@@ -624,6 +616,11 @@ module IType = struct
if
(
p1
.
desc
==
iempty
.
desc
)
||
(
p2
.
desc
==
iempty
.
desc
)
then
iempty
else
mk
(
IAnd
(
p1
,
p2
))
let
times
x
y
=
mk
(
ITimes
(
x
,
y
))
let
xml
x
y
=
mk
(
IXml
(
x
,
y
))
let
record
o
m
=
mk
(
IRecord
(
o
,
m
))
let
optional
x
=
mk
(
IOptional
x
)
type
regexp
=
|
PElem
of
node
|
PGuard
of
node
...
...
@@ -640,6 +637,8 @@ module IType = struct
let
eps
=
PSeq
[]
let
emp
=
PAlt
[]
let
star
x
=
PStar
x
let
elem
x
=
PElem
x
let
seq
r1
r2
=
let
r1
=
match
r1
with
PSeq
l
->
l
|
x
->
[
x
]
in
...
...
@@ -731,6 +730,19 @@ module IType = struct
ior
q_empty
x
let
pcdata
=
star
(
PElem
(
itype
(
Types
.
char
Chars
.
any
)))
let
mix
regexp
=
let
rec
aux
=
function
|
PSeq
[]
->
eps
|
PElem
re
->
PElem
re
|
PGuard
re
->
assert
false
|
PSeq
(
r
::
rl
)
->
seq
(
aux
r
)
(
seq
pcdata
(
aux
(
PSeq
rl
)))
|
PAlt
rl
->
PAlt
(
List
.
map
aux
rl
)
|
PStar
re
->
star
(
seq
pcdata
(
aux
re
))
|
PWeakStar
re
->
assert
false
in
seq
pcdata
(
seq
(
aux
regexp
)
pcdata
)
let
cst_nil
=
Types
.
Atom
Sequence
.
nil_atom
let
capture_all
vars
p
=
IdSet
.
fold
(
fun
p
x
->
iand
p
(
mk
(
ICapture
x
)))
p
vars
...
...
@@ -1029,7 +1041,8 @@ module IType = struct
with
exn
->
clean_on_err
()
;
raise
exn
let
typ_descr
d
=
let
get_type
d
=
check_delayed
()
;
try
internalize
d
;
typ
d
with
exn
->
clean_on_err
()
;
raise
exn
...
...
@@ -1047,6 +1060,16 @@ module IType = struct
try
pat_node
d
with
Patterns
.
Error
s
->
raise_loc_generic
t
.
loc
s
with
exn
->
clean_on_err
()
;
raise
exn
let
delayed
()
=
delayed
noloc
let
link
a
b
=
a
.
desc
<-
ILink
b
let
get_ct
c
=
match
c
.
desc
with
|
ITimes
({
desc
=
IRecord
(
o
,
fields
)
}
,
content
)
->
(
o
,
fields
,
content
)
|
_
->
assert
false
end
let
typ
=
IType
.
typ
...
...
@@ -1766,274 +1789,6 @@ let type_let_funs env funs =
report_unused_branches
()
;
let
env
=
enter_values
typs
env
in
(
env
,
funs
,
typs
)
(* Schema stuff from now on ... *)
(** convertion from XML Schema types (including global elements and
attributes) to CDuce Types.descr *)
module
Schema_converter
=
struct
open
Printf
open
Schema_types
open
Schema_common
open
Encodings
open
IType
let
xsd
=
Schema_xml
.
xsd
let
is_xsd
(
ns
,
l
)
local
=
(
Ns
.
equal
ns
xsd
)
&&
(
String
.
compare
(
Utf8
.
get_str
l
)
local
=
0
)
let
complex_memo
=
Hashtbl
.
create
213
let
rexp
re
=
rexp
(
simplify_regexp
re
)
(* TODO: better approx *)
let
xsd_any_type
=
Types
.
any
let
nil_type
=
itype
Sequence
.
nil_type
let
mk_len_regexp
?
min
?
max
base
=
let
rec
repeat_regexp
re
=
function
|
0
->
eps
|
n
->
seq
re
(
repeat_regexp
re
(
pred
n
))
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
|
0
->
acc
|
n
->
aux
(
alt
eps
(
seq
base
acc
))
(
pred
n
)
in
seq
min_regexp
(
aux
eps
(
max
-
min
))
|
None
->
seq
min_regexp
(
PStar
base
)
let
mk_seq_derecurs
base
facets
=
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
xsi_nil_field_map
=
LabelMap
.
singleton
xsi_nil_label
(
Types
.
cons
Builtin_defs
.
true_type
)
let
xsi_nil_field_map'
=