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
1d59613c
Commit
1d59613c
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-04 01:16:24 by afrisch] More uniform treatment of cduce,ocaml,schema units
Original author: afrisch Date: 2005-03-04 01:16:26+00:00
parent
bbcdbaaa
Changes
19
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
1d59613c
...
...
@@ -78,7 +78,7 @@ and compile_aux env tail = function
|
Typed
.
Transform
(
e
,
brs
)
->
Transform
(
compile
env
false
e
,
compile_branches
env
false
brs
)
|
Typed
.
Xtrans
(
e
,
brs
)
->
Xtrans
(
compile
env
false
e
,
compile_branches
env
false
brs
)
|
Typed
.
Validate
(
e
,
k
,
sch
,
t
)
->
Validate
(
compile
env
tail
e
,
k
,
sch
,
t
)
|
Typed
.
Validate
(
e
,
sch
,
t
)
->
Validate
(
compile
env
tail
e
,
sch
,
t
)
|
Typed
.
RemoveField
(
e
,
l
)
->
RemoveField
(
compile
env
tail
e
,
l
)
|
Typed
.
Dot
(
e
,
l
)
->
Dot
(
compile
env
tail
e
,
l
)
|
Typed
.
Try
(
e
,
brs
)
->
Try
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
...
...
compile/lambda.ml
View file @
1d59613c
...
...
@@ -56,7 +56,7 @@ type expr =
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
schema_component_kind
*
string
*
Ns
.
qname
|
Validate
of
expr
*
string
*
Ns
.
qname
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Ref
of
expr
*
Types
.
Node
.
t
...
...
@@ -186,10 +186,9 @@ module Put = struct
bits
nbits
s
12
;
expr
s
e
;
branches
s
brs
|
Validate
(
e
,
k
,
sch
,
t
)
->
|
Validate
(
e
,
sch
,
t
)
->
bits
nbits
s
13
;
expr
s
e
;
serialize_schema_component_kind
s
k
;
string
s
sch
;
Ns
.
QName
.
serialize
s
t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
...
...
@@ -313,10 +312,9 @@ module Get = struct
Try
(
e
,
brs
)
|
13
->
let
e
=
expr
s
in
let
k
=
deserialize_schema_component_kind
s
in
let
sch
=
string
s
in
let
t
=
Ns
.
QName
.
deserialize
s
in
Validate
(
e
,
k
,
sch
,
t
)
Validate
(
e
,
sch
,
t
)
|
14
->
let
e
=
expr
s
in
let
l
=
LabelPool
.
deserialize
s
in
...
...
compile/lambda.mli
View file @
1d59613c
...
...
@@ -29,7 +29,7 @@ type expr =
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
schema_component_kind
*
string
*
Ns
.
qname
|
Validate
of
expr
*
string
*
Ns
.
qname
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Ref
of
expr
*
Types
.
Node
.
t
...
...
driver/cduce.ml
View file @
1d59613c
...
...
@@ -251,11 +251,6 @@ let directive ppf tenv cenv = function
(
if
!
toplevel
then
raise
End_of_file
)
|
`Env
->
dump_env
ppf
tenv
cenv
|
`Print_schema
schema
->
let
uri
=
Typer
.
find_schema
schema
tenv
in
let
sch
=
Typer
.
get_schema
uri
in
Schema_common
.
print_schema
ppf
sch
;
flush_ppf
ppf
|
`Print_type
t
->
let
t
=
Typer
.
typ
tenv
t
in
Format
.
fprintf
ppf
"%a@."
Types
.
Print
.
print_noname
(
Types
.
descr
t
)
...
...
driver/librarian.ml
View file @
1d59613c
...
...
@@ -81,6 +81,10 @@ let deserialize_dep =
*)
let
has_obj
n
=
let
base
=
Encodings
.
Utf8
.
to_string
n
^
".cdo"
in
List
.
exists
(
fun
p
->
Sys
.
file_exists
(
Filename
.
concat
p
base
))
!
obj_path
let
find_obj
id
=
let
base
=
Encodings
.
Utf8
.
to_string
(
C
.
value
id
)
^
".cdo"
in
let
p
=
...
...
@@ -278,6 +282,7 @@ let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
let
()
=
Typer
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
typing
);
Typer
.
has_comp_unit
:=
has_obj
;
Compile
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
compile
);
Eval
.
get_global
:=
(
fun
cu
i
->
import_and_run
cu
;
(
load
cu
)
.
vals
.
(
i
));
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
(
load
cu
)
.
vals
.
(
i
)
<-
v
);
...
...
ocamliface/mlstub.ml
View file @
1d59613c
...
...
@@ -516,6 +516,8 @@ let stub name ty_env c_env values =
let
register
()
=
Typer
.
has_ocaml_unit
:=
(
fun
cu
->
Mltypes
.
has_cmi
(
U
.
get_str
cu
));
Librarian
.
stub_ml
:=
(
fun
cu
ty_env
c_env
->
try
...
...
ocamliface/mltypes.ml
View file @
1d59613c
...
...
@@ -183,6 +183,11 @@ let unfold ty =
let
unsupported
s
=
raise
(
Error
(
Printf
.
sprintf
"Unsupport feature (%s) found in .cmi"
s
))
let
has_cmi
name
=
Config
.
load_path
:=
Config
.
standard_library
::
!
Librarian
.
obj_path
;
try
ignore
(
Misc
.
find_in_path_uncap
!
Config
.
load_path
(
name
^
".cmi"
));
true
with
Not_found
->
false
let
read_cmi
name
=
Config
.
load_path
:=
Config
.
standard_library
::
!
Librarian
.
obj_path
;
let
filename
=
Misc
.
find_in_path_uncap
!
Config
.
load_path
(
name
^
".cmi"
)
in
...
...
ocamliface/mltypes.mli
View file @
1d59613c
...
...
@@ -24,3 +24,5 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val
find_value
:
string
->
t
*
int
val
has_cmi
:
string
->
bool
parser/ast.ml
View file @
1d59613c
...
...
@@ -31,7 +31,6 @@ and toplevel_directive =
|
`Reinit_ns
|
`Help
|
`Dump
of
pexpr
|
`Print_schema
of
U
.
t
|
`Print_type
of
ppat
|
`Debug
of
debug_directive
|
`Verbose
...
...
@@ -62,8 +61,7 @@ and pexpr =
|
Map
of
pexpr
*
branches
|
Transform
of
pexpr
*
branches
|
Xtrans
of
pexpr
*
branches
|
Validate
of
pexpr
*
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
(* exp, schema component kind, schema name, element name *)
|
Validate
of
pexpr
*
U
.
t
*
U
.
t
(* exp, schema name, element name *)
|
Dot
of
pexpr
*
label
|
RemoveField
of
pexpr
*
label
...
...
@@ -94,8 +92,10 @@ and branches = (ppat * pexpr) list
and
ppat
=
ppat'
located
and
ppat'
=
|
PatVar
of
(
U
.
t
option
)
*
U
.
t
(* optional compilation unit *)
(*
| SchemaVar of (* type/pattern schema variable *)
Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
*)
|
Cst
of
pexpr
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
Location
.
loc
*
U
.
t
*
ppat
)
list
...
...
parser/parser.ml
View file @
1d59613c
...
...
@@ -159,8 +159,6 @@ EXTEND
|
"#"
;
IDENT
"ascii"
->
Ulexer
.
enc
:=
Ulexing
.
Ascii
;
[
]
|
"#"
;
IDENT
"quit"
->
[
mk
loc
(
Directive
`Quit
)
]
|
"#"
;
IDENT
"env"
->
[
mk
loc
(
Directive
`Env
)
]
|
"#"
;
IDENT
"print_schema"
;
name
=
IDENT
->
[
mk
loc
(
Directive
(
`Print_schema
(
U
.
mk
name
)))
]
|
"#"
;
IDENT
"print_type"
;
t
=
pat
->
[
mk
loc
(
Directive
(
`Print_type
t
))
]
|
"#"
;
IDENT
"dump_value"
;
e
=
expr
->
[
mk
loc
(
Directive
(
`Dump
e
))
]
...
...
@@ -238,8 +236,8 @@ EXTEND
exp
loc
(
if_then_else
e
e1
e2
)
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Transform
(
e
,
b
))
|
"validate"
;
e
=
SELF
;
"with"
;
(
kind
,
schema
,
typ
)
=
schema_ref
->
exp
loc
(
Validate
(
e
,
kind
,
schema
,
typ
))
|
"validate"
;
e
=
SELF
;
"with"
;
(
schema
,
typ
)
=
schema_ref
->
exp
loc
(
Validate
(
e
,
schema
,
typ
))
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
"external"
;
s
=
STRING2
->
...
...
@@ -512,19 +510,8 @@ EXTEND
]
];
schema_kind
:
[
[
IDENT
"element"
->
`Element
|
"type"
->
`Type
|
IDENT
"attribute"
->
`Attribute
|
IDENT
"attribute_group"
->
`Attribute_group
|
IDENT
"model_group"
->
`Model_group
]
];
schema_ref
:
[
[
schema
=
IDENT
;
"#"
;
typ
=
[
IDENT
|
keyword
];
kind
=
OPT
[
"as"
;
k
=
schema_kind
->
k
]
->
(
kind
,
U
.
mk
schema
,
U
.
mk
typ
)
[
schema
=
IDENT
;
"."
;
typ
=
[
IDENT
|
keyword
]
->
(
U
.
mk
schema
,
U
.
mk
typ
)
]
];
...
...
@@ -551,13 +538,8 @@ EXTEND
|
IDENT
"_"
->
mk
loc
(
Internal
Types
.
any
)
|
"("
;
a
=
IDENT
;
":="
;
c
=
expr
;
")"
->
mk
loc
(
Constant
(
ident
a
,
c
))
|
schema
=
IDENT
;
"#"
;
typ
=
[
IDENT
|
keyword
];
kind
=
OPT
[
"as"
;
k
=
schema_kind
->
k
]
->
mk
loc
(
SchemaVar
(
kind
,
U
.
mk
schema
,
U
.
mk
typ
))
|
"!"
;
a
=
IDENT
->
mk
loc
(
Internal
(
Types
.
abstract
(
Types
.
Abstract
.
atom
a
)))
(* | a = IDENT ->
mk loc (PatVar (None, U.mk a)) *)
|
cu
=
OPT
[
cu
=
IDENT
;
"."
->
U
.
mk
cu
];
a
=
IDENT
->
mk
loc
(
PatVar
(
cu
,
U
.
mk
a
))
|
i
=
INT
;
"--"
;
j
=
INT
->
...
...
runtime/eval.ml
View file @
1d59613c
...
...
@@ -141,7 +141,7 @@ let rec eval env = function
|
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
Validate
(
e
,
kind
,
schema
,
name
)
->
eval_validate
env
e
kind
schema
name
|
Validate
(
e
,
schema
,
name
)
->
eval_validate
env
e
schema
name
|
Ref
(
e
,
t
)
->
eval_ref
env
e
t
|
Op
(
op
,
args
)
as
e
->
let
eval_fun
=
eval_op
op
in
...
...
@@ -229,22 +229,10 @@ and eval_branches_new env brs arg =
and
eval_ref
env
e
t
=
Value
.
mk_ref
(
Types
.
descr
t
)
(
eval
env
e
)
and
eval_validate
env
e
kind
uri
name
=
let
schema
=
Typer
.
get_schema
uri
in
try
let
validate
=
match
Schema_common
.
get_component
kind
name
schema
with
|
Schema_types
.
Type
x
->
Schema_validator
.
validate_type
x
schema
|
Schema_types
.
Element
x
->
Schema_validator
.
validate_element
x
schema
|
Schema_types
.
Attribute
x
->
assert
false
(* TODO see schema/schema_validator.mli *)
(* Schema_validator.validate_attribute x schema *)
|
Schema_types
.
Attribute_group
x
->
Schema_validator
.
validate_attribute_group
x
schema
|
Schema_types
.
Model_group
x
->
Schema_validator
.
validate_model_group
x
schema
in
validate
(
eval
env
e
)
and
eval_validate
env
e
uri
name
=
(* TODO: compute the validator when loading the lambda code *)
let
validate
=
Typer
.
get_schema_validator
uri
name
in
try
validate
(
eval
env
e
)
with
Schema_common
.
XSI_validation_error
msg
->
failwith'
(
"Schema validation failure: "
^
msg
)
...
...
schema/schema_builtin.ml
View file @
1d59613c
...
...
@@ -712,7 +712,8 @@ let string_of_time_type fields =
(** {2 API} *)
let
is
=
QTable
.
mem
builtins
let
xsd_any
=
(
xsd
,
Utf8
.
mk
"anyType"
)
let
is
s
=
QTable
.
mem
builtins
s
||
(
Ns
.
QName
.
equal
s
xsd_any
)
let
iter
f
=
QTable
.
iter
f
builtins
let
get
name
=
QTable
.
find
builtins
name
...
...
schema/schema_validator.ml
View file @
1d59613c
...
...
@@ -33,8 +33,6 @@ let foo_qname = Ns.empty, Utf8.mk ""
type
context
=
{
ctx_stream
:
event
Stream
.
t
;
ctx_schema
:
schema
;
mutable
ctx_mixed
:
bool
;
mutable
ctx_current
:
Value
.
t
;
}
...
...
@@ -523,14 +521,13 @@ and validate_model_group ctx model_group =
|
Sequence
particles
->
List
.
iter
(
validate_particle
ctx
)
particles
let
ctx
stream
schema
=
let
ctx
stream
=
{
ctx_stream
=
stream
;
ctx_schema
=
schema
;
ctx_mixed
=
false
;
ctx_current
=
Value
.
Absent
}
let
validate_element
decl
schema
value
=
let
ctx
=
ctx
(
stream_of_value
value
)
schema
in
let
validate_element
decl
value
=
let
ctx
=
ctx
(
stream_of_value
value
)
in
validate_element
ctx
decl
let
get_str
v
=
...
...
@@ -539,12 +536,12 @@ let get_str v =
"Only string values could be validate against simple types"
;
fst
(
get_string_utf8
v
)
let
validate_type
def
schema
value
=
let
validate_type
def
value
=
match
def
with
|
AnyType
->
value
(* shortcut *)
|
Simple
st_def
->
validate_simple_type
st_def
(
get_str
value
)
|
Complex
ct_def
->
let
ctx
=
ctx
(
stream_of_value
value
)
schema
in
let
ctx
=
ctx
(
stream_of_value
value
)
in
let
start_tag
=
expect_any_start_tag
ctx
in
let
attrs
=
get_attributes
ctx
in
let
(
attrs
,
content
)
=
validate_complex_type
ctx
attrs
ct_def
in
...
...
@@ -552,7 +549,7 @@ let validate_type def schema value =
Value
.
Xml
(
Value
.
Atom
(
Atoms
.
V
.
of_qname
start_tag
)
,
attrs
,
content
)
(*
let validate_attribute decl
schema
value =
let validate_attribute decl value =
assert false; (* TODO see the .mli *)
(match value with
| Record _ -> ()
...
...
@@ -586,7 +583,7 @@ let validate_attribute decl schema value =
Value.vrecord fields
*)
let
validate_attribute_group
{
ag_def
=
attr_uses
}
schema
value
=
let
validate_attribute_group
{
ag_def
=
attr_uses
}
value
=
let
stream
=
match
value
with
|
Record
_
->
...
...
@@ -600,18 +597,18 @@ let validate_attribute_group { ag_def = attr_uses } schema value =
error
"Only record values could be validated against attribute groups"
in
let
ctx
=
ctx
stream
schema
in
let
ctx
=
ctx
stream
in
let
attrs
=
get_attributes
ctx
in
validate_attribute_uses
attrs
attr_uses
let
validate_model_group
{
mg_def
=
mg
}
schema
value
=
let
validate_model_group
{
mg_def
=
mg
}
value
=
if
not
(
Value
.
is_seq
value
)
then
error
"Only sequence values could be validated against model groups"
;
let
stream
=
stream_of_value
(
Value
.
Xml
(
foo_atom
,
empty_record
,
value
))
in
Stream
.
junk
stream
;
let
ctx
=
ctx
stream
schema
in
let
ctx
=
ctx
stream
in
validate_model_group
ctx
mg
;
get
ctx
...
...
schema/schema_validator.mli
View file @
1d59613c
...
...
@@ -12,7 +12,7 @@ open Schema_types
* that a given XML value has the given type ignoring tag name (CDuce domain:
* XML values)
*)
val
validate_type
:
type_definition
->
schema
->
Value
.
t
->
Value
.
t
val
validate_type
:
type_definition
->
Value
.
t
->
Value
.
t
(** CDuce domain: records
*
...
...
@@ -29,15 +29,15 @@ val validate_type : type_definition -> schema -> Value.t -> Value.t
*)
(** CDuce domain: XML values *)
val
validate_element
:
element_declaration
->
schema
->
Value
.
t
->
Value
.
t
val
validate_element
:
element_declaration
->
Value
.
t
->
Value
.
t
(** CDuce domain: records *)
val
validate_attribute_group
:
attribute_group_definition
->
schema
->
Value
.
t
->
Value
.
t
attribute_group_definition
->
Value
.
t
->
Value
.
t
(** CDuce domain: sequences of XML values *)
val
validate_model_group
:
model_group_definition
->
schema
->
Value
.
t
->
Value
.
t
model_group_definition
->
Value
.
t
->
Value
.
t
(** {2 derived validators} *)
...
...
tests/schema/test.pl
View file @
1d59613c
...
...
@@ -31,13 +31,13 @@ foreach my $s (@ARGV) {
EOF
if
(
$root
)
{
print
CD
<<EOF;
#print_type X
#
$root;;
#print_type X
.
$root;;
EOF
}
if
(
-
f
"
$1.xml
")
{
print
CD
<<EOF;
let x = load_xml "$1.xml";;
let y = validate x with X
#
$root;;
let y = validate x with X
.
$root;;
print_xml y;;
EOF
}
...
...
types/externals.mli
View file @
1d59613c
val
nb
:
unit
->
int
val
register
:
ref
(
int
->
string
->
Types
.
Node
.
t
list
->
Types
.
t
)
val
resolve
:
string
->
Types
.
Node
.
t
list
->
(
int
*
Types
.
t
)
typing/typed.ml
View file @
1d59613c
...
...
@@ -42,8 +42,7 @@ and texpr' =
|
Map
of
texpr
*
branches
|
Transform
of
texpr
*
branches
|
Xtrans
of
texpr
*
branches
|
Validate
of
texpr
*
Schema_types
.
component_kind
*
string
*
Ns
.
qname
(* exp, schema component kind, schema uri, element name *)
|
Validate
of
texpr
*
string
*
Ns
.
qname
(* exp, schema uri, element name *)
|
RemoveField
of
texpr
*
label
|
Dot
of
texpr
*
label
...
...
typing/typer.ml
View file @
1d59613c
...
...
@@ -43,13 +43,17 @@ type item =
|
Type
of
Types
.
t
|
Val
of
Types
.
t
type
ext
=
|
ECDuce
of
Types
.
CompUnit
.
t
(* CDuce unit *)
|
EOCaml
of
string
(* OCaml module *)
|
ESchema
of
string
(* XML Schema *)
module
UEnv
=
Map
.
Make
(
U
)
type
t
=
{
ids
:
item
Env
.
t
;
ns
:
Ns
.
table
;
cu
:
Types
.
CompUnit
.
t
UEnv
.
t
;
schemas
:
string
UEnv
.
t
cu
:
ext
UEnv
.
t
;
}
let
hash
_
=
failwith
"Typer.hash"
...
...
@@ -62,18 +66,13 @@ let check _ = failwith "Typer.check"
let
load_schema_fwd
=
ref
(
fun
x
uri
->
assert
false
)
let
enter_schema
?
prefix
x
uri
env
=
let
sch
,
reg
=
!
load_schema_fwd
x
uri
in
(* Set the namespace prefix before registration for better pretty
printing *)
let
env
=
{
env
with
schemas
=
UEnv
.
add
x
uri
env
.
schemas
;
ns
=
(
match
prefix
with
|
Some
p
->
Ns
.
add_prefix
p
sch
.
Schema_types
.
targetNamespace
env
.
ns
|
None
->
env
.
ns
)
}
in
reg
()
;
env
let
sch
=
!
load_schema_fwd
x
uri
in
{
env
with
cu
=
UEnv
.
add
x
(
ESchema
uri
)
env
.
cu
;
ns
=
(
match
prefix
with
|
Some
p
->
Ns
.
add_prefix
p
sch
.
Schema_types
.
targetNamespace
env
.
ns
|
None
->
env
.
ns
)
}
(* TODO: filter out builtin defs ? *)
...
...
@@ -86,7 +85,9 @@ let serialize s env =
Ns
.
serialize_table
s
env
.
ns
;
let
schs
=
UEnv
.
fold
(
fun
name
uri
accu
->
(
name
,
uri
)
::
accu
)
env
.
schemas
[]
in
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
let
deserialize_item
s
=
match
Serialize
.
Get
.
bits
1
s
with
...
...
@@ -101,7 +102,7 @@ let deserialize s =
Serialize
.
Get
.
list
(
Serialize
.
Get
.
pair
U
.
deserialize
Serialize
.
Get
.
string
)
s
in
let
env
=
{
ids
=
ids
;
ns
=
ns
;
cu
=
UEnv
.
empty
;
schemas
=
UEnv
.
empty
}
in
{
ids
=
ids
;
ns
=
ns
;
cu
=
UEnv
.
empty
}
in
List
.
fold_left
(
fun
env
(
name
,
uri
)
->
enter_schema
name
uri
env
)
env
schs
...
...
@@ -109,22 +110,30 @@ let empty_env = {
ids
=
Env
.
empty
;
ns
=
Ns
.
empty_table
;
cu
=
UEnv
.
empty
;
schemas
=
UEnv
.
empty
}
let
from_comp_unit
=
ref
(
fun
cu
->
assert
false
)
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
enter_cu
x
cu
env
=
{
env
with
cu
=
UEnv
.
add
x
cu
env
.
cu
}
{
env
with
cu
=
UEnv
.
add
x
(
ECDuce
cu
)
env
.
cu
}
let
find_cu
x
env
=
let
find_cu
loc
x
env
=
try
UEnv
.
find
x
env
.
cu
with
Not_found
->
Types
.
CompUnit
.
mk
x
with
Not_found
->
if
!
has_comp_unit
x
then
(
ECDuce
(
Types
.
CompUnit
.
mk
x
))
else
if
!
has_ocaml_unit
x
then
(
EOCaml
(
U
.
get_str
x
))
else
error
loc
(
"Cannot find external unit "
^
(
U
.
to_string
x
))
let
find_schema
x
env
=
try
UEnv
.
find
x
env
.
schemas
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"%s: no such schema"
(
U
.
get_str
x
)))
try
(
match
UEnv
.
find
x
env
.
cu
with
|
ESchema
s
->
s
|
_
->
raise
Not_found
)
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"%s: no such schema"
(
U
.
to_string
x
)))
let
enter_type
id
t
env
=
{
env
with
ids
=
Env
.
add
id
(
Type
t
)
env
.
ids
}
...
...
@@ -136,10 +145,6 @@ let find_type id env =
|
Type
t
->
t
|
Val
_
->
raise
Not_found
let
find_type_global
loc
cu
id
env
=
let
cu
=
find_cu
cu
env
in
let
env
=
!
from_comp_unit
cu
in
find_type
id
env
let
enter_value
id
t
env
=
{
env
with
ids
=
Env
.
add
id
(
Val
t
)
env
.
ids
}
...
...
@@ -153,12 +158,9 @@ let find_value id env =
match
Env
.
find
id
env
.
ids
with
|
Val
t
->
t
|
_
->
raise
Not_found
let
find_value_global
cu
id
env
=
let
env
=
!
from_comp_unit
cu
in
find_value
id
env
let
is_cu
id
env
=
try
ignore
(
!
from_comp_unit
(
find_cu
id
env
));
true
with
_
->
false
let
find_value_global
loc
cu
id
env
=
try
find_value
id
(
!
from_comp_unit
cu
)
with
Not_found
->
raise_loc
loc
(
UnboundExtId
(
cu
,
id
))
let
value_name_ok
id
env
=
try
match
Env
.
find
id
env
.
ids
with
...
...
@@ -239,55 +241,24 @@ let rec const env loc = function
(* Schema *)
let
is_registered_schema
env
s
=
UEnv
.
mem
s
env
.
schemas
(* uri -> schema binding *)
let
schemas
=
State
.
ref
"Typer.schemas"
(
Hashtbl
.
create
3
)
let
schema_types
=
State
.
ref
"Typer.schema_types"
(
Hashtbl
.
create
51
)
let
schema_elements
=
State
.
ref
"Typer.schema_elements"
(
Hashtbl
.
create
51
)
let
schema_attributes
=
State
.
ref
"Typer.schema_attributes"
(
Hashtbl
.
create
51
)
let
schema_attribute_groups
=
State
.
ref
"Typer.schema_attribute_groups"
(
Hashtbl
.
create
51
)
let
schema_model_groups
=
State
.
ref
"Typer.schema_model_groups"
(
Hashtbl
.
create
51
)
let
schemas
=
Hashtbl
.
create
3
(*
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found -> assert false
*)
let
find_schema_descr_uri
kind
uri
(
name
:
Ns
.
qname
)
=
let
find_schema_descr
uri
(
name
:
Ns
.
qname
)
=
try
let
elt
()
=
Hashtbl
.
find
!
schema_elements
(
uri
,
name
)
in
let
typ
()
=
Hashtbl
.
find
!
schema_types
(
uri
,
name
)
in
let
att
()
=
Hashtbl
.
find
!
schema_attributes
(
uri
,
name
)
in
let
att_group
()
=
Hashtbl
.
find
!
schema_attribute_groups
(
uri
,
name
)
in
let
mod_group
()
=
Hashtbl
.
find
!
schema_model_groups
(
uri
,
name
)
in
let
rec
do_try
n
=
function
|
[]
->
raise
Not_found
|
f
::
rem
->
(
try
f
()
with
Not_found
->
do_try
n
rem
)
in
match
kind
with
|
Some
`Element
->
do_try
"element"
[
elt
]
|
Some
`Type
->
do_try
"type"
[
typ
]
|
Some
`Attribute
->
do_try
"atttribute"
[
att
]
|
Some
`Attribute_group
->
do_try
"attribute group"
[
att_group
]
|
Some
`Model_group
->
do_try
"model group"
[
mod_group
]
|
None
->
(* policy for unqualified schema component resolution. This order should
* be consistent with Schema_component.get_component *)
do_try
"component"
[
elt
;
typ
;
att
;
att_group
;
mod_group
]
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"No %s named '%s' found in schema '%s'"
(
Schema_common
.
string_of_component_kind
kind
)
(
Ns
.
QName
.
to_string
name
)
uri
))
let
sch
=
snd
(
Hashtbl
.
find
schemas
uri
)
in
fst
(
Env
.
find
(
Ident
.
ident
name
)
sch
)
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"No component named '%s' found in schema '%s'"
(
Ns
.
QName
.
to_string
name
)
uri
))
let
find_schema_descr
env
kind
schema
name
=
let
uri
=
find_schema
schema
env
in
find_schema_descr_uri
kind
uri
name
let
find_type_global
loc
cu
id
env
=
match
find_cu
loc
cu
env
with
|
ECDuce
cu
->
find_type
id
(
!
from_comp_unit
cu
)
|
EOCaml
_
->
error
loc
"OCaml units don't export types"
(* TODO *)
|
ESchema
s
->
find_schema_descr
s
(
Ident
.
value
id
)
module
IType
=
struct
type
node
=
{
...
...
@@ -796,10 +767,12 @@ module IType = struct
let
rec
derecurs
env
p
=
match
p
.
descr
with
|
PatVar
(
cu
,
v
)
->
derecurs_var
env
p
.
loc
cu
v
(*
| SchemaVar (kind, schema_name, component_name) ->
let name = qname env.penv_tenv p.loc component_name in
itype (find_schema_descr env.penv_tenv kind schema_name name)
*)
|
Recurs
(
p
,
b
)
->
derecurs
(
derecurs_def
env
b
)
p
|
Internal
t
->
itype
t
...
...
@@ -1040,17 +1013,16 @@ let rec expr env loc = function
let
(
fv1
,
e1
)
=
expr
env
loc
e1
and
(
fv2
,
e2
)
=
expr
env
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Xml
(
e1
,
e2
))
|
Dot
(
LocatedExpr
(
_
,
Var
cu
)
,
id
)
when
not
(
has_value
cu
env
)
->
if
is_cu
cu
env
then
(
let
cu
=
find_cu
cu
env
in
let
id
=
ident
env
loc
id
in
let
t
=