Skip to content
GitLab
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
4b4c0821
Commit
4b4c0821
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-07-02 23:26:38 by afrisch] Serialize schema by reference
Original author: afrisch Date: 2004-07-02 23:26:39+00:00
parent
1e3a9cba
Changes
11
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
4b4c0821
...
...
@@ -134,6 +134,14 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests
# Objects to build
SCHEMA_OBJS
=
\
schema/schema_types.cmo
\
schema/schema_xml.cmo
\
schema/schema_common.cmo
\
schema/schema_builtin.cmo
\
schema/schema_validator.cmo
\
schema/schema_parser.cmo
\
OBJECTS
=
\
driver/config.cmo
\
misc/stats.cmo
\
...
...
@@ -150,12 +158,7 @@ OBJECTS = \
compile/lambda.cmo
\
runtime/value.cmo
\
\
schema/schema_types.cmo
\
schema/schema_xml.cmo
\
schema/schema_common.cmo
\
schema/schema_builtin.cmo
\
schema/schema_validator.cmo
\
schema/schema_parser.cmo
\
$(SCHEMA_OBJS)
\
\
parser/location.cmo parser/url.cmo parser/ulexer.cmo parser/ast.cmo parser/parser.cmo
\
\
...
...
compile/compile.ml
View file @
4b4c0821
...
...
@@ -234,6 +234,11 @@ let namespace (tenv,cenv,codes) pr ns =
let
tenv
=
Typer
.
enter_ns
pr
ns
tenv
in
(
tenv
,
cenv
,
codes
)
let
schema
(
tenv
,
cenv
,
codes
)
x
sch
=
ignore
(
Typer
.
get_schema
sch
);
(* To raise the error here ... *)
let
tenv
=
Typer
.
enter_schema
x
sch
tenv
in
(
tenv
,
cenv
,
codes
)
let
find_cu
(
tenv
,_,_
)
cu
=
Typer
.
find_cu
cu
tenv
...
...
@@ -259,9 +264,8 @@ 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
,
schema
)
}
::
rest
->
Typer
.
register_schema
name
schema
;
loop
accu
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
.
Using
(
x
,
cu
)
}
::
rest
->
...
...
compile/lambda.ml
View file @
4b4c0821
...
...
@@ -20,6 +20,25 @@ let print_var_loc ppf = function
type
schema_component_kind
=
[
`Type
|
`Element
|
`Attribute
|
`Attribute_group
|
`Model_group
]
option
let
serialize_schema_component_kind
s
x
=
Serialize
.
Put
.
bits
3
s
(
match
x
with
|
Some
`Type
->
0
|
Some
`Element
->
1
|
Some
`Attribute
->
2
|
Some
`Attribute_group
->
3
|
Some
`Model_group
->
4
|
None
->
5
)
let
deserialize_schema_component_kind
s
=
match
Serialize
.
Get
.
bits
3
s
with
|
0
->
Some
`Type
|
1
->
Some
`Element
|
2
->
Some
`Attribute
|
3
->
Some
`Attribute_group
|
4
->
Some
`Model_group
|
5
->
None
|
_
->
assert
false
type
expr
=
|
Var
of
var_loc
|
Apply
of
bool
*
expr
*
expr
...
...
@@ -36,7 +55,7 @@ type expr =
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
schema_component_kind
*
U
.
t
*
U
.
t
|
Validate
of
expr
*
schema_component_kind
*
string
*
U
.
t
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
UnaryOp
of
int
*
expr
...
...
@@ -164,7 +183,12 @@ module Put = struct
expr
s
e
;
branches
s
brs
|
Validate
(
e
,
k
,
sch
,
t
)
->
assert
false
(* TODO:Need to store a pointer to the schema ... *)
bits
nbits
s
13
;
expr
s
e
;
serialize_schema_component_kind
s
k
;
string
s
sch
;
U
.
serialize
s
t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
|
RemoveField
(
e
,
l
)
->
bits
nbits
s
14
;
expr
s
e
;
...
...
@@ -276,7 +300,12 @@ module Get = struct
let
e
=
expr
s
in
let
brs
=
branches
s
in
Try
(
e
,
brs
)
|
13
->
assert
false
|
13
->
let
e
=
expr
s
in
let
k
=
deserialize_schema_component_kind
s
in
let
sch
=
string
s
in
let
t
=
U
.
deserialize
s
in
Validate
(
e
,
k
,
sch
,
t
)
|
14
->
let
e
=
expr
s
in
let
l
=
LabelPool
.
deserialize
s
in
...
...
compile/lambda.mli
0 → 100644
View file @
4b4c0821
open
Ident
type
var_loc
=
|
Stack
of
int
|
Env
of
int
|
Ext
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
External
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
Global
of
int
(* Only for the toplevel *)
|
Dummy
type
schema_component_kind
=
[
`Type
|
`Element
|
`Attribute
|
`Attribute_group
|
`Model_group
]
option
type
expr
=
|
Var
of
var_loc
|
Apply
of
bool
*
expr
*
expr
|
Abstraction
of
var_loc
array
*
(
Types
.
t
*
Types
.
t
)
list
*
branches
|
Const
of
Types
.
Const
.
t
|
Pair
of
expr
*
expr
|
Xml
of
expr
*
expr
*
expr
|
Record
of
expr
label_map
|
String
of
U
.
uindex
*
U
.
uindex
*
U
.
t
*
expr
|
Match
of
expr
*
branches
|
Map
of
expr
*
branches
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
schema_component_kind
*
string
*
U
.
t
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
brs_tail
:
bool
;
brs_input
:
Types
.
t
;
brs_accept_chars
:
bool
;
mutable
brs_compiled
:
(
Patterns
.
Compile
.
dispatcher
*
expr
Patterns
.
Compile
.
rhs
array
)
option
}
type
code_item
=
|
Push
of
expr
|
Pop
|
Split
of
Patterns
.
node
|
SetGlobal
of
Types
.
CompUnit
.
t
*
int
type
code
=
code_item
list
module
Put
:
sig
val
unary_op
:
(
Serialize
.
Put
.
t
->
int
->
unit
)
ref
val
binary_op
:
(
Serialize
.
Put
.
t
->
int
->
unit
)
ref
val
var_loc
:
Serialize
.
Put
.
t
->
var_loc
->
unit
val
expr
:
expr
Serialize
.
Put
.
f
val
branches
:
Serialize
.
Put
.
t
->
branches
->
unit
val
code_item
:
Serialize
.
Put
.
t
->
code_item
->
unit
val
codes
:
code_item
list
Serialize
.
Put
.
f
val
compunit
:
Serialize
.
Put
.
t
->
code_item
list
->
unit
end
module
Get
:
sig
val
unary_op
:
(
Serialize
.
Get
.
t
->
int
)
ref
val
binary_op
:
(
Serialize
.
Get
.
t
->
int
)
ref
val
var_loc
:
Serialize
.
Get
.
t
->
var_loc
val
expr
:
expr
Serialize
.
Get
.
f
val
branches
:
Serialize
.
Get
.
t
->
branches
val
code_item
:
Serialize
.
Get
.
t
->
code_item
val
codes
:
code_item
list
Serialize
.
Get
.
f
val
compunit
:
Serialize
.
Get
.
t
->
code_item
list
end
val
print_var_loc
:
Format
.
formatter
->
var_loc
->
unit
depend
View file @
4b4c0821
...
...
@@ -71,17 +71,15 @@ types/builtin_defs.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx misc/ns.cmx types/sequence.cmx \
types/types.cmx types/builtin_defs.cmi
compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
types/types.cmi
types/types.cmi
compile/lambda.cmi
compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx
types/types.cmx
compile/lambda.cmi
runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi compile/lambda.cm
o
\
misc/encodings.cmi types/ident.cmo types/intervals.cmi compile/lambda.cm
i
\
misc/ns.cmi types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi
types/externals.cmo: parser/location.cmi types/externals.cmi
types/externals.cmx: parser/location.cmx types/externals.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
...
...
@@ -142,6 +140,8 @@ parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
parser/location.cmx misc/ns.cmx schema/schema_parser.cmx \
types/sequence.cmx types/types.cmx parser/ulexer.cmx parser/url.cmx \
parser/parser.cmi
types/externals.cmo: parser/location.cmi types/externals.cmi
types/externals.cmx: parser/location.cmx types/externals.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
schema/schema_types.cmi types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
...
...
@@ -186,7 +186,7 @@ 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
runtime/eval.cmo: types/ident.cmo compile/lambda.cm
o
types/patterns.cmi \
runtime/eval.cmo: types/ident.cmo compile/lambda.cm
i
types/patterns.cmi \
runtime/run_dispatch.cmi schema/schema_common.cmi schema/schema_types.cmi \
schema/schema_validator.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi runtime/eval.cmi
...
...
@@ -195,14 +195,14 @@ runtime/eval.cmx: types/ident.cmx compile/lambda.cmx types/patterns.cmx \
schema/schema_validator.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: parser/ast.cmo runtime/eval.cmi types/ident.cmo \
compile/lambda.cm
o
parser/location.cmi types/patterns.cmi \
compile/lambda.cm
i
parser/location.cmi types/patterns.cmi \
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
compile/compile.cmi
compile/compile.cmx: parser/ast.cmx runtime/eval.cmx types/ident.cmx \
compile/lambda.cmx parser/location.cmx types/patterns.cmx \
misc/serialize.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
compile/compile.cmi
compile/operators.cmo: misc/custom.cmo runtime/eval.cmi compile/lambda.cm
o
\
compile/operators.cmo: misc/custom.cmo runtime/eval.cmi compile/lambda.cm
i
\
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
compile/operators.cmx: misc/custom.cmx runtime/eval.cmx compile/lambda.cmx \
...
...
@@ -220,7 +220,7 @@ types/builtin.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
runtime/value.cmx types/builtin.cmi
driver/librarian.cmo: types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi types/externals.cmi types/ident.cmo \
compile/lambda.cm
o
parser/location.cmi parser/parser.cmi \
compile/lambda.cm
i
parser/location.cmi parser/parser.cmi \
misc/serialize.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
driver/librarian.cmi
driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
...
...
@@ -240,22 +240,6 @@ driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
types/ident.cmo driver/librarian.cmi types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
types/ident.cmx driver/librarian.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi ocamliface/mltypes.cmi \
misc/ns.cmi types/sequence.cmi typing/typer.cmi types/types.cmi \
ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
compile/compile.cmx driver/config.cmx types/externals.cmx types/ident.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 \
...
...
@@ -311,9 +295,8 @@ types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sample.cmi: types/types.cmi
types/builtin_defs.cmi: types/atoms.cmi types/ident.cmo types/types.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cm
o
misc/ns.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cm
i
misc/ns.cmi \
types/types.cmi
types/externals.cmi: types/types.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
...
...
@@ -324,6 +307,7 @@ schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \
schema/schema_validator.cmi: schema/schema_types.cmi runtime/value.cmi
schema/schema_parser.cmi: schema/schema_types.cmi schema/schema_xml.cmi
parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi
typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_types.cmi typing/typed.cmo types/types.cmi
...
...
@@ -331,9 +315,9 @@ runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/explain.cmi: types/types.cmi runtime/value.cmi
runtime/print_xml.cmi: misc/ns.cmi runtime/value.cmi
runtime/eval.cmi: types/ident.cmo compile/lambda.cm
o
types/types.cmi \
runtime/eval.cmi: types/ident.cmo compile/lambda.cm
i
types/types.cmi \
runtime/value.cmi
compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cm
o
\
compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cm
i
\
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi
compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
...
...
@@ -341,7 +325,6 @@ compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: compile/compile.cmi types/ident.cmo typing/typer.cmi \
types/types.cmi runtime/value.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
query/query.cmi: parser/ast.cmo
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
driver/cduce.ml
View file @
4b4c0821
...
...
@@ -57,7 +57,7 @@ let dump_env ppf tenv cenv =
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
()
)));
(
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
))
...
...
@@ -214,13 +214,15 @@ let directive ppf tenv cenv = function
|
`Env
->
dump_env
ppf
tenv
cenv
|
`Print_schema
schema
->
Schema_common
.
print_schema
ppf
(
Typer
.
get_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
name
->
Typer
.
dump_type
ppf
tenv
name
;
flush_ppf
ppf
|
`Print_schema_type
schema_ref
->
Typer
.
dump_schema_type
ppf
schema_ref
;
Typer
.
dump_schema_type
ppf
tenv
schema_ref
;
flush_ppf
ppf
|
`Reinit_ns
->
Typer
.
set_ns_table_for_printer
tenv
...
...
parser/ast.ml
View file @
4b4c0821
...
...
@@ -8,7 +8,7 @@ type pprog = pmodule_item list
and
pmodule_item
=
pmodule_item'
located
and
pmodule_item'
=
|
TypeDecl
of
id
*
ppat
|
SchemaDecl
of
U
.
t
*
Schema_types
.
schema
(* name,
schema
*)
|
SchemaDecl
of
U
.
t
*
string
(* name,
uri
*)
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
|
Namespace
of
U
.
t
*
Ns
.
t
...
...
parser/parser.ml
View file @
4b4c0821
...
...
@@ -112,10 +112,7 @@ EXTEND
[
mk
loc
(
Using
(
U
.
mk
name
,
U
.
mk
cu
))
]
|
"schema"
;
name
=
IDENT
;
"="
;
uri
=
STRING2
->
protect_op
"schema"
;
let
schema
=
match
Url
.
process
uri
with
|
Url
.
Filename
s
->
Schema_parser
.
schema_of_file
s
|
Url
.
Url
s
->
Schema_parser
.
schema_of_string
s
in
[
mk
loc
(
SchemaDecl
(
U
.
mk
name
,
schema
))
]
[
mk
loc
(
SchemaDecl
(
U
.
mk
name
,
uri
))
]
|
(
name
,
ns
)
=
namespace_binding
->
[
mk
loc
(
Namespace
(
name
,
ns
))
]
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
...
...
typing/typed.ml
View file @
4b4c0821
...
...
@@ -41,8 +41,8 @@ and texpr' =
|
Map
of
texpr
*
branches
|
Transform
of
texpr
*
branches
|
Xtrans
of
texpr
*
branches
|
Validate
of
texpr
*
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
(* exp, schema component kind, schema
name
, element name *)
|
Validate
of
texpr
*
Schema_types
.
component_kind
*
string
*
U
.
t
(* exp, schema component kind, schema
uri
, element name *)
|
RemoveField
of
texpr
*
label
|
Dot
of
texpr
*
label
...
...
typing/typer.ml
View file @
4b4c0821
...
...
@@ -16,6 +16,19 @@ let warning loc msg =
Location
.
html_hilight
(
loc
,
`Full
)
msg
exception
NonExhaustive
of
Types
.
descr
exception
Constraint
of
Types
.
descr
*
Types
.
descr
exception
ShouldHave
of
Types
.
descr
*
string
exception
ShouldHave2
of
Types
.
descr
*
string
*
Types
.
descr
exception
WrongLabel
of
Types
.
descr
*
label
exception
UnboundId
of
id
*
bool
exception
UnboundExtId
of
Types
.
CompUnit
.
t
*
id
exception
Error
of
string
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
...
...
@@ -26,6 +39,7 @@ type t = {
ids
:
item
Env
.
t
;
ns
:
Ns
.
table
;
cu
:
Types
.
CompUnit
.
t
UEnv
.
t
;
schemas
:
string
UEnv
.
t
}
let
hash
_
=
failwith
"Typer.hash"
...
...
@@ -49,16 +63,16 @@ 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
{
ids
=
ids
;
ns
=
ns
;
cu
=
UEnv
.
empty
}
{
ids
=
ids
;
ns
=
ns
;
cu
=
UEnv
.
empty
;
schemas
=
UEnv
.
empty
}
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
)
...
...
@@ -71,6 +85,12 @@ let find_cu x env =
with
Not_found
->
Types
.
CompUnit
.
mk
x
let
enter_schema
x
uri
env
=
{
env
with
schemas
=
UEnv
.
add
x
uri
env
.
schemas
}
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
)))
let
enter_type
id
t
env
=
{
env
with
ids
=
Env
.
add
id
(
Type
t
)
env
.
ids
}
let
enter_types
l
env
=
...
...
@@ -167,22 +187,13 @@ let rec const env loc = function
(* I. Transform the abstract syntax of types and patterns into
the internal form *)
exception
NonExhaustive
of
Types
.
descr
exception
Constraint
of
Types
.
descr
*
Types
.
descr
exception
ShouldHave
of
Types
.
descr
*
string
exception
ShouldHave2
of
Types
.
descr
*
string
*
Types
.
descr
exception
WrongLabel
of
Types
.
descr
*
label
exception
UnboundId
of
id
*
bool
exception
UnboundExtId
of
Types
.
CompUnit
.
t
*
id
exception
Error
of
string
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
)
(* Schema *)
(* just to remember imported schemas *)
let
is_registered_schema
env
s
=
UEnv
.
mem
s
env
.
schemas
(* uri -> schema binding *)
let
schemas
=
State
.
ref
"Typer.schemas"
(
Hashtbl
.
create
3
)
let
is_registered_schema
=
Hashtbl
.
mem
!
schemas
let
schema_types
=
State
.
ref
"Typer.schema_types"
(
Hashtbl
.
create
51
)
let
schema_elements
=
State
.
ref
"Typer.schema_elements"
(
Hashtbl
.
create
51
)
...
...
@@ -192,38 +203,43 @@ let schema_attribute_groups =
let
schema_model_groups
=
State
.
ref
"Typer.schema_model_groups"
(
Hashtbl
.
create
51
)
(* raise Not_found *)
let
find_schema_descr
kind
schema
name
=
let
elt
()
=
Hashtbl
.
find
!
schema_elements
(
schema
,
name
)
in
let
typ
()
=
Hashtbl
.
find
!
schema_types
(
schema
,
name
)
in
let
att
()
=
Hashtbl
.
find
!
schema_attributes
(
schema
,
name
)
in
let
att_group
()
=
Hashtbl
.
find
!
schema_attribute_groups
(
schema
,
name
)
in
let
mod_group
()
=
Hashtbl
.
find
!
schema_model_groups
(
schema
,
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
]
(* as above, but raise Error *)
let
find_schema_descr'
k
s
n
=
let
get_schema_fwd
=
ref
(
fun
_
->
assert
false
)
let
find_schema_descr_uri
kind
uri
name
=
try
find_schema_descr
k
s
n
with
Not_found
->
if
is_registered_schema
s
then
ignore
(
!
get_schema_fwd
uri
);
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
k
)
(
U
.
get_str
n
)
(
U
.
get_str
s
)))
else
raise
(
Error
(
Printf
.
sprintf
"%s: no such schema"
(
U
.
get_str
s
)))
(
Schema_common
.
string_of_component_kind
kind
)
(
U
.
get_str
name
)
uri
))
let
find_schema_descr
env
kind
schema
name
=
let
uri
=
find_schema
schema
env
in
find_schema_descr_uri
kind
uri
name
(* Eliminate Recursion, propagate Sequence Capture Variables *)
...
...
@@ -500,7 +516,7 @@ let rec derecurs env p = match p.descr with
raise_loc_generic
p
.
loc
(
"Unbound external type "
^
cu
^
":"
^
(
U
.
to_string
v
)))
|
SchemaVar
(
kind
,
schema_name
,
component_name
)
->
PType
(
derecurs_schema
env
kind
schema_name
component_name
)
PType
(
find_schema_descr
env
.
penv_t
env
kind
schema_name
component_name
)
|
Recurs
(
p
,
b
)
->
derecurs
(
derecurs_def
env
b
)
p
|
Internal
t
->
PType
t
|
NsT
ns
->
PType
(
Types
.
atom
(
Atoms
.
any_in_ns
(
parse_ns
env
.
penv_tenv
p
.
loc
ns
)))
...
...
@@ -546,8 +562,6 @@ and derecurs_def env b =
List
.
iter
(
fun
(
v
,
p
,
s
)
->
s
.
pdescr
<-
derecurs
env
p
)
b
;
env
and
derecurs_schema
env
=
find_schema_descr
let
rec
fv_slot
s
=
match
s
.
fv
with
|
Some
x
->
x
...
...
@@ -790,8 +804,9 @@ let dump_type ppf env name =
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"Type %s not found"
(
U
.
get_str
name
)))
let
dump_schema_type
ppf
(
k
,
s
,
n
)
=
let
descr
=
find_schema_descr'
k
s
n
in
let
dump_schema_type
ppf
env
(
k
,
s
,
n
)
=
let
uri
=
find_schema
s
env
in
let
descr
=
find_schema_descr_uri
k
uri
n
in
Types
.
Print
.
print
ppf
descr
let
dump_ns
ppf
env
=
...
...
@@ -933,7 +948,8 @@ let rec expr env loc = function
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Xtrans
(
e
,
b
))
|
Validate
(
e
,
kind
,
schema
,
elt
)
->
let
(
fv
,
e
)
=
expr
env
loc
e
in
exp
loc
fv
(
Typed
.
Validate
(
e
,
kind
,
schema
,
elt
))
let
uri
=
find_schema
schema
env
in
exp
loc
fv
(
Typed
.
Validate
(
e
,
kind
,
uri
,
elt
))
|
Try
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
env
loc
e
and
(
fv2
,
b
)
=
branches
env
b
in
...
...
@@ -1154,9 +1170,9 @@ and type_check' loc env e constr precise = match e with
)
t
in
verify
loc
t
constr
|
Validate
(
e
,
kind
,
schema_name
,
name
)
->
|
Validate
(
e
,
kind
,
uri
,
name
)
->
ignore
(
type_check
env
e
Types
.
any
false
);
let
t
=
find_schema_descr
'
kind
schema_name
name
in
let
t
=
find_schema_descr
_uri
kind
uri
name
in
verify
loc
t
constr
|
Ref
(
e
,
t
)
->
...
...
@@ -1570,60 +1586,60 @@ module Schema_converter =
end
let
get_schema
name
=
try
Hashtbl
.
find
!
schemas
name
with
Not_found
->
raise
(
Error
(
Printf
.
sprintf
"Schema '%s' not found"
(
U
.
get_str
name
)))
let
get_schema_names
env
=
UEnv
.
fold
(
fun
n
_
acc
->
n
::
acc
)
env
.
schemas
[]
let
get_schema_names
()
=
Hashtbl
.
fold
(
fun
n
_
acc
->
n
::
acc
)
!
schemas
[]
let
get_schema
uri
=
try
Hashtbl
.
find
!
schemas
uri
with
Not_found
->
let
schema
=
match
Url
.
process
uri
with
|
Url
.
Filename
s
->
Schema_parser
.
schema_of_file
s
|
Url
.
Url
s
->
Schema_parser
.
schema_of_string
s
in
let
register_schema
schema_name
schema
=
if
is_registered_schema
schema_name
then
failwith
(
"Redefinition of schema "
^
U
.
get_str
schema_name
)
else
begin
let
log_schema_component
kind
schema
name
cd_type
=
if
not
(
Schema_builtin
.
is_builtin
name
)
then
begin
let
log_schema_component
kind
uri
name
cd_type
=
(* if not (Schema_builtin.is_builtin name) then begin
Format.fprintf Format.std_formatter
"Registering schema %s: %s # %s"
kind
(
U
.
get_str
schema
)
(
U
.
get_str
name
);
kind
uri
(U.get_str name);
if debug_schema then
Types.Print.print Format.std_formatter cd_type;