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
097b5407
Commit
097b5407
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-02-21 07:15:03 by afrisch] Empty log message
Original author: afrisch Date: 2005-02-21 07:15:04+00:00
parent
4059b145
Changes
5
Hide whitespace changes
Inline
Side-by-side
misc/stats.ml
View file @
097b5407
...
...
@@ -60,3 +60,34 @@ module Counter = struct
let
incr
c
=
c
.
count
<-
c
.
count
+
1
end
module
InOut
=
struct
let
h
=
Hashtbl
.
create
17
let
enter
s
=
let
i
=
try
Hashtbl
.
find
h
s
with
Not_found
->
let
r
=
ref
0
in
Hashtbl
.
add
h
s
r
;
r
in
incr
i
;
Printf
.
printf
"+%s[%i] "
s
!
i
;
flush
stdout
let
leave
s
=
let
i
=
try
Hashtbl
.
find
h
s
with
Not_found
->
assert
false
in
decr
i
;
Printf
.
printf
"-%s[%i] "
s
!
i
;
flush
stdout
let
wrap
s
f
x
=
enter
s
;
try
let
r
=
f
x
in
leave
s
;
r
with
exn
->
leave
s
;
raise
exn
end
misc/stats.mli
View file @
097b5407
...
...
@@ -20,3 +20,10 @@ module Timer: sig
val
stop
:
t
->
'
a
->
'
a
val
print
:
Format
.
formatter
->
t
->
unit
end
module
InOut
:
sig
val
enter
:
string
->
unit
val
leave
:
string
->
unit
val
wrap
:
string
->
(
'
a
->
'
b
)
->
'
a
->
'
b
end
schema/schema_common.ml
View file @
097b5407
...
...
@@ -214,7 +214,7 @@ let print_element fmt { elt_uid = id; elt_name = name } =
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
let
print_attribute_group
fmt
ag
=
Format
.
fprintf
fmt
"{agroup:%a}"
Ns
.
QName
.
print
ag
.
ag_name
let
print_model_group
fmt
mg
=
let
print_model_group
_def
fmt
mg
=
Format
.
fprintf
fmt
"{mgroup:%a}"
Ns
.
QName
.
print
mg
.
mg_name
let
print_schema
fmt
schema
=
let
defined_types
=
(* filter out built-in types *)
...
...
@@ -248,7 +248,7 @@ let print_schema fmt schema =
end
;
if
schema
.
model_groups
<>
[]
then
begin
Format
.
fprintf
fmt
"Model groups: "
;
List
.
iter
(
fun
c
->
print_model_group
fmt
c
;
Format
.
fprintf
fmt
" "
)
List
.
iter
(
fun
c
->
print_model_group
_def
fmt
c
;
Format
.
fprintf
fmt
" "
)
schema
.
model_groups
;
Format
.
fprintf
fmt
"
\n
"
end
...
...
@@ -421,3 +421,17 @@ let test v =
aux ()
*)
let
rec
print_model_group
ppf
=
function
|
All
pl
->
Format
.
fprintf
ppf
"All(%a)"
print_particle_list
pl
|
Choice
pl
->
Format
.
fprintf
ppf
"Choice(%a)"
print_particle_list
pl
|
Sequence
pl
->
Format
.
fprintf
ppf
"Sequence(%a)"
print_particle_list
pl
and
print_particle_list
ppf
=
function
|
[]
->
()
|
[
p
]
->
print_particle
ppf
p
|
hd
::
tl
->
Format
.
fprintf
ppf
"%a;%a"
print_particle
hd
print_particle_list
tl
and
print_particle
ppf
(
min
,
max
,
term
,_
)
=
print_term
ppf
term
and
print_term
ppf
=
function
|
Elt
e
->
Format
.
fprintf
ppf
"E%i"
((
Lazy
.
force
e
)
.
elt_uid
)
|
Model
m
->
print_model_group
ppf
m
schema/schema_common.mli
View file @
097b5407
...
...
@@ -17,7 +17,7 @@ val print_attribute : Format.formatter -> attribute_declaration -> unit
val
print_element
:
Format
.
formatter
->
element_declaration
->
unit
val
print_attribute_group
:
Format
.
formatter
->
attribute_group_definition
->
unit
val
print_model_group
:
Format
.
formatter
->
model_group_definition
->
unit
val
print_model_group
_def
:
Format
.
formatter
->
model_group_definition
->
unit
val
print_simple_type
:
Format
.
formatter
->
simple_type_definition
->
unit
val
print_complex_type
:
Format
.
formatter
->
complex_type_definition
->
unit
...
...
@@ -93,3 +93,7 @@ val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t
val
stream_of_value
:
Value
.
t
->
event
Stream
.
t
val
string_of_event
:
event
->
string
val
print_model_group
:
Format
.
formatter
->
model_group
->
unit
val
print_particle
:
Format
.
formatter
->
particle
->
unit
typing/typer.ml
View file @
097b5407
...
...
@@ -8,6 +8,12 @@ open Location
open
Ast
open
Ident
let
(
=
)
(
x
:
int
)
y
=
x
=
y
let
(
<=
)
(
x
:
int
)
y
=
x
<=
y
let
(
<
)
(
x
:
int
)
y
=
x
<
y
let
(
>=
)
(
x
:
int
)
y
=
x
>=
y
let
(
>
)
(
x
:
int
)
y
=
x
>
y
let
debug_schema
=
false
let
warning
loc
msg
=
...
...
@@ -274,7 +280,7 @@ type derecurs_slot = {
}
and
derecurs
=
|
PDummy
|
PAlias
of
derecurs_slot
|
PType
of
Types
.
descr
|
PType
of
Types
.
descr
*
int
|
POr
of
derecurs
*
derecurs
|
PAnd
of
derecurs
*
derecurs
|
PDiff
of
derecurs
*
derecurs
...
...
@@ -295,9 +301,34 @@ and derecurs_regexp =
|
PStar
of
derecurs_regexp
|
PWeakStar
of
derecurs_regexp
let
rec
print_derecurs
ppf
=
function
|
PDummy
->
Format
.
fprintf
ppf
"Dummy"
|
PAlias
a
->
Format
.
fprintf
ppf
"Alias %i"
a
.
pid
|
PType
_
->
Format
.
fprintf
ppf
"Type"
|
POr
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"Or(%a,%a)"
print_derecurs
r1
print_derecurs
r2
|
PAnd
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"And(%a,%a)"
print_derecurs
r1
print_derecurs
r2
|
PDiff
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"Diff(%a,%a)"
print_derecurs
r1
print_derecurs
r2
|
PTimes
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"Times(%a,%a)"
print_derecurs
r1
print_derecurs
r2
|
PXml
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"Xml(%a,%a)"
print_derecurs
r1
print_derecurs
r2
|
PRegexp
r
->
Format
.
fprintf
ppf
"Regexp(%a)"
print_regexp
r
|
_
->
Format
.
fprintf
ppf
"Other"
and
print_regexp
ppf
=
function
|
PEpsilon
->
Format
.
fprintf
ppf
"e"
|
PElem
r
->
Format
.
fprintf
ppf
"(%a)"
print_derecurs
r
|
PGuard
r
->
Format
.
fprintf
ppf
"/(%a)"
print_derecurs
r
|
PSeq
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"%a,%a"
print_regexp
r1
print_regexp
r2
|
PAlt
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"%a|%a"
print_regexp
r1
print_regexp
r2
|
PStar
r
|
PWeakStar
r
->
Format
.
fprintf
ppf
"%a*"
print_regexp
r
type
descr
=
|
IDummy
|
IType
of
Types
.
descr
|
IType
of
Types
.
descr
*
int
|
IOr
of
descr
*
descr
|
IAnd
of
descr
*
descr
|
IDiff
of
descr
*
descr
...
...
@@ -338,8 +369,8 @@ let rec hash_derecurs = function
|
PDummy
->
assert
false
|
PAlias
s
->
s
.
pid
|
PType
t
->
1
+
17
*
(
Types
.
hash
t
)
|
PType
(
t
,
hash
)
->
1
+
17
*
hash
|
POr
(
p1
,
p2
)
->
2
+
17
*
(
hash_derecurs
p1
)
+
257
*
(
hash_derecurs
p2
)
|
PAnd
(
p1
,
p2
)
->
...
...
@@ -384,8 +415,8 @@ and hash_derecurs_regexp = function
let
rec
equal_derecurs
p1
p2
=
(
p1
==
p2
)
||
match
p1
,
p2
with
|
PAlias
s1
,
PAlias
s2
->
s1
==
s2
|
PType
t1
,
PType
t2
->
Types
.
equal
t1
t2
|
PType
(
t1
,
h1
)
,
PType
(
t2
,
h2
)
->
(
h1
==
h2
)
&&
(
Types
.
equal
t1
t2
)
|
POr
(
p1
,
q1
)
,
POr
(
p2
,
q2
)
|
PAnd
(
p1
,
q1
)
,
PAnd
(
p2
,
q2
)
|
PDiff
(
p1
,
q1
)
,
PDiff
(
p2
,
q2
)
...
...
@@ -436,7 +467,7 @@ let rank = ref 0
let
rec
hash_descr
=
function
|
IDummy
->
assert
false
|
IType
x
->
Types
.
hash
x
|
IType
(
t
,
h
)
->
h
|
IOr
(
d1
,
d2
)
->
1
+
17
*
(
hash_descr
d1
)
+
257
*
(
hash_descr
d2
)
|
IAnd
(
d1
,
d2
)
->
2
+
17
*
(
hash_descr
d1
)
+
257
*
(
hash_descr
d2
)
|
IDiff
(
d1
,
d2
)
->
3
+
17
*
(
hash_descr
d1
)
+
257
*
(
hash_descr
d2
)
...
...
@@ -460,7 +491,7 @@ and hash_slot s =
let
rec
equal_descr
d1
d2
=
match
(
d1
,
d2
)
with
|
IType
x1
,
IType
x2
->
Types
.
equal
x1
x2
|
IType
(
x1
,
h1
)
,
IType
(
x2
,
h2
)
->
(
h1
==
h2
)
&&
(
Types
.
equal
x1
x2
)
|
IOr
(
x1
,
y1
)
,
IOr
(
x2
,
y2
)
|
IAnd
(
x1
,
y1
)
,
IAnd
(
x2
,
y2
)
|
IDiff
(
x1
,
y1
)
,
IDiff
(
x2
,
y2
)
->
(
equal_descr
x1
x2
)
&&
(
equal_descr
y1
y2
)
...
...
@@ -469,7 +500,7 @@ let rec equal_descr d1 d2 =
|
IXml
(
x1
,
y1
)
,
IXml
(
x2
,
y2
)
|
IArrow
(
x1
,
y1
)
,
IArrow
(
x2
,
y2
)
->
(
equal_slot
x1
x2
)
&&
(
equal_slot
y1
y2
)
|
IRecord
(
o1
,
r1
)
,
IRecord
(
o2
,
r2
)
->
(
o1
=
o2
)
&&
(
LabelMap
.
equal
equal_descr_field
r1
r2
)
(
o1
=
=
o2
)
&&
(
LabelMap
.
equal
equal_descr_field
r1
r2
)
|
ICapture
x1
,
ICapture
x2
->
Id
.
equal
x1
x2
|
IConstant
(
x1
,
y1
)
,
IConstant
(
x2
,
y2
)
->
(
Id
.
equal
x1
x2
)
&&
(
Types
.
Const
.
equal
y1
y2
)
...
...
@@ -509,8 +540,9 @@ module SlotTable = Hashtbl.Make(
e
)
end
)
let
ptype
t
=
PType
(
t
,
Types
.
hash
t
)
let
pempty
=
PT
ype
Types
.
empty
let
pempty
=
pt
ype
Types
.
empty
let
por
p1
p2
=
if
p1
==
pempty
then
p2
else
...
...
@@ -578,10 +610,10 @@ let rec derecurs env p = match p.descr with
|
PatVar
v
->
derecurs_var
env
p
.
loc
v
|
SchemaVar
(
kind
,
schema_name
,
component_name
)
->
let
name
=
qname
env
.
penv_tenv
p
.
loc
component_name
in
PT
ype
(
find_schema_descr
env
.
penv_tenv
kind
schema_name
name
)
pt
ype
(
find_schema_descr
env
.
penv_tenv
kind
schema_name
name
)
|
Recurs
(
p
,
b
)
->
derecurs
(
derecurs_def
env
b
)
p
|
Internal
t
->
PT
ype
t
|
NsT
ns
->
PT
ype
(
Types
.
atom
(
Atoms
.
any_in_ns
(
parse_ns
env
.
penv_tenv
p
.
loc
ns
)))
|
Internal
t
->
pt
ype
t
|
NsT
ns
->
pt
ype
(
Types
.
atom
(
Atoms
.
any_in_ns
(
parse_ns
env
.
penv_tenv
p
.
loc
ns
)))
|
Or
(
p1
,
p2
)
->
POr
(
derecurs
env
p1
,
derecurs
env
p2
)
|
And
(
p1
,
p2
)
->
PAnd
(
derecurs
env
p1
,
derecurs
env
p2
)
|
Diff
(
p1
,
p2
)
->
PDiff
(
derecurs
env
p1
,
derecurs
env
p2
)
...
...
@@ -595,7 +627,7 @@ let rec derecurs env p = match p.descr with
|
(
p
,
None
)
->
derecurs
env
p
,
None
in
PRecord
(
o
,
parse_record
env
.
penv_tenv
p
.
loc
aux
r
)
|
Constant
(
x
,
c
)
->
PConstant
(
x
,
const
env
.
penv_tenv
p
.
loc
c
)
|
Cst
c
->
PT
ype
(
Types
.
constant
(
const
env
.
penv_tenv
p
.
loc
c
))
|
Cst
c
->
pt
ype
(
Types
.
constant
(
const
env
.
penv_tenv
p
.
loc
c
))
|
Regexp
r
->
let
r
,_
=
derecurs_regexp
IdSet
.
empty
false
IdSet
.
empty
true
env
r
in
PRegexp
r
...
...
@@ -650,12 +682,12 @@ and derecurs_var env loc v =
let
v
=
ident
v
in
(
try
PAlias
(
Env
.
find
v
env
.
penv_derec
)
with
Not_found
->
try
PT
ype
(
find_type
v
env
.
penv_tenv
)
try
pt
ype
(
find_type
v
env
.
penv_tenv
)
with
Not_found
->
PCapture
v
)
|
cu
,
v
->
try
let
cu
=
U
.
mk
cu
in
PT
ype
(
find_type_global
loc
cu
(
ident
v
)
env
.
penv_tenv
)
pt
ype
(
find_type_global
loc
cu
(
ident
v
)
env
.
penv_tenv
)
with
Not_found
->
raise_loc_generic
loc
(
"Unbound external type "
^
cu
^
":"
^
(
U
.
to_string
v
))
...
...
@@ -707,18 +739,24 @@ let check_no_capture loc s =
raise_loc_generic
loc
(
"Capture variable not allowed: "
^
(
Ident
.
to_string
x
))
|
None
->
()
let
compile_slot_hash
=
DerecursTable
.
create
67
let
compile_hash
=
DerecursTable
.
create
67
let
compile_slot_hash
=
DerecursTable
.
create
150
67
let
compile_hash
=
DerecursTable
.
create
150
67
let
todo_defs
=
ref
[]
let
todo_fv
=
ref
[]
let
rec
compile
p
=
try
DerecursTable
.
find
compile_hash
p
real_compile
p
(*
print_char '*'; flush stdout;
try Stats.InOut.wrap "lookup" (DerecursTable.find compile_hash) p;
with Not_found ->
Stats.InOut.enter "compile";
let c = real_compile p in
DerecursTable.replace compile_hash p c;
Stats.InOut.leave "compile";
c
*)
and
real_compile
=
function
|
PDummy
->
assert
false
|
PAlias
v
->
...
...
@@ -728,7 +766,7 @@ and real_compile = function
let
r
=
compile
v
.
pdescr
in
v
.
ploop
<-
false
;
r
|
PType
t
->
IType
t
|
PType
(
t
,
h
)
->
IType
(
t
,
h
)
|
POr
(
t1
,
t2
)
->
IOr
(
compile
t1
,
compile
t2
)
|
PAnd
(
t1
,
t2
)
->
IAnd
(
compile
t1
,
compile
t2
)
|
PDiff
(
t1
,
t2
)
->
IDiff
(
compile
t1
,
compile
t2
)
...
...
@@ -739,7 +777,7 @@ and real_compile = function
|
PRecord
(
o
,
r
)
->
IRecord
(
o
,
LabelMap
.
map
compile_field
r
)
|
PConstant
(
x
,
v
)
->
IConstant
(
x
,
v
)
|
PCapture
x
->
ICapture
x
|
PRegexp
r
->
compile
(
remove_regexp
r
(
PT
ype
Sequence
.
nil_type
))
|
PRegexp
r
->
compile
(
remove_regexp
r
(
pt
ype
Sequence
.
nil_type
))
and
compile_field
=
function
|
(
p
,
Some
e
)
->
(
compile_slot
p
,
Some
(
compile
e
))
...
...
@@ -763,7 +801,9 @@ let rec flush_defs () =
List
.
iter
compute_fv
!
todo_fv
;
todo_fv
:=
[]
;
Stats
.
Timer
.
stop
timer_fv
()
|
(
s
,
p
)
::
t
->
|
(
s
,
p
)
::
t
->
(* Format.fprintf Format.std_formatter "flush slot:%a@."
print_derecurs p; *)
todo_defs
:=
t
;
s
.
d
<-
compile
p
;
flush_defs
()
...
...
@@ -772,7 +812,7 @@ let typ_nodes = SlotTable.create 67
let
pat_nodes
=
SlotTable
.
create
67
let
rec
typ
=
function
|
IType
t
->
t
|
IType
(
t
,_
)
->
t
|
IOr
(
s1
,
s2
)
->
Types
.
cup
(
typ
s1
)
(
typ
s2
)
|
IAnd
(
s1
,
s2
)
->
Types
.
cap
(
typ
s1
)
(
typ
s2
)
|
IDiff
(
s1
,
s2
)
->
Types
.
diff
(
typ
s1
)
(
typ
s2
)
...
...
@@ -903,6 +943,10 @@ let dump_ns ppf env =
let
do_typ
loc
r
=
(*
DerecursTable.clear compile_slot_hash;
DerecursTable.clear compile_hash;
*)
let
s
=
compile_slot
r
in
flush_defs
()
;
check_no_capture
loc
(
fv_slot
s
);
...
...
@@ -916,7 +960,8 @@ let pat env p =
flush_defs
()
;
try
pat_node
s
with
Patterns
.
Error
e
->
raise_loc_generic
p
.
loc
e
|
Location
(
loc
,_,
exn
)
when
loc
=
noloc
->
raise
(
Location
(
p
.
loc
,
`Full
,
exn
))
|
Location
(
loc
,_,
exn
)
when
loc
==
noloc
->
raise
(
Location
(
p
.
loc
,
`Full
,
exn
))
(* II. Build skeleton *)
...
...
@@ -1033,7 +1078,8 @@ and extern loc env s args =
and
var
env
loc
s
=
match
is_op
env
s
with
|
Some
(
s
,
arity
)
->
let
need_ns
=
s
=
"print_xml"
||
s
=
"print_xml_utf8"
in
let
need_ns
=
match
s
with
"print_xml"
|
"print_xml_utf8"
->
true
|
_
->
false
in
let
e
=
Typed
.
Op
(
s
,
arity
,
[]
)
in
let
e
=
if
need_ns
then
Typed
.
NsTable
(
env
.
ns
,
e
)
else
e
in
exp
loc
Fv
.
empty
e
...
...
@@ -1111,7 +1157,7 @@ and branches env b =
let
br
=
{
Typed
.
br_loc
=
br_loc
;
Typed
.
br_used
=
br_loc
=
noloc
;
Typed
.
br_used
=
br_loc
=
=
noloc
;
Typed
.
br_vars_empty
=
Patterns
.
fv
p'
;
Typed
.
br_pat
=
p'
;
Typed
.
br_body
=
e
}
in
...
...
@@ -1468,7 +1514,7 @@ let rec unused_branches b =
List
.
map
(
fun
x
->
let
x
=
Ident
.
to_string
x
in
if
x
=
"$$$"
then
raise
Exit
else
x
)
if
(
String
.
compare
x
"$$$"
=
0
)
then
raise
Exit
else
x
)
(
IdSet
.
get
br
.
br_vars_empty
)
in
let
l
=
String
.
concat
","
l
in
"The following variables always match the empty sequence: "
^
...
...
@@ -1538,19 +1584,23 @@ module Schema_converter =
open
Schema_types
open
Encodings
let
seq
r1
r2
=
match
r1
,
r2
with
|
PEpsilon
,
r
|
r
,
PEpsilon
->
r
|
r1
,
r2
->
PSeq
(
r1
,
r2
)
let
xsd
=
Schema_xml
.
xsd
let
is_xsd
(
ns
,
l
)
local
=
(
Ns
.
equal
ns
xsd
)
&&
(
Utf8
.
get_str
l
=
local
)
(
Ns
.
equal
ns
xsd
)
&&
(
String
.
compare
(
Utf8
.
get_str
l
)
local
=
0
)
(* auxiliary functions *)
let
nil_type
=
PT
ype
Sequence
.
nil_type
let
nil_type
=
pt
ype
Sequence
.
nil_type
let
mk_len_regexp
?
min
?
max
base
=
let
rec
repeat_regexp
re
=
function
|
z
when
Intervals
.
V
.
is_zero
z
->
PEpsilon
|
n
when
Intervals
.
V
.
gt
n
Intervals
.
V
.
zero
->
PS
eq
(
re
,
repeat_regexp
re
(
Intervals
.
V
.
pred
n
))
s
eq
re
(
repeat_regexp
re
(
Intervals
.
V
.
pred
n
))
|
_
->
assert
false
in
let
min
=
match
min
with
Some
min
->
min
|
_
->
Intervals
.
V
.
one
in
...
...
@@ -1561,10 +1611,10 @@ module Schema_converter =
let
rec
aux
acc
=
function
|
z
when
Intervals
.
V
.
is_zero
z
->
acc
|
n
->
aux
(
PAlt
(
PEpsilon
,
(
PS
eq
(
base
,
acc
)))
)
(
Intervals
.
V
.
pred
n
)
aux
(
PAlt
(
PEpsilon
,
(
s
eq
base
acc
)))
(
Intervals
.
V
.
pred
n
)
in
PS
eq
(
min_regexp
,
aux
PEpsilon
(
Intervals
.
V
.
sub
max
min
))
|
None
->
PS
eq
(
min_regexp
,
PStar
base
)
s
eq
min_regexp
(
aux
PEpsilon
(
Intervals
.
V
.
sub
max
min
))
|
None
->
s
eq
min_regexp
(
PStar
base
)
(* given a base derecurs create a derecurs value representing a sequence
* type according to length constraints members of facets *)
...
...
@@ -1580,22 +1630,22 @@ module Schema_converter =
(* This is not correct ! *)
let
mix_regexp
=
let
pcdata
=
PStar
(
PElem
(
PT
ype
Builtin_defs
.
string
))
in
let
pcdata
=
PStar
(
PElem
(
pt
ype
Builtin_defs
.
string
))
in
let
rec
aux
=
function
|
PEpsilon
->
PEpsilon
|
PElem
re
->
PElem
re
|
PGuard
re
->
PGuard
re
|
PSeq
(
re1
,
re2
)
->
PS
eq
(
aux
re1
,
PS
eq
(
pcdata
,
aux
re2
))
|
PSeq
(
re1
,
re2
)
->
s
eq
(
aux
re1
)
(
s
eq
pcdata
(
aux
re2
))
|
PAlt
(
re1
,
re2
)
->
PAlt
(
aux
re1
,
aux
re2
)
|
PStar
re
->
PStar
(
aux
re
)
|
PWeakStar
re
->
PWeakStar
(
aux
re
)
in
let
rec
simplify
=
function
|
PSeq
(
x1
,
PSeq
(
x2
,
y
))
when
x1
=
pcdata
&&
x2
=
pcdata
->
simplify
(
PS
eq
(
x2
,
y
)
)
|
PSeq
(
x1
,
PSeq
(
x2
,
y
))
when
x1
=
=
pcdata
&&
x2
=
=
pcdata
->
simplify
(
s
eq
x2
y
)
|
re
->
re
in
fun
regexp
->
(*
simplify
*)
(
PS
eq
(
pcdata
,
aux
regexp
))
fun
regexp
->
simplify
(
s
eq
pcdata
(
aux
regexp
))
(* conversion functions *)
...
...
@@ -1603,29 +1653,29 @@ module Schema_converter =
let
rec
cd_type_of_simple_type
~
schema
=
function
|
Primitive
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
when
Schema_builtin
.
is_builtin
name
->
PT
ype
(
Schema_builtin
.
cd_type_of_builtin
name
)
pt
ype
(
Schema_builtin
.
cd_type_of_builtin
name
)
|
Primitive
_
->
assert
false
(* all primitives are built-in *)
|
Derived
(
_
,
_
,
{
enumeration
=
Some
values
}
,
_
)
->
(* enumeration *)
PT
ype
(
Types
.
choice_of_list
pt
ype
(
Types
.
choice_of_list
(
List
.
map
(
fun
c
->
Types
.
constant
(
Value
.
inv_const
(
Lazy
.
force
c
)))
values
))
|
Derived
(
_
,
_
,
({
maxInclusive
=
Some
_
}
as
facets
)
,
_
)(
*
boundaries
*
)
|
Derived
(
_
,
_
,
({
maxExclusive
=
Some
_
}
as
facets
)
,
_
)
|
Derived
(
_
,
_
,
({
minInclusive
=
Some
_
}
as
facets
)
,
_
)
|
Derived
(
_
,
_
,
({
minExclusive
=
Some
_
}
as
facets
)
,
_
)
->
PT
ype
(
Types
.
interval
(
Schema_common
.
get_interval
facets
))
pt
ype
(
Types
.
interval
(
Schema_common
.
get_interval
facets
))
|
Derived
(
_
,
Atomic
c
,
facets
,
_
)
->
(
match
Lazy
.
force
c
with
|
Simple
(
Primitive
name
)
->
if
is_xsd
name
"string"
||
is_xsd
name
"anyURI"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PT
ype
Builtin_defs
.
char
))
facets
mk_seq_derecurs
~
base
:
(
PElem
(
pt
ype
Builtin_defs
.
char
))
facets
else
if
is_xsd
name
"hexBinary"
||
is_xsd
name
"base64Binary"
then
(* length *)
mk_seq_derecurs
~
base
:
(
PElem
(
PT
ype
Builtin_defs
.
char_latin1
))
mk_seq_derecurs
~
base
:
(
PElem
(
pt
ype
Builtin_defs
.
char_latin1
))
facets
else
(* no other interesting facet *)
PT
ype
(
Schema_builtin
.
cd_type_of_builtin
name
)
pt
ype
(
Schema_builtin
.
cd_type_of_builtin
name
)
|
_
->
assert
false
)
|
Derived
(
_
,
List
item
,
facets
,
_
)
->
mk_seq_derecurs
...
...
@@ -1664,22 +1714,9 @@ module Schema_converter =
|
All
(
hd
::
tl
)
|
Sequence
(
hd
::
tl
)
->
List
.
fold_left
(
fun
acc
particle
->
PS
eq
(
acc
,
regexp_of_particle
~
schema
particle
))
s
eq
acc
(
regexp_of_particle
~
schema
particle
))
(
regexp_of_particle
~
schema
hd
)
tl
(*
and regexp_of_content_type ~schema = function
| CT_empty -> PEpsilon
| CT_simple st -> PElem (cd_type_of_simple_type ~schema st)
| CT_model (particle, mixed) ->
let regexp = regexp_of_particle ~schema particle in
if mixed then begin (* TODO mixed *)
Value.failwith' "Mixed content models aren't supported";
mix_regexp regexp
end else
regexp
*)
and
regexp_of_particle
~
schema
(
min
,
max
,
term
,
_
)
=
mk_len_regexp
?
min
:
(
Some
min
)
?
max
(
regexp_of_term
~
schema
term
)
...
...
@@ -1691,19 +1728,18 @@ module Schema_converter =
with
Not_found
->
let
slot
=
mk_derecurs_slot
noloc
in
Hashtbl
.
add
complex_memo
ct
.
ct_uid
slot
;
(* let content_re = regexp_of_content_type ~schema ct.ct_content in*)
let
content_ast_node
=
match
ct
.
ct_content
with
|
CT_empty
->
PT
ype
Sequence
.
nil_type
|
CT_empty
->
pt
ype
Sequence
.
nil_type
|
CT_simple
st
->
cd_type_of_simple_type_ref
~
schema
st
|
CT_model
(
particle
,
mixed
)
->
(*
if mixed then
Value.failwith' "Mixed content models aren't supported"
; *)
(*
Format.fprintf Format.std_formatter "CT_model particle=%a@."
Schema_common.print_particle particle
; *)
let
regexp
=
regexp_of_particle
~
schema
particle
in
let
regexp
=
if
mixed
then
mix_regexp
regexp
else
regexp
in
PRegexp
regexp
in
slot
.
pdescr
<-
slot
.
pdescr
<-
PTimes
(
cd_type_of_attr_uses
~
schema
ct
.
ct_attrs
,
content_ast_node
);
PAlias
slot
...
...
@@ -1716,7 +1752,7 @@ module Schema_converter =
match
at
.
attr_use_cstr
with
|
Some
(
`Fixed
v
)
->
let
v
=
Lazy
.
force
v
in
PT
ype
(
Types
.
constant
(
Value
.
inv_const
v
))
pt
ype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
cd_type_of_simple_type_ref
~
schema
at
.
attr_decl
.
attr_typdef
in
let
r
=
if
at
.
attr_required
then
r
else
POptional
r
in
...
...
@@ -1732,27 +1768,27 @@ module Schema_converter =
and
cd_type_of_elt_decl
~
schema
elt
=
let
atom_type
=
PT
ype
(
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
of_qname
elt
.
elt_name
)))
pt
ype
(
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
of_qname
elt
.
elt_name
)))
in
let
content
=
match
elt
.
elt_cstr
with
|
Some
(
`Fixed
v
)
->
let
v
=
Lazy
.
force
v
in
PT
ype
(
Types
.
constant
(
Value
.
inv_const
v
))
pt
ype
(
Types
.
constant
(
Value
.
inv_const
v
))
|
_
->
(
match
Lazy
.
force
elt
.
elt_typdef
with
|
AnyType
->
PT
ype
(
Schema_builtin
.
cd_type_of_builtin
(
xsd
,
U
.
mk
"anyType"
))
pt
ype
(
Schema_builtin
.
cd_type_of_builtin
(
xsd
,
U
.
mk
"anyType"
))
|
Simple
st
->
PTimes
(
PT
ype
Types
.
empty_closed_record
,
(
pt
ype
Types
.
empty_closed_record
,
cd_type_of_simple_type
~
schema
st
)
|
Complex
ct
->
cd_type_of_complex_type'
~
schema
ct
)
in
PXml
(
atom_type
,
content
)
let
cd_type_of_complex_type
~
schema
ct
=
PXml
(
PT
ype
Types
.
any
,
cd_type_of_complex_type'
~
schema
ct
)
PXml
(
pt
ype
Types
.
any
,
cd_type_of_complex_type'
~
schema
ct
)
let
cd_type_of_model_group
~
schema
g
=
PRegexp
(
regexp_of_model_group
~
schema
g
)
...
...
@@ -1787,8 +1823,8 @@ let get_schema uri =
Format
.
fprintf
Format
.
std_formatter
"Registering schema %s: %s # %s"
kind
uri
(
Ns
.
QName
.
to_string
name
);
if
debug_schema
then
Types
.
Print
.
print
Format
.
std_formatter
cd_type
;
(*
if debug_schema then
Types.Print.print Format.std_formatter cd_type;
*)
Format
.
fprintf
Format
.
std_formatter
"@."
end
in
...
...
@@ -1796,8 +1832,10 @@ let get_schema uri =
List
.
iter
(* Schema types -> CDuce types *)
(
fun
type_def
->
let
name
=
Schema_common
.
name_of_type_definition
type_def
in
log_schema_component
"type"
uri
name
()
;
let
cd_type
=
Schema_converter
.
cd_type_of_type_def
~
schema
type_def
in
log_schema_component
"type"
uri
name
cd_type
;
Format
.
fprintf
Format
.
std_formatter
"Done@."
;
Hashtbl
.
add
!
schema_types
(
uri
,
name
)
cd_type
)
schema
.
Schema_types
.
types
;
List
.
iter
(* Schema attributes -> CDuce types *)
...
...
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