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
c272c7ec
Commit
c272c7ec
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-02-18 17:36:34 by afrisch] Schema and namespaces
Original author: afrisch Date: 2005-02-18 17:36:35+00:00
parent
6a14fe70
Changes
19
Hide whitespace changes
Inline
Side-by-side
compile/lambda.ml
View file @
c272c7ec
...
...
@@ -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
*
U
.
t
|
Validate
of
expr
*
schema_component_kind
*
string
*
Ns
.
qname
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Ref
of
expr
*
Types
.
Node
.
t
...
...
@@ -191,7 +191,7 @@ module Put = struct
expr
s
e
;
serialize_schema_component_kind
s
k
;
string
s
sch
;
U
.
serialize
s
t
Ns
.
QName
.
serialize
s
t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
|
RemoveField
(
e
,
l
)
->
bits
nbits
s
14
;
...
...
@@ -315,7 +315,7 @@ module Get = struct
let
e
=
expr
s
in
let
k
=
deserialize_schema_component_kind
s
in
let
sch
=
string
s
in
let
t
=
U
.
deserialize
s
in
let
t
=
Ns
.
QName
.
deserialize
s
in
Validate
(
e
,
k
,
sch
,
t
)
|
14
->
let
e
=
expr
s
in
...
...
compile/lambda.mli
View file @
c272c7ec
...
...
@@ -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
*
U
.
t
|
Validate
of
expr
*
schema_component_kind
*
string
*
Ns
.
qname
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Ref
of
expr
*
Types
.
Node
.
t
...
...
driver/cduce.ml
View file @
c272c7ec
...
...
@@ -258,8 +258,9 @@ let directive ppf tenv cenv = function
Typer
.
dump_type
ppf
tenv
name
;
flush_ppf
ppf
|
`Print_schema_type
schema_ref
->
Typer
.
dump_schema_type
ppf
tenv
schema_ref
;
flush_ppf
ppf
assert
false
(* Typer.dump_schema_type ppf tenv schema_ref;
flush_ppf ppf *)
|
`Reinit_ns
->
Typer
.
set_ns_table_for_printer
tenv
|
`Help
->
...
...
misc/ns.ml
View file @
c272c7ec
...
...
@@ -21,6 +21,10 @@ module P = Pool.Make(U)
include
P
let
empty
=
mk
empty_str
let
xml_ns
=
mk
(
U
.
mk
"http://www.w3.org/XML/1998/namespace"
)
let
xsd_ns
=
mk
(
U
.
mk
"http://www.w3.org/2001/XMLSchema"
)
let
xsi_ns
=
mk
(
U
.
mk
"http://www.w3.org/2001/XMLSchema-instance"
)
let
mk_ascii
s
=
mk
(
U
.
mk
s
)
module
Table
=
Map
.
Make
(
U
)
...
...
@@ -52,7 +56,11 @@ let deserialize_table s =
let
global_hints
=
State
.
ref
"Ns.prefixes"
(
Hashtbl
.
create
63
)
let
empty_table
=
Table
.
add
empty_str
empty
(
Table
.
add
(
U
.
mk
"xml"
)
xml_ns
Table
.
empty
)
List
.
fold_left
(
fun
table
(
pr
,
ns
)
->
Table
.
add
(
U
.
mk
pr
)
ns
table
)
Table
.
empty
[
""
,
empty
;
"xml"
,
xml_ns
;
"xsd"
,
xsd_ns
;
"xsi"
,
xsi_ns
]
let
add_prefix
pr
ns
table
=
if
(
U
.
get_str
pr
<>
""
)
then
Hashtbl
.
add
!
global_hints
ns
pr
;
Table
.
add
pr
ns
table
...
...
schema/schema_builtin.ml
View file @
c272c7ec
...
...
@@ -12,7 +12,8 @@ open Schema_types
(** {2 Aux/Misc stuff} *)
let
add_xsd_prefix
s
=
Utf8
.
mk
(
"xsd:"
^
s
)
let
xsd
=
Schema_xml
.
xsd
let
add_xsd_prefix
s
=
(
xsd
,
Utf8
.
mk
s
)
let
unsupported
=
List
.
map
(
fun
s
->
add_xsd_prefix
s
)
...
...
@@ -50,8 +51,8 @@ let char_of_hex =
let
strip_parens
s
=
Pcre
.
replace
~
pat
:
"[()]"
s
let
add_limits
s
=
"^"
^
s
^
"$"
exception
Schema_builtin_error
of
Utf8
.
t
let
simple_type_error
name
=
raise
(
Schema_builtin_error
(
add_xsd_prefix
name
)
)
exception
Schema_builtin_error
of
string
let
simple_type_error
name
=
raise
(
Schema_builtin_error
name
)
let
qualify
s
=
(
Ns
.
empty
,
Encodings
.
Utf8
.
mk
s
)
...
...
@@ -402,12 +403,14 @@ let validate_anyURI s =
(** {2 API backend} *)
let
builtins
=
Hashtbl
.
create
50
let
reg
name
spec
=
Hashtbl
.
add
builtins
(
add_xsd_prefix
name
)
spec
module
QTable
=
Hashtbl
.
Make
(
Ns
.
QName
)
let
builtins
=
QTable
.
create
50
let
reg
name
spec
=
QTable
.
add
builtins
(
add_xsd_prefix
name
)
spec
let
alias
alias
name
=
let
(
alias
,
name
)
=
(
add_xsd_prefix
alias
,
add_xsd_prefix
name
)
in
Hasht
bl
.
add
builtins
alias
(
let
(
st_def
,
descr
,
validator
)
=
Hasht
bl
.
find
builtins
name
in
QTa
bl
e
.
add
builtins
alias
(
let
(
st_def
,
descr
,
validator
)
=
QTa
bl
e
.
find
builtins
name
in
let
new_def
=
match
st_def
with
|
Primitive
_
->
Primitive
alias
...
...
@@ -417,7 +420,7 @@ let alias alias name =
(
new_def
,
descr
,
validator
))
let
restrict'
name
basename
new_facets
=
let
(
name
,
basename
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
basename
)
in
let
(
base
,
_
,
_
)
=
Hasht
bl
.
find
builtins
basename
in
let
(
base
,
_
,
_
)
=
QTa
bl
e
.
find
builtins
basename
in
let
variety
=
variety_of_simple_type_definition
base
in
let
facets
=
merge_facets
(
facets_of_simple_type_definition
base
)
new_facets
...
...
@@ -425,7 +428,7 @@ let restrict' name basename new_facets =
Derived
(
Some
name
,
variety
,
facets
,
ref
(
Simple
base
))
let
list'
name
itemname
=
let
(
name
,
itemname
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
itemname
)
in
let
(
base
,
_
,
_
)
=
Hasht
bl
.
find
builtins
itemname
in
let
(
base
,
_
,
_
)
=
QTa
bl
e
.
find
builtins
itemname
in
let
base
=
ref
(
Simple
base
)
in
Derived
(
Some
name
,
List
base
,
no_facets
,
base
)
...
...
@@ -563,7 +566,7 @@ let null_value = {
}
let
string_of_time_type
fields
=
let
fail
()
=
raise
(
Schema_builtin_error
(
Utf8
.
mk
""
)
)
in
let
fail
()
=
raise
(
Schema_builtin_error
""
)
in
let
parse_int
=
function
Value
.
Integer
i
->
i
|
_
->
fail
()
in
let
parse_timezone
v
=
let
fields
=
...
...
@@ -694,11 +697,11 @@ let string_of_time_type fields =
(** {2 API} *)
let
is_builtin
=
Hasht
bl
.
mem
builtins
let
is_builtin
=
QTa
bl
e
.
mem
builtins
let
iter_builtin
f
=
Hasht
bl
.
iter
(
fun
_
(
type_def
,
_
,
_
)
->
f
type_def
)
builtins
QTa
bl
e
.
iter
(
fun
_
(
type_def
,
_
,
_
)
->
f
type_def
)
builtins
let
lookup
name
=
Hasht
bl
.
find
builtins
name
let
lookup
name
=
QTa
bl
e
.
find
builtins
name
let
fst
(
x
,_,_
)
=
x
let
snd
(
_
,
y
,_
)
=
y
...
...
schema/schema_builtin.mli
View file @
c272c7ec
...
...
@@ -3,13 +3,13 @@ open Encodings
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception
Schema_builtin_error
of
Utf8
.
t
exception
Schema_builtin_error
of
string
val
is_builtin
:
Utf8
.
t
->
bool
val
get_builtin
:
Utf8
.
t
->
Schema_types
.
simple_type_definition
val
is_builtin
:
Ns
.
QName
.
t
->
bool
val
get_builtin
:
Ns
.
QName
.
t
->
Schema_types
.
simple_type_definition
val
iter_builtin
:
(
Schema_types
.
simple_type_definition
->
unit
)
->
unit
val
cd_type_of_builtin
:
Utf8
.
t
->
Types
.
descr
val
cd_type_of_builtin
:
Ns
.
QName
.
t
->
Types
.
descr
(** validate_builtin <builtin> <string>
* validates <string> against builtin type <builtin> and return the resulting
...
...
@@ -17,7 +17,7 @@ val cd_type_of_builtin: Utf8.t -> Types.descr
* @raise Schema_builtin_error [name] in case of validation error, where
* [name] is the name of a schema built in type prefixed with
* Schema_xml.xsd_prefix *)
val
validate_builtin
:
Utf8
.
t
->
Utf8
.
t
->
Value
.
t
val
validate_builtin
:
Ns
.
QName
.
t
->
Utf8
.
t
->
Value
.
t
val
string_of_time_type
:
(
Ns
.
qname
*
Value
.
t
)
list
->
Utf8
.
t
schema/schema_common.ml
View file @
c272c7ec
...
...
@@ -4,6 +4,8 @@ open Encodings
open
Schema_pcre
open
Schema_types
let
xsd
=
Schema_xml
.
xsd
let
no_facets
=
{
length
=
None
;
minLength
=
None
;
...
...
@@ -71,7 +73,7 @@ let rec variety_of_simple_type_definition = function
let
get_simple_type
=
function
|
{
contents
=
Simple
c
}
->
c
|
{
contents
=
AnyType
}
->
Primitive
(
Utf8
.
mk
"
xsd:
anySimpleType"
)
|
{
contents
=
AnyType
}
->
Primitive
(
xsd
,
Utf8
.
mk
"anySimpleType"
)
|
_
->
assert
false
let
rec
normalize_simple_type
=
function
...
...
@@ -93,7 +95,7 @@ let name_of_complex_type_definition = function
|
{
ct_name
=
Some
name
}
->
name
|
_
->
raise
(
Invalid_argument
"anonymous complex type definition"
)
let
name_of_type_definition
=
function
|
AnyType
->
Encodings
.
Utf8
.
mk
"
xsd:
anyType"
|
AnyType
->
(
xsd
,
Utf8
.
mk
"anyType"
)
|
Simple
st
->
name_of_simple_type_definition
st
|
Complex
ct
->
name_of_complex_type_definition
ct
let
name_of_attribute_declaration
a
=
a
.
attr_name
...
...
@@ -141,7 +143,7 @@ let rec normalize_white_space =
in
pcre_replace
~
rex
:
margins_RE
~
templ
:
(
Utf8
.
mk
"$1"
)
s'
let
anySimpleType
=
Primitive
(
Encodings
.
Utf8
.
mk
"
xsd:
anySimpleType"
)
let
anySimpleType
=
Primitive
(
xsd
,
Utf8
.
mk
"anySimpleType"
)
let
anyType
=
AnyType
let
first_of_particle
(
_
,
_
,
_
,
first
)
=
first
...
...
@@ -158,7 +160,7 @@ let first_of_model_group = function
aux
particles
let
rec
is_in_first
tag
=
function
|
[]
->
false
|
Some
tag'
::
rest
when
Utf8
.
equal
tag'
tag
->
true
|
Some
tag'
::
rest
when
Ns
.
QName
.
equal
tag'
tag
->
true
|
_
::
rest
->
is_in_first
tag
rest
let
get_interval
facets
=
...
...
@@ -191,13 +193,13 @@ let get_interval facets =
let
print_simple_type
fmt
=
function
|
Primitive
name
->
Format
.
fprintf
fmt
"%a"
Encodings
.
Utf8
.
dump
name
|
Primitive
name
->
Format
.
fprintf
fmt
"%a"
Ns
.
QName
.
print
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%a'"
Encodings
.
Utf8
.
dump
name
|
Derived
(
None
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"unnamed
'
"
Format
.
fprintf
fmt
"%a'"
Ns
.
QName
.
print
name
|
Derived
(
None
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"unnamed"
let
print_complex_type
fmt
=
function
|
{
ct_uid
=
id
;
ct_name
=
Some
name
}
->
Format
.
fprintf
fmt
"%d:%a"
id
Encodings
.
Utf8
.
dump
name
Format
.
fprintf
fmt
"%d:%a"
id
Ns
.
QName
.
print
name
|
{
ct_uid
=
id
}
->
Format
.
fprintf
fmt
"%d:unnamed'"
id
let
print_type
fmt
=
function
...
...
@@ -205,20 +207,20 @@ let print_type fmt = function
|
Simple
t
->
Format
.
fprintf
fmt
"S:%a"
print_simple_type
t
|
Complex
t
->
Format
.
fprintf
fmt
"C:%a"
print_complex_type
t
let
print_attribute
fmt
{
attr_name
=
name
;
attr_typdef
=
t
}
=
Format
.
fprintf
fmt
"@@%a:%a"
Utf8
.
dump
name
print_simple_type
Format
.
fprintf
fmt
"@@%a:%a"
Ns
.
QName
.
print
name
print_simple_type
(
get_simple_type
t
)
let
print_element
fmt
{
elt_uid
=
id
;
elt_name
=
name
}
=
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Utf8
.
dump
name
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Ns
.
QName
.
print
name
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
let
print_attribute_group
fmt
ag
=
Format
.
fprintf
fmt
"{agroup:%a}"
Utf8
.
dump
ag
.
ag_name
Format
.
fprintf
fmt
"{agroup:%a}"
Ns
.
QName
.
print
ag
.
ag_name
let
print_model_group
fmt
mg
=
Format
.
fprintf
fmt
"{mgroup:%a}"
Utf8
.
dump
mg
.
mg_name
Format
.
fprintf
fmt
"{mgroup:%a}"
Ns
.
QName
.
print
mg
.
mg_name
let
print_schema
fmt
schema
=
let
defined_types
=
(* filter out built-in types *)
List
.
filter
(
fun
def
->
not
(
Schema_xml
.
has_xsd_prefix
(
name_of_type_definition
def
)))
schema
.
types
List
.
filter
(
fun
t
->
let
(
ns
,_
)
=
name_of_type_definition
t
in
not
(
Ns
.
equal
ns
xsd
))
schema
.
types
in
if
defined_types
<>
[]
then
begin
Format
.
fprintf
fmt
"Types: "
;
...
...
@@ -252,41 +254,29 @@ let print_schema fmt schema =
end
let
get_
type
name
schema
=
let
get_
qual
name
table
get_name
=
List
.
find
(
fun
x
->
try
name_of_type_definition
x
=
name
try
Ns
.
QName
.
equal
(
get_name
x
)
name
with
Invalid_argument
_
->
false
)
schema
.
types
let
get_
attribute
name
schema
=
table
let
get_
unqual
name
table
get_name
=
List
.
find
(
fun
x
->
try
name_of_attribute_declaration
x
=
name
try
Utf8
.
equal
(
snd
(
get_name
x
))
name
with
Invalid_argument
_
->
false
)
schema
.
attributes
table
let
get_type
name
schema
=
get_qual
name
schema
.
types
name_of_type_definition
let
get_attribute
name
schema
=
get_qual
name
schema
.
attributes
name_of_attribute_declaration
let
get_element
name
schema
=
List
.
find
(
fun
x
->
try
name_of_element_declaration
x
=
name
with
Invalid_argument
_
->
false
)
schema
.
elements
get_qual
name
schema
.
elements
name_of_element_declaration
let
get_attribute_group
name
schema
=
List
.
find
(
fun
x
->
try
name_of_attribute_group_definition
x
=
name
with
Invalid_argument
_
->
false
)
schema
.
attribute_groups
get_qual
name
schema
.
attribute_groups
name_of_attribute_group_definition
let
get_model_group
name
schema
=
List
.
find
(
fun
x
->
try
name_of_model_group_definition
x
=
name
with
Invalid_argument
_
->
false
)
schema
.
model_groups
get_qual
name
schema
.
model_groups
name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
...
...
@@ -308,6 +298,37 @@ let get_component kind name schema =
|
Some
`Model_group
->
mod_group
()
|
None
->
tries
[
elt
;
typ
;
att
;
att_group
;
mod_group
]
let
get_type
name
schema
=
get_unqual
name
schema
.
types
name_of_type_definition
let
get_attribute
name
schema
=
get_unqual
name
schema
.
attributes
name_of_attribute_declaration
let
get_element
name
schema
=
get_unqual
name
schema
.
elements
name_of_element_declaration
let
get_attribute_group
name
schema
=
get_unqual
name
schema
.
attribute_groups
name_of_attribute_group_definition
let
get_model_group
name
schema
=
get_unqual
name
schema
.
model_groups
name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
let
get_unqual_component
kind
name
schema
=
let
rec
tries
=
function
|
[]
->
raise
Not_found
|
hd
::
tl
->
(
try
hd
()
with
Not_found
->
tries
tl
)
in
let
elt
()
=
Element
(
get_element
name
schema
)
in
let
typ
()
=
Type
(
get_type
name
schema
)
in
let
att
()
=
Attribute
(
get_attribute
name
schema
)
in
let
att_group
()
=
Attribute_group
(
get_attribute_group
name
schema
)
in
let
mod_group
()
=
Model_group
(
get_model_group
name
schema
)
in
match
kind
with
|
Some
`Element
->
elt
()
|
Some
`Type
->
typ
()
|
Some
`Attribute
->
att
()
|
Some
`Attribute_group
->
att_group
()
|
Some
`Model_group
->
mod_group
()
|
None
->
tries
[
elt
;
typ
;
att
;
att_group
;
mod_group
]
let
string_of_component_kind
(
kind
:
component_kind
)
=
match
kind
with
|
Some
`Type
->
"type"
...
...
schema/schema_common.mli
View file @
c272c7ec
...
...
@@ -25,15 +25,15 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
val
get_simple_type
:
type_ref
->
simple_type_definition
val
name_of_element_declaration
:
element_declaration
->
Utf8
.
t
val
name_of_type_definition
:
type_definition
->
Utf8
.
t
val
name_of_simple_type_definition
:
simple_type_definition
->
Utf8
.
t
val
name_of_complex_type_definition
:
complex_type_definition
->
Utf8
.
t
val
name_of_attribute_declaration
:
attribute_declaration
->
Utf8
.
t
val
name_of_attribute_use
:
attribute_use
->
Utf8
.
t
val
name_of_attribute_group_definition
:
attribute_group_definition
->
Utf8
.
t
val
name_of_model_group_definition
:
model_group_definition
->
Utf8
.
t
val
name_of_particle
:
particle
->
Utf8
.
t
val
name_of_element_declaration
:
element_declaration
->
Ns
.
qname
val
name_of_type_definition
:
type_definition
->
Ns
.
qname
val
name_of_simple_type_definition
:
simple_type_definition
->
Ns
.
qname
val
name_of_complex_type_definition
:
complex_type_definition
->
Ns
.
qname
val
name_of_attribute_declaration
:
attribute_declaration
->
Ns
.
qname
val
name_of_attribute_use
:
attribute_use
->
Ns
.
qname
val
name_of_attribute_group_definition
:
attribute_group_definition
->
Ns
.
qname
val
name_of_model_group_definition
:
model_group_definition
->
Ns
.
qname
val
name_of_particle
:
particle
->
Ns
.
qname
val
string_of_component_kind
:
component_kind
->
string
...
...
@@ -43,13 +43,16 @@ val simple_type_of_type : type_definition -> simple_type_definition
val
complex_type_of_type
:
type_definition
->
complex_type_definition
val
content_type_of_type
:
type_definition
->
content_type
val
get_type
:
Utf8
.
t
->
schema
->
type_definition
val
get_attribute
:
Utf8
.
t
->
schema
->
attribute_declaration
val
get_element
:
Utf8
.
t
->
schema
->
element_declaration
val
get_attribute_group
:
Utf8
.
t
->
schema
->
attribute_group_definition
val
get_model_group
:
Utf8
.
t
->
schema
->
model_group_definition
(*
val get_type: Ns.qname -> schema -> type_definition
val get_attribute: Ns.qname -> schema -> attribute_declaration
val get_element: Ns.qname -> schema -> element_declaration
val get_attribute_group: Ns.qname -> schema -> attribute_group_definition
val get_model_group: Ns.qname -> schema -> model_group_definition
*)
val
get_component
:
component_kind
->
Utf8
.
t
->
schema
->
component
val
get_component
:
component_kind
->
Ns
.
qname
->
schema
->
component
val
get_unqual_component
:
component_kind
->
Utf8
.
t
->
schema
->
component
val
iter_types
:
schema
->
(
type_definition
->
unit
)
->
unit
val
iter_attributes
:
schema
->
(
attribute_declaration
->
unit
)
->
unit
...
...
@@ -60,7 +63,7 @@ val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
val
first_of_particle
:
particle
->
first
val
first_of_model_group
:
model_group
->
first
val
is_in_first
:
Utf8
.
t
->
first
->
bool
val
is_in_first
:
Ns
.
qname
->
first
->
bool
val
nullable
:
particle
->
bool
(** {2 Facets} *)
...
...
schema/schema_parser.ml
View file @
c272c7ec
...
...
@@ -7,19 +7,23 @@ open Schema_types
open
Schema_validator
open
Schema_xml
module
QTable
=
Hashtbl
.
Make
(
Ns
.
QName
)
let
validation_error
s
=
raise
(
XSD_validation_error
s
)
let
xsd
=
Schema_xml
.
xsd
let
fake_type_def
=
Complex
{
ct_uid
=
-
1
;
ct_name
=
Some
(
Utf8
.
mk
" FAKE TYP "
);
ct_name
=
Some
(
xsd
,
Utf8
.
mk
" FAKE TYP "
);
ct_typdef
=
AnyType
;
ct_deriv
=
`Restriction
;
ct_attrs
=
[]
;
ct_content
=
CT_empty
}
let
fake_elt_decl
=
{
elt_uid
=
-
2
;
elt_name
=
Utf8
.
mk
" FAKE ELT "
;
elt_name
=
(
xsd
,
Utf8
.
mk
" FAKE ELT "
)
;
elt_typdef
=
ref
fake_type_def
;
elt_cstr
=
None
}
let
is_fake_type_def
=
(
==
)
fake_type_def
...
...
@@ -52,14 +56,14 @@ let split s = pcre_split ~rex:space_RE s
let
unqualify
s
=
snd
(
Ns
.
split_qname
s
)
let
hashtbl_deref
tbl
=
Hasht
bl
.
fold
(
fun
_
v
acc
->
!
v
::
acc
)
tbl
[]
let
hashtbl_values
tbl
=
Hasht
bl
.
fold
(
fun
_
v
acc
->
v
::
acc
)
tbl
[]
let
hashtbl_deref
tbl
=
QTa
bl
e
.
fold
(
fun
_
v
acc
->
!
v
::
acc
)
tbl
[]
let
hashtbl_values
tbl
=
QTa
bl
e
.
fold
(
fun
_
v
acc
->
v
::
acc
)
tbl
[]
let
parse_facets
base
n
=
let
validate_base_type
v
=
lazy
(
Schema_validator
.
validate_simple_type
(
get_simple_type
base
)
v
)
in
let
validate_nonNegativeInteger
=
Schema_builtin
.
validate_builtin
(
Utf8
.
mk
"
xsd:
nonNegativeInteger"
)
Schema_builtin
.
validate_builtin
(
xsd
,
Utf8
.
mk
"nonNegativeInteger"
)
in
let
aux
facets
n
tag
=
let
fixed
=
_is_attr
"fixed"
n
"true"
in
...
...
@@ -144,148 +148,116 @@ let find_particles n =
let
find_particle
n
=
first
n
_may_elem
[
"xsd:all"
;
"xsd:choice"
;
"xsd:group"
;
"xsd:sequence"
]
let
register_builtins
typs
=
Schema_builtin
.
iter_builtin
(
fun
st_def
->
let
type_def
=
Simple
st_def
in
let
name
=
name_of_type_definition
type_def
in
Hasht
bl
.
replace
typs
name
(
ref
type_def
));
Hasht
bl
.
replace
typs
(
Utf8
.
mk
"
xsd:
anyType"
)
(
ref
AnyType
)
QTa
bl
e
.
replace
typs
name
(
ref
type_def
));
QTa
bl
e
.
replace
typs
(
xsd
,
Utf8
.
mk
"anyType"
)
(
ref
AnyType
)
(* Main parsing function *)
let
schema_of_uri
uri
=
let
nsman
=
new
Pxp_dtd
.
namespace_manager
in
List
.
iter
(
fun
(
p
,
ns
)
->
nsman
#
add_namespace
(
Utf8
.
get_str
p
)
(
Utf8
.
get_str
ns
))
Schema_xml
.
schema_ns_prefixes
;
let
root
=
node_of_uri
uri
in
let
orig_ns
=
Hashtbl
.
create
17
in
let
register_ns
rt
=
List
.
iter
(
fun
(
prefix
,
uri
)
->
if
prefix
<>
""
then
begin
Hashtbl
.
add
orig_ns
prefix
uri
;
ignore
(
nsman
#
lookup_or_add_namespace
prefix
uri
)
end
)
(
_namespaces
rt
)
in
register_ns
root
;
let
qualify
,
targetNamespace
=
match
_may_attr
"targetNamespace"
root
with
|
Some
ns
->
let
pr
=
nsman
#
lookup_or_add_namespace
"target"
(
Utf8
.
get_str
ns
)
in
let
pr
=
Utf8
.
mk
(
pr
^
":"
)
in
(
fun
name
->
Utf8
.
concat
pr
name
)
,
Ns
.
mk
ns
|
None
->
(
fun
name
->
name
)
,
Ns
.
empty
in
let
typs
=
Hashtbl
.
create
17
and
attrs
=
Hashtbl
.
create
17
and
elts
=
Hashtbl
.
create
17
and
attr_groups
=
Hashtbl
.
create
17
and
model_groups
=
Hashtbl
.
create
17
in
let
typs
=
QTable
.
create
17
in
let
elts
=
QTable
.
create
17
in
let
attrs
=
QTable
.
create
17
in
let
attr_groups
=
QTable
.
create
17
in
let
model_groups
=
QTable
.
create
17
in
register_builtins
typs
;
let
fix_namespace
s
=
match
Ns
.
split_qname
s
with
|
""
,
base
->
qualify
base
|
prefix
,
base
->
(
try
let
orig_uri
=
Hashtbl
.
find
orig_ns
prefix
in
let
new_prefix
=
nsman
#
get_normprefix
orig_uri
in
Utf8
.
concat
(
Utf8
.
mk
(
new_prefix
^
":"
))
base
with
Not_found
->
validation_error
(
"Can't resolve: "
^
Utf8
.
get_str
s
))
let
attr_elems
=
QTable
.
create
17
and
attr_group_elems
=
QTable
.
create
17
and
model_group_elems
=
QTable
.
create
17
in
let
resolve
k
t1
t2
f
qname
=
try
QTable
.
find
t1
qname
with
Not_found
->
let
node
=
try
QTable
.
find
t2
qname
with
Not_found
->
validation_error
(
"Can't find declaration for "
^
k
^
" "
^
Ns
.
QName
.
to_string
qname
)
in
let
decl
=
f
node
in
QTable
.
replace
t1
qname
decl
;
decl
in
let
todo
=
ref
[]
in
let
roots
=
ref
[
]
in
let
find_global_component
tag_pred
name
err
=
let
basename
=
Utf8
.
get_str
(
snd
(
Ns
.
split_qname
name
))
in
let
sel
n
=
(
_has_tag
n
tag_pred
)
&&
(
_is_attr
"name"
n
basename
)
in
let
rec
aux
=
function
|
[]
->
validation_error
(
"Can't find declaration for "
^
err
^
" "
^
Utf8
.
get_str
name
)
|
hd
::
tl
->
(
try
_find
sel
hd
with
Not_found
->
aux
tl
)
let
rec
parse_uri
uri
=
let
root
=
node_of_uri
uri
in
let
targetNamespace
=
match
_may_attr
"targetNamespace"
root
with
|
Some
ns
->
Ns
.
mk
ns
|
None
->
Ns
.
empty
in
aux
!
roots
in
let
attributeFormDefault
=
_is_attr
"attributeFormDefault"
root
"qualified"
in
let
elementFormDefault
=
_is_attr
"elementFormDefault"
root
"qualified"
in
let
parse_root
root
=
let
may_name
n
=
match
_may_attr
"name"
n
with
|
Some
local
->
Some
(
targetNamespace
,
local
)
|
None
->
None
in
let
get_name
n
=
(
targetNamespace
,
_attr
"name"
n
)
in
let
rec
resolve_typ
name
=
try
Hasht
bl
.
find
typs
(
fix_namespace
name
)
let
rec
resolve_typ
q
name
=
try
QTa
bl
e
.
find
typs
q
name
with
Not_found
->
failwith
(
"Cannot find type "
^
(
Utf8
.
to_string
name
))
failwith
(
"Cannot find type "
^
(
Ns
.
QName
.
to_string
q
name
))
and
resolve_simple_typ
name
=
resolve_typ
name
and
resolve_simple_typ
q
name
=
resolve_typ
q
name
and
resolve_elt
name
=