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
73e03a54
Commit
73e03a54
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-07-07 13:57:17 by afrisch] Export namespaces, schemas, ...
Original author: afrisch Date: 2005-07-07 13:57:18+00:00
parent
80304e58
Changes
11
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
73e03a54
...
...
@@ -216,23 +216,20 @@ let type_defs (tenv,cenv,codes) typs =
let
tenv
=
Typer
.
type_defs
tenv
typs
in
(
tenv
,
cenv
,
codes
)
let
namespace
(
tenv
,
cenv
,
codes
)
pr
ns
=
let
tenv
=
Typer
.
type_ns
tenv
pr
ns
in
let
namespace
(
tenv
,
cenv
,
codes
)
loc
pr
ns
=
let
tenv
=
Typer
.
type_ns
tenv
loc
pr
ns
in
(
tenv
,
cenv
,
codes
)
let
keep_ns
(
tenv
,
cenv
,
codes
)
k
=
let
tenv
=
Typer
.
type_keep_ns
tenv
k
in
(
tenv
,
cenv
,
codes
)
let
schema
(
tenv
,
cenv
,
codes
)
x
sch
=
let
tenv
=
Typer
.
type_schema
tenv
x
sch
in
let
schema
(
tenv
,
cenv
,
codes
)
loc
x
sch
=
let
tenv
=
Typer
.
type_schema
tenv
loc
x
sch
in
(
tenv
,
cenv
,
codes
)
let
find_cu
(
tenv
,_,_
)
cu
=
Typer
.
find_cu
cu
tenv
let
using
(
tenv
,
cenv
,
codes
)
x
cu
=
let
tenv
=
Typer
.
enter_cu
x
cu
tenv
in
let
using
(
tenv
,
cenv
,
codes
)
loc
x
cu
=
let
tenv
=
Typer
.
type_using
tenv
loc
x
cu
in
(
tenv
,
cenv
,
codes
)
let
rec
collect_funs
accu
=
function
...
...
@@ -244,7 +241,7 @@ let rec collect_types accu = function
collect_types
((
loc
,
x
,
t
)
::
accu
)
rest
|
rest
->
(
accu
,
rest
)
let
rec
phrases
~
run
~
show
~
loading
~
directive
=
let
rec
phrases
~
run
~
show
~
directive
=
let
rec
loop
accu
phs
=
match
phs
with
|
{
descr
=
Ast
.
FunDecl
_
}
::
_
->
...
...
@@ -253,16 +250,14 @@ let rec phrases ~run ~show ~loading ~directive =
|
{
descr
=
Ast
.
TypeDecl
(
_
,_
)
}
::
_
->
let
(
typs
,
rest
)
=
collect_types
[]
phs
in
loop
(
type_defs
accu
typs
)
rest
|
{
descr
=
Ast
.
SchemaDecl
(
name
,
uri
)
}
::
rest
->
loop
(
schema
accu
name
uri
)
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
loop
(
namespace
accu
pr
ns
)
rest
|
{
descr
=
Ast
.
SchemaDecl
(
name
,
uri
)
;
loc
=
loc
}
::
rest
->
loop
(
schema
accu
loc
name
uri
)
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
;
loc
=
loc
}
::
rest
->
loop
(
namespace
accu
loc
pr
ns
)
rest
|
{
descr
=
Ast
.
KeepNs
b
}
::
rest
->
loop
(
keep_ns
accu
b
)
rest
|
{
descr
=
Ast
.
Using
(
x
,
cu
)
}
::
rest
->
let
cu
=
find_cu
accu
cu
in
loading
cu
;
loop
(
using
accu
x
cu
)
rest
|
{
descr
=
Ast
.
Using
(
x
,
cu
);
loc
=
loc
}
::
rest
->
loop
(
using
accu
loc
x
cu
)
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
loop
(
eval
~
run
~
show
accu
e
)
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
...
...
@@ -278,9 +273,8 @@ let rec phrases ~run ~show ~loading ~directive =
let
comp_unit
?
(
run
=
false
)
?
(
show
=
fun
_
_
_
->
()
)
?
(
loading
=
fun
_
->
()
)
?
(
directive
=
fun
_
_
_
->
()
)
tenv
cenv
phs
=
let
(
tenv
,
cenv
,
codes
)
=
phrases
~
run
~
show
~
loading
~
directive
(
tenv
,
cenv
,
[]
)
phs
in
let
(
tenv
,
cenv
,
codes
)
=
phrases
~
run
~
show
~
directive
(
tenv
,
cenv
,
[]
)
phs
in
(
tenv
,
cenv
,
List
.
rev
codes
)
...
...
compile/compile.mli
View file @
73e03a54
...
...
@@ -17,7 +17,6 @@ val compile_eval_expr : env -> Typed.texpr -> Value.t
val
comp_unit
:
?
run
:
bool
->
?
show
:
(
id
option
->
Types
.
t
->
Value
.
t
option
->
unit
)
->
?
loading
:
(
Compunit
.
t
->
unit
)
->
?
directive
:
(
Typer
.
t
->
env
->
Ast
.
toplevel_directive
->
unit
)
->
Typer
.
t
->
env
->
Ast
.
pmodule_item
list
->
...
...
driver/cduce.ml
View file @
73e03a54
...
...
@@ -60,8 +60,6 @@ let dump_env ppf tenv cenv =
Format
.
fprintf
ppf
"Namespace prefixes:@
\n
%a"
Typer
.
dump_ns
tenv
;
Format
.
fprintf
ppf
"Namespace prefixes used for pretty-printing:@.%t"
Ns
.
InternalPrinter
.
dump
;
Format
.
fprintf
ppf
"Schemas: %s@."
(
String
.
concat
" "
(
List
.
map
U
.
get_str
(
Typer
.
get_schema_names
tenv
)));
Format
.
fprintf
ppf
"Values:@."
;
Typer
.
iter_values
tenv
(
fun
x
t
->
dump_value
ppf
x
t
(
get_global_value
cenv
x
))
...
...
@@ -271,7 +269,6 @@ let phrases ppf phs =
let
(
tenv
,
cenv
,_
)
=
Compile
.
comp_unit
~
run
:
true
~
show
:
(
show
ppf
)
~
loading
:
Librarian
.
run
~
directive
:
(
directive
ppf
)
!
typing_env
!
compile_env
phs
in
typing_env
:=
tenv
;
...
...
driver/librarian.ml
View file @
73e03a54
...
...
@@ -7,6 +7,8 @@ exception InvalidObject of string
exception
CannotOpen
of
string
exception
NoImplementation
of
U
.
t
let
run_loaded
=
ref
false
type
t
=
{
name
:
U
.
t
;
descr
:
Compunit
.
t
;
...
...
@@ -217,7 +219,10 @@ let get_builtins () =
let
()
=
Typer
.
from_comp_unit
:=
(
fun
d
->
(
from_descr
d
)
.
typing
);
Typer
.
load_comp_unit
:=
(
fun
name
->
if
has_obj
name
then
(
load
name
)
.
descr
if
has_obj
name
then
let
cu
=
load
name
in
if
!
run_loaded
then
run
cu
;
cu
.
descr
else
raise
Not_found
);
Typer
.
has_static_external
:=
Hashtbl
.
mem
static_externals
;
Compile
.
from_comp_unit
:=
(
fun
d
->
(
from_descr
d
)
.
compile
);
...
...
driver/librarian.mli
View file @
73e03a54
...
...
@@ -6,6 +6,7 @@ exception CannotOpen of string
exception
NoImplementation
of
U
.
t
val
name
:
Compunit
.
t
->
U
.
t
val
run_loaded
:
bool
ref
val
obj_path
:
string
list
ref
...
...
driver/run.ml
View file @
73e03a54
...
...
@@ -124,6 +124,7 @@ let toploop () =
Sys
.
set_signal
Sys
.
sigquit
(
Sys
.
Signal_handle
(
fun
_
->
quit
()
));
Sys
.
catch_break
true
;
Cduce
.
toplevel
:=
true
;
Librarian
.
run_loaded
:=
true
;
Location
.
push_source
`Stream
;
let
read
i
=
if
!
bol
then
...
...
parser/ast.ml
View file @
73e03a54
...
...
@@ -3,6 +3,8 @@
open
Location
open
Ident
type
ns_expr
=
[
`Uri
of
Ns
.
Uri
.
t
|
`Path
of
U
.
t
list
]
type
pprog
=
pmodule_item
list
and
pmodule_item
=
pmodule_item'
located
...
...
@@ -11,7 +13,7 @@ and pmodule_item' =
|
SchemaDecl
of
U
.
t
*
string
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
|
Namespace
of
U
.
t
*
Ns
.
Uri
.
t
|
Namespace
of
U
.
t
*
ns_expr
|
KeepNs
of
bool
|
Using
of
U
.
t
*
U
.
t
|
EvalStatement
of
pexpr
...
...
@@ -61,15 +63,16 @@ and pexpr =
|
Map
of
pexpr
*
branches
|
Transform
of
pexpr
*
branches
|
Xtrans
of
pexpr
*
branches
|
Validate
of
pexpr
*
U
.
t
*
U
.
t
(* exp, schema name, element name *)
|
Dot
of
pexpr
*
label
*
ppat
list
|
Validate
of
pexpr
*
U
.
t
list
|
Dot
of
pexpr
*
label
|
TyArgs
of
pexpr
*
ppat
list
|
RemoveField
of
pexpr
*
label
(* Exceptions *)
|
Try
of
pexpr
*
branches
(* Other *)
|
NamespaceIn
of
U
.
t
*
Ns
.
Uri
.
t
*
pexpr
|
NamespaceIn
of
U
.
t
*
ns_expr
*
pexpr
|
KeepNsIn
of
bool
*
pexpr
|
Forget
of
pexpr
*
ppat
|
Check
of
pexpr
*
ppat
...
...
@@ -93,7 +96,7 @@ and branches = (ppat * pexpr) list
and
ppat
=
ppat'
located
and
ppat'
=
|
PatVar
of
(
U
.
t
option
)
*
U
.
t
(* optional compilation unit *)
|
PatVar
of
U
.
t
list
|
Cst
of
pexpr
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
Location
.
loc
*
U
.
t
*
ppat
)
list
...
...
parser/parser.ml
View file @
73e03a54
...
...
@@ -117,8 +117,8 @@ let logical_not e = if_then_else e cst_false cst_true
let
apply_op2_noloc
op
e1
e2
=
Apply
(
Apply
(
Var
(
ident
op
)
,
e1
)
,
e2
)
let
apply_op2
loc
op
e1
e2
=
exp
loc
(
apply_op2_noloc
op
e1
e2
)
let
set_ref
e1
e2
=
Apply
(
Dot
(
e1
,
U
.
mk
"set"
,
[]
)
,
e2
)
let
get_ref
e
=
Apply
(
Dot
(
e
,
U
.
mk
"get"
,
[]
)
,
cst_nil
)
let
set_ref
e1
e2
=
Apply
(
Dot
(
e1
,
U
.
mk
"set"
)
,
e2
)
let
get_ref
e
=
Apply
(
Dot
(
e
,
U
.
mk
"get"
)
,
cst_nil
)
let
let_in
e1
p
e2
=
Match
(
e1
,
[
p
,
e2
])
let
seq
e1
e2
=
let_in
e1
pat_nil
e2
let
concat
e1
e2
=
apply_op2_noloc
"@"
e1
e2
...
...
@@ -243,7 +243,7 @@ EXTEND
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Transform
(
e
,
b
))
|
"validate"
;
e
=
SELF
;
"with"
;
(
schema
,
typ
)
=
schema_ref
->
exp
loc
(
Validate
(
e
,
schema
,
typ
))
exp
loc
(
Validate
(
e
,
[
schema
;
typ
]
))
|
"select"
;
e
=
SELF
;
"from"
;
l
=
LIST1
[
x
=
pat
;
"in"
;
e
=
expr
->
(
x
,
e
)]
SEP
","
;
cond
=
[
"where"
;
c
=
LIST1
[
expr
]
SEP
"and"
->
c
...
...
@@ -302,7 +302,7 @@ EXTEND
let
any
=
mk
loc
(
Internal
Types
.
any
)
in
let
att
=
mk
loc
(
Record
(
true
,
[(
label
a
,
(
mk
loc
(
PatVar
(
None
,
id_dummy
)
)
,
(
mk
loc
(
PatVar
[
id_dummy
]
)
,
None
))]))
in
let
p
=
mk
loc
(
XmlT
(
tag
,
multi_prod
loc
[
att
;
any
]))
in
let
t
=
(
p
,
Pair
(
Var
id_dummy
,
cst_nil
))
in
...
...
@@ -318,11 +318,11 @@ EXTEND
set_ref
(
Var
stk
)
(
concat
(
get_ref
(
Var
stk
))
(
Pair
(
Var
id_dummy
,
cst_nil
)))
in
let
capt
=
mk
loc
(
And
(
mk
loc
(
PatVar
(
None
,
U
.
mk
"$$$"
)
)
,
p
))
in
let
capt
=
mk
loc
(
And
(
mk
loc
(
PatVar
[
U
.
mk
"$$$"
]
)
,
p
))
in
let
xt
=
Xtrans
(
e
,
[
capt
,
assign
])
in
let
rf
=
Ref
(
cst_nil
,
mk
loc
(
Regexp
(
Star
(
Elem
p
))))
in
let
body
=
let_in
rf
(
mk
loc
(
PatVar
(
None
,
stk
)
))
let_in
rf
(
mk
loc
(
PatVar
[
stk
]
))
(
let_in
xt
(
mk
loc
(
Internal
Types
.
any
))
(
get_ref
(
Var
stk
)))
in
exp
loc
body
...
...
@@ -335,10 +335,10 @@ EXTEND
|
"no_appl"
[
e
=
expr
;
"
."
;
l
=
[
IDENT
|
keyword
];
tyargs
=
[
"with"
;
"{"
;
pl
=
LIST0
pat
;
"}"
->
pl
|
->
[]
]
->
exp
loc
(
Dot
(
e
,
label
l
,
tyargs
))
[
e
=
expr
;
"
with"
;
"{"
;
tyargs
=
LIST0
pat
;
"}"
->
exp
loc
(
TyArgs
(
e
,
tyargs
))
|
e
=
expr
;
"."
;
l
=
[
IDENT
|
keyword
]
->
exp
loc
(
Dot
(
e
,
label
l
))
]
|
[
"("
;
l
=
LIST1
expr
SEP
","
;
")"
->
exp
loc
(
tuple
l
)
...
...
@@ -397,19 +397,24 @@ EXTEND
[
name
=
[
name
=
[
IDENT
|
keyword
];
"="
->
ident
name
|
->
U
.
mk
""
];
uri
=
STRING2
->
let
ns
=
Ns
.
Uri
.
mk
(
ident
uri
)
in
`Prefix
(
name
,
ns
)
ns
=
ns_expr
->
`Prefix
(
name
,
ns
)
|
IDENT
"on"
->
`Keep
true
|
IDENT
"off"
->
`Keep
false
]
]
->
r
]
];
ns_expr
:
[
[
uri
=
STRING2
->
`Uri
(
Ns
.
Uri
.
mk
(
ident
uri
))
|
ids
=
LIST1
[
IDENT
|
keyword
]
SEP
"."
->
let
ids
=
List
.
map
(
fun
x
->
ident
x
)
ids
in
`Path
ids
]
];
let_binding
:
[
[
"let"
;
is_fun_decl
;
OPT
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
let
f
=
match
f
with
Some
x
->
x
|
None
->
assert
false
in
let
p
=
mk
loc
(
PatVar
(
None
,
snd
f
)
)
in
let
p
=
mk
loc
(
PatVar
[
snd
f
]
)
in
let
abst
=
{
fun_name
=
Some
f
;
fun_iface
=
a
;
fun_body
=
b
}
in
let
e
=
exp
loc
(
Abstraction
abst
)
in
(
true
,
p
,
e
)
...
...
@@ -581,8 +586,9 @@ EXTEND
mk
loc
(
Constant
(
ident
a
,
c
))
|
"!"
;
a
=
IDENT
->
mk
loc
(
Internal
(
Types
.
abstract
(
Types
.
Abstract
.
atom
a
)))
|
cu
=
OPT
[
cu
=
IDENT
;
"."
->
U
.
mk
cu
];
a
=
[
IDENT
|
keyword
]
->
mk
loc
(
PatVar
(
cu
,
ident
a
))
|
ids
=
LIST1
[
IDENT
|
keyword
]
SEP
"."
->
let
ids
=
List
.
map
(
fun
x
->
ident
x
)
ids
in
mk
loc
(
PatVar
ids
)
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Intervals
.
V
.
mk
i
and
j
=
Intervals
.
V
.
mk
j
in
...
...
@@ -643,7 +649,7 @@ EXTEND
[
[
r
=
LIST0
[
l
=
[
IDENT
|
keyword
];
f
=
opt_field_pat
;
OPT
";"
->
let
(
o
,
x
,
y
)
=
match
f
with
|
None
->
(
false
,
mknoloc
(
PatVar
(
None
,
ident
l
)
)
,
None
)
|
None
->
(
false
,
mknoloc
(
PatVar
[
ident
l
]
)
,
None
)
|
Some
z
->
z
in
let
x
=
if
o
then
mk
loc
(
Optional
x
)
else
x
in
...
...
schema/schema_converter.ml
View file @
73e03a54
...
...
@@ -168,13 +168,13 @@ let attr_group ag = attr_uses ag.ag_def
let
load_schema
schema_name
uri
=
let
schema_name
=
Utf8
.
get_str
schema_name
in
let
log_schema_component
kind
name
cd_type
=
if
not
(
Schema_builtin
.
is
name
)
then
begin
Types
.
Print
.
register_global
schema_name
name
cd_type
;
Format
.
fprintf
Format
.
std_formatter
"Registering schema %s: %a@."
kind
Ns
.
QName
.
print
name
;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
end
in
let
env
=
ref
Env
.
empty
in
...
...
@@ -196,7 +196,7 @@ let load_schema schema_name uri =
(
fun
x
->
VType
x
)
schema
.
types
;
defs
"element"
(
fun
e
->
Atoms
.
V
.
value
e
.
elt_name
)
elt_decl
(
fun
x
->
VElem
x
)
schema
.
elements
;
Obj
.
magic
!
env
schema
.
targetNamespace
,
!
env
let
()
=
...
...
typing/typer.ml
View file @
73e03a54
...
...
@@ -29,74 +29,116 @@ 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
schema
=
{
sch_uri
:
string
;
sch_ns
:
Ns
.
Uri
.
t
;
sch_comps
:
(
Types
.
t
*
Schema_validator
.
t
)
Ident
.
Env
.
t
;
}
type
item
=
(* These are really exported by CDuce units: *)
|
Type
of
Types
.
t
|
Val
of
Types
.
t
type
ext
=
|
ECDuce
of
Compunit
.
t
(* CDuce unit *)
|
EOCaml
of
string
(* OCaml module *)
|
ESchema
of
string
(* XML Schema *)
module
UEnv
=
Map
.
Make
(
U
)
|
ECDuce
of
Compunit
.
t
|
ESchema
of
schema
|
ENamespace
of
Ns
.
Uri
.
t
(* These are only used internally: *)
|
EVal
of
Compunit
.
t
*
id
*
Types
.
t
|
EOCaml
of
string
|
EOCamlComponent
of
string
|
ESchemaComponent
of
(
Types
.
t
*
Schema_validator
.
t
)
type
t
=
{
ids
:
item
Env
.
t
;
ns
:
Ns
.
table
;
cu
:
ext
UEnv
.
t
;
keep_ns
:
bool
}
(* Namespaces *)
let
set_ns_table_for_printer
env
=
Ns
.
InternalPrinter
.
set_table
env
.
ns
let
get_ns_table
tenv
=
tenv
.
ns
let
type_keep_ns
env
k
=
{
env
with
keep_ns
=
k
}
let
protect_error_ns
loc
f
x
=
try
f
x
with
Ns
.
UnknownPrefix
ns
->
raise_loc_generic
loc
(
"Undefined namespace prefix "
^
(
U
.
to_string
ns
))
let
qname
env
loc
t
=
protect_error_ns
loc
(
Ns
.
map_tag
env
.
ns
)
t
let
ident
env
loc
t
=
protect_error_ns
loc
(
Ns
.
map_attr
env
.
ns
)
t
let
has_value
id
env
=
try
match
Env
.
find
(
Ident
.
ident
(
Ns
.
map_attr
env
.
ns
id
))
env
.
ids
with
|
Val
t
->
true
|
_
->
false
with
Not_found
|
Ns
.
UnknownPrefix
_
->
false
let
parse_atom
env
loc
t
=
Atoms
.
V
.
mk
(
qname
env
loc
t
)
let
parse_ns
env
loc
ns
=
protect_error_ns
loc
(
Ns
.
map_prefix
env
.
ns
)
ns
let
parse_label
env
loc
t
=
Label
.
mk
(
protect_error_ns
loc
(
Ns
.
map_attr
env
.
ns
)
t
)
let
parse_record
env
loc
f
r
=
let
r
=
List
.
map
(
fun
(
l
,
x
)
->
(
parse_label
env
loc
l
,
f
x
))
r
in
LabelMap
.
from_list
(
fun
_
_
->
raise_loc_generic
loc
"Duplicated record field"
)
r
let
load_schema
=
ref
(
fun
_
_
->
assert
false
)
let
from_comp_unit
=
ref
(
fun
_
->
assert
false
)
let
load_comp_unit
=
ref
(
fun
_
->
assert
false
)
let
has_ocaml_unit
=
ref
(
fun
_
->
false
)
let
has_static_external
=
ref
(
fun
_
->
assert
false
)
let
schemas
=
Hashtbl
.
create
13
let
type_schema
env
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
}
let
type_schema
env
loc
name
uri
=
let
x
=
ident
env
loc
name
in
let
(
ns
,
sch
)
=
!
load_schema
(
U
.
to_string
name
)
uri
in
let
sch
=
{
sch_uri
=
uri
;
sch_comps
=
sch
;
sch_ns
=
ns
}
in
{
env
with
ids
=
Env
.
add
x
(
ESchema
sch
)
env
.
ids
}
let
empty_env
=
{
ids
=
Env
.
empty
;
ns
=
Ns
.
def_table
;
cu
=
UEnv
.
empty
;
keep_ns
=
false
}
let
enter_cu
x
cu
env
=
{
env
with
cu
=
UEnv
.
add
x
(
ECDuce
cu
)
env
.
cu
}
let
find_cu
loc
x
env
=
try
UEnv
.
find
x
env
.
cu
with
Not_found
->
try
ECDuce
(
!
load_comp_unit
x
)
with
Not_found
->
if
!
has_ocaml_unit
x
then
(
EOCaml
(
U
.
get_str
x
))
else
error
loc
(
"Cannot find external unit "
^
(
U
.
to_string
x
))
let
enter_id
x
i
env
=
{
env
with
ids
=
Env
.
add
x
i
env
.
ids
}
let
find_schema
x
env
=
let
type_using
env
loc
x
cu
=
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
}
let
cu
=
!
load_comp_unit
cu
in
enter_id
(
ident
env
loc
x
)
(
ECDuce
cu
)
env
with
Not_found
->
error
loc
(
"Cannot find external unit "
^
(
U
.
to_string
cu
))
let
enter_type
id
t
env
=
enter_id
id
(
Type
t
)
env
let
enter_types
l
env
=
{
env
with
ids
=
List
.
fold_left
(
fun
accu
(
id
,
t
)
->
Env
.
add
id
(
Type
t
)
accu
)
env
.
ids
l
}
let
find_type
id
env
=
match
Env
.
find
id
env
.
ids
with
|
Type
t
->
t
|
Val
_
->
raise
Not_found
let
find_id
env0
env
loc
head
x
=
let
id
=
ident
env0
loc
x
in
try
Env
.
find
id
env
.
ids
with
Not_found
when
head
->
try
ECDuce
(
!
load_comp_unit
x
)
with
Not_found
->
if
!
has_ocaml_unit
x
then
(
EOCaml
(
U
.
get_str
x
))
else
error
loc
"Cannot resolve this identifier"
let
enter_value
id
t
env
=
{
env
with
ids
=
Env
.
add
id
(
Val
t
)
env
.
ids
}
...
...
@@ -106,14 +148,12 @@ let enter_values l env =
let
enter_values_dummy
l
env
=
{
env
with
ids
=
List
.
fold_left
(
fun
accu
id
->
Env
.
add
id
(
Val
Types
.
empty
)
accu
)
env
.
ids
l
}
let
find_value
id
env
=
match
Env
.
find
id
env
.
ids
with
|
Val
t
->
t
|
_
->
raise
Not_found
let
find_value_global
loc
cu
id
env
=
(*
let find_value_global loc cu id =
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
|
Val
t
->
true
...
...
@@ -132,48 +172,6 @@ let register_types cu env =
|
_
->
()
)
env
.
ids
(* Namespaces *)
let
set_ns_table_for_printer
env
=
Ns
.
InternalPrinter
.
set_table
env
.
ns
let
get_ns_table
tenv
=
tenv
.
ns
let
type_ns
env
p
ns
=
{
env
with
ns
=
Ns
.
add_prefix
p
ns
env
.
ns
}
let
type_keep_ns
env
k
=
{
env
with
keep_ns
=
k
}
let
protect_error_ns
loc
f
x
=
try
f
x
with
Ns
.
UnknownPrefix
ns
->
raise_loc_generic
loc
(
"Undefined namespace prefix "
^
(
U
.
to_string
ns
))
let
qname
env
loc
t
=
protect_error_ns
loc
(
Ns
.
map_tag
env
.
ns
)
t
let
ident
env
loc
t
=
protect_error_ns
loc
(
Ns
.
map_attr
env
.
ns
)
t
let
has_value
id
env
=
try
match
Env
.
find
(
Ident
.
ident
(
Ns
.
map_attr
env
.
ns
id
))
env
.
ids
with
|
Val
t
->
true
|
_
->
false
with
Not_found
|
Ns
.
UnknownPrefix
_
->
false
let
parse_atom
env
loc
t
=
Atoms
.
V
.
mk
(
qname
env
loc
t
)
let
parse_ns
env
loc
ns
=
protect_error_ns
loc
(
Ns
.
map_prefix
env
.
ns
)
ns
let
parse_label
env
loc
t
=
Label
.
mk
(
protect_error_ns
loc
(
Ns
.
map_attr
env
.
ns
)
t
)
let
parse_record
env
loc
f
r
=
let
r
=
List
.
map
(
fun
(
l
,
x
)
->
(
parse_label
env
loc
l
,
f
x
))
r
in
LabelMap
.
from_list
(
fun
_
_
->
raise_loc_generic
loc
"Duplicated record field"
)
r
let
rec
const
env
loc
=
function
|
LocatedExpr
(
loc
,
e
)
->
const
env
loc
e
...
...
@@ -191,26 +189,85 @@ let rec const env loc = function
the internal form *)
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
find_schema_descr
uri
(
name
:
Ns
.
QName
.
t
)
=
try
find_schema_component
uri
name
let
find_schema_component
sch
name
=
try
ESchemaComponent
(
Env
.
find
name
sch
.
sch_comps
)
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"No component named '%s' found in schema '%s'"
(
Ns
.
QName
.
to_string
name
)
uri
))
(
Ns
.
QName
.
to_string
name
)
sch
.
sch_uri
))
let
navig
loc
env0
(
env
,
comp
)
id
=
match
comp
with
|
ECDuce
cu
->
let
env
=
!
from_comp_unit
cu
in
let
c
=
try
find_id
env0
env
loc
false
id
with
Not_found
->
error
loc
"Unbound identifier"
in
let
c
=
match
c
with
|
Val
t
->
EVal
(
cu
,
ident
env0
loc
id
,
t
)
|
c
->
c
in
env
,
c
|
EOCaml
cu
->
let
s
=
cu
^
"."
^
(
U
.
get_str
id
)
in
(
match
(
U
.
get_str
id
)
.
[
0
]
with
|
'
A'
..
'
Z'
->
env
,
EOCaml
s
|
_
->
env
,
EOCamlComponent
s
)
|
ESchema
sch
->
env
,
find_schema_component
sch
(
ident
env0
loc
id
)
|
_
->
error
loc
"Invalid dot access"
let
rec
find_global
env
loc
ids
=
match
ids
with
|
id
::
rest
->
let
comp
=
find_id
env
env
loc
true
id
in
snd
(
List
.
fold_left
(
navig
loc
env
)
(
env
,
comp
)
rest
)
|
_
->
assert
false
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
->
fst
(
find_schema_descr
s
(
Ident
.
value
id
))
let
eval_ns
env
loc
=
function
|
`Uri
ns
->
ns
|
`Path
ids
->
match
find_global
env
loc
ids
with
|
ENamespace
ns
->
ns
|
ESchema
sch
->
sch
.
sch_ns