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
c5e7054e
Commit
c5e7054e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-11-24 16:03:12 by szach] use Utf8 everywhere in schema support
Original author: szach Date: 2003-11-24 16:03:14+00:00
parent
7121a7e3
Changes
17
Expand all
Hide whitespace changes
Inline
Side-by-side
compile/lambda.ml
View file @
c5e7054e
...
...
@@ -26,7 +26,7 @@ type expr =
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
schema_component_kind
*
string
*
string
|
Validate
of
expr
*
schema_component_kind
*
U
.
t
*
U
.
t
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
UnaryOp
of
int
*
expr
...
...
driver/cduce.ml
View file @
c5e7054e
...
...
@@ -69,7 +69,7 @@ let dump_env ppf =
Format
.
fprintf
ppf
"Namespace prefixes used for pretty-printing:@.%t"
Ns
.
InternalPrinter
.
dump
;
Format
.
fprintf
ppf
"Schemas: %s@."
(
String
.
concat
" "
(
Typer
.
get_schema_names
()
));
(
String
.
concat
" "
(
List
.
map
U
.
get_str
(
Typer
.
get_schema_names
()
))
)
;
Format
.
fprintf
ppf
"Values:@."
;
Typer
.
iter_values
!
typing_env
(
fun
x
t
->
dump_value
ppf
x
t
(
get_global_value
x
))
...
...
parser/ast.ml
View file @
c5e7054e
...
...
@@ -8,7 +8,7 @@ type pprog = pmodule_item list
and
pmodule_item
=
pmodule_item'
located
and
pmodule_item'
=
|
TypeDecl
of
id
*
ppat
|
SchemaDecl
of
string
*
Schema_types
.
schema
(* name, schema *)
|
SchemaDecl
of
U
.
t
*
Schema_types
.
schema
(* name, schema *)
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
|
Namespace
of
U
.
t
*
Ns
.
t
...
...
@@ -30,9 +30,9 @@ and toplevel_directive =
|
`Reinit_ns
|
`Help
|
`Dump
of
pexpr
|
`Print_schema
of
string
|
`Print_schema_type
of
Schema_types
.
component_kind
*
string
*
string
|
`Print_type
of
string
|
`Print_schema
of
U
.
t
|
`Print_schema_type
of
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
|
`Print_type
of
U
.
t
]
...
...
@@ -59,7 +59,7 @@ and pexpr =
|
Map
of
pexpr
*
branches
|
Transform
of
pexpr
*
branches
|
Xtrans
of
pexpr
*
branches
|
Validate
of
pexpr
*
Schema_types
.
component_kind
*
string
*
string
|
Validate
of
pexpr
*
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
(* exp, schema component kind, schema name, element name *)
|
Dot
of
pexpr
*
label
|
RemoveField
of
pexpr
*
label
...
...
@@ -91,7 +91,7 @@ and ppat = ppat' located
and
ppat'
=
|
PatVar
of
U
.
t
|
SchemaVar
of
(* type/pattern schema variable *)
Schema_types
.
component_kind
*
string
*
string
(* kind, schema, name *)
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
(* kind, schema, name *)
|
Cst
of
pexpr
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
id
*
ppat
)
list
...
...
parser/parser.ml
View file @
c5e7054e
...
...
@@ -114,7 +114,7 @@ EXTEND
|
"schema"
;
name
=
IDENT
;
"="
;
uri
=
STRING2
->
protect_op
"schema"
;
let
schema
=
Schema_parser
.
schema_of_file
uri
in
[
mk
loc
(
SchemaDecl
(
name
,
schema
))
]
[
mk
loc
(
SchemaDecl
(
U
.
mk
name
,
schema
))
]
|
(
name
,
ns
)
=
namespace_binding
->
[
mk
loc
(
Namespace
(
name
,
ns
))
]
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
...
...
@@ -127,7 +127,7 @@ EXTEND
|
DIRECTIVE
"#quit"
->
[
mk
loc
(
Directive
`Quit
)
]
|
DIRECTIVE
"#env"
->
[
mk
loc
(
Directive
`Env
)
]
|
DIRECTIVE
"#print_schema"
;
name
=
IDENT
->
[
mk
loc
(
Directive
(
`Print_schema
name
))
]
[
mk
loc
(
Directive
(
`Print_schema
(
U
.
mk
name
))
)
]
|
DIRECTIVE
"#print_type"
;
name
=
IDENT
;
schema_part
=
OPT
[
"#"
;
typ
=
[
IDENT
|
keyword
];
...
...
@@ -135,9 +135,10 @@ EXTEND
(
kind
,
typ
)
]
->
(
match
schema_part
with
|
None
->
[
mk
loc
(
Directive
(
`Print_type
name
))
]
|
None
->
[
mk
loc
(
Directive
(
`Print_type
(
U
.
mk
name
))
)
]
|
Some
(
kind
,
typ
)
->
[
mk
loc
(
Directive
(
`Print_schema_type
(
kind
,
name
,
typ
)))
])
[
mk
loc
(
Directive
(
`Print_schema_type
(
kind
,
U
.
mk
name
,
U
.
mk
typ
)))
])
|
DIRECTIVE
"#dump_value"
;
e
=
expr
->
[
mk
loc
(
Directive
(
`Dump
e
))
]
|
DIRECTIVE
"#reinit_ns"
->
[
mk
loc
(
Directive
`Reinit_ns
)
]
|
DIRECTIVE
"#help"
->
[
mk
loc
(
Directive
`Help
)
]
...
...
@@ -483,7 +484,7 @@ EXTEND
schema_ref
:
[
[
schema
=
IDENT
;
"#"
;
typ
=
[
IDENT
|
keyword
];
kind
=
OPT
[
"as"
;
k
=
schema_kind
->
k
]
->
(
kind
,
schema
,
typ
)
(
kind
,
U
.
mk
schema
,
U
.
mk
typ
)
]
];
...
...
@@ -508,7 +509,7 @@ EXTEND
mk
loc
(
Constant
(
ident
a
,
c
))
|
schema
=
IDENT
;
"#"
;
typ
=
[
IDENT
|
keyword
];
kind
=
OPT
[
"as"
;
k
=
schema_kind
->
k
]
->
mk
loc
(
SchemaVar
(
kind
,
schema
,
typ
))
mk
loc
(
SchemaVar
(
kind
,
U
.
mk
schema
,
U
.
mk
typ
))
|
a
=
IDENT
->
mk
loc
(
PatVar
(
U
.
mk
a
))
|
i
=
INT
;
"--"
;
j
=
INT
->
...
...
schema/schema_builtin.ml
View file @
c5e7054e
This diff is collapsed.
Click to expand it.
schema/schema_builtin.mli
View file @
c5e7054e
open
Encodings
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception
Schema_builtin_error
of
string
exception
Schema_builtin_error
of
Utf8
.
t
val
is_builtin
:
string
->
bool
val
get_builtin
:
string
->
Schema_types
.
simple_type_definition
val
is_builtin
:
Utf8
.
t
->
bool
val
get_builtin
:
Utf8
.
t
->
Schema_types
.
simple_type_definition
val
iter_builtin
:
(
Schema_types
.
simple_type_definition
->
unit
)
->
unit
val
cd_type_of_builtin
:
string
->
Types
.
descr
val
cd_type_of_builtin
:
Utf8
.
t
->
Types
.
descr
(** @raise Schema_builtin_error [name] in case of validation error, where
(** validate_builtin <builtin> <string>
* validates <string> against builtin type <builtin> and return the resulting
* cduce value
* @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
:
string
->
string
->
Value
.
t
val
validate_builtin
:
Utf8
.
t
->
Utf8
.
t
->
Value
.
t
schema/schema_common.ml
View file @
c5e7054e
open
Printf
open
Encodings
open
Encodings
.
Utf8
.
Pcre
open
Schema_types
let
no_facets
=
{
...
...
@@ -29,7 +31,7 @@ let name_of_complex_type_definition = function
|
_
,
Some
name
,
_
,
_
,
_
,
_
->
name
|
_
->
raise
(
Invalid_argument
"anonymous complex type definition"
)
let
name_of_type_definition
=
function
|
AnyType
->
"xsd:anyType"
|
AnyType
->
Encodings
.
Utf8
.
mk
"xsd:anyType"
|
Simple
st
->
name_of_simple_type_definition
st
|
Complex
ct
->
name_of_complex_type_definition
ct
let
name_of_attribute_declaration
(
name
,
_
,
_
)
=
name
...
...
@@ -63,26 +65,24 @@ let iter_attribute_groups schema f = List.iter f schema.attribute_groups
let
iter_model_groups
schema
f
=
List
.
iter
f
schema
.
model_groups
exception
XSD_validation_error
of
string
exception
XSI_validation_error
of
validation_context
*
string
let
regexp'
s
=
Pcre
.
regexp
~
flags
:
[
`UTF8
]
s
exception
XSI_validation_error
of
string
let
rec
normalize_white_space
=
let
ws_RE
=
regexp
'
"[
\t\r\n
]"
in
let
spaces_RE
=
regexp
'
"[ ]+"
in
let
margins_RE
=
regexp
'
"^ (.*) $"
in
let
ws_RE
=
pcre_
regexp
"[
\t\r\n
]"
in
let
spaces_RE
=
pcre_
regexp
"[ ]+"
in
let
margins_RE
=
pcre_
regexp
"^ (.*) $"
in
fun
handling
s
->
match
handling
with
|
`Preserve
->
s
|
`Replace
->
P
cre
.
replace
~
rex
:
ws_RE
~
templ
:
" "
s
|
`Replace
->
p
cre
_
replace
~
rex
:
ws_RE
~
templ
:
(
Utf8
.
mk
" "
)
s
|
`Collapse
->
let
s'
=
P
cre
.
replace
~
rex
:
spaces_RE
~
templ
:
" "
p
cre
_
replace
~
rex
:
spaces_RE
~
templ
:
(
Utf8
.
mk
" "
)
(
normalize_white_space
`Replace
s
)
in
P
cre
.
replace
~
rex
:
margins_RE
~
templ
:
"$1"
s'
p
cre
_
replace
~
rex
:
margins_RE
~
templ
:
(
Utf8
.
mk
"$1"
)
s'
let
anySimpleType
=
Primitive
"xsd:anySimpleType"
let
anySimpleType
=
Primitive
(
Encodings
.
Utf8
.
mk
"xsd:anySimpleType"
)
let
anyType
=
AnyType
let
get_interval
facets
=
...
...
@@ -113,22 +113,27 @@ let get_interval facets =
|
None
,
None
->
Intervals
.
any
let
print_simple_type
fmt
=
function
|
Primitive
name
->
Format
.
fprintf
fmt
"%s"
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%s'"
name
|
Primitive
name
->
Format
.
fprintf
fmt
"%a"
Encodings
.
Utf8
.
dump
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%a'"
Encodings
.
Utf8
.
dump
name
|
Derived
(
None
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"unnamed'"
let
print_complex_type
fmt
=
function
|
(
id
,
Some
name
,
_
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%d:%s"
id
name
|
(
id
,
Some
name
,
_
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%d:%a"
id
Encodings
.
Utf8
.
dump
name
|
(
id
,
None
,
_
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%d:unnamed'"
id
let
print_type
fmt
=
function
|
AnyType
->
Format
.
fprintf
fmt
"xsd:anyType"
|
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
(
name
,
t
,
_
)
=
Format
.
fprintf
fmt
"@@%s:%a"
name
print_simple_type
t
let
print_element
fmt
(
id
,
name
,
_
,
_
)
=
Format
.
fprintf
fmt
"E:%d:<%s>"
id
name
Format
.
fprintf
fmt
"@@%a:%a"
Utf8
.
dump
name
print_simple_type
t
let
print_element
fmt
(
id
,
name
,
_
,
_
)
=
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Utf8
.
dump
name
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
let
print_attribute_group
fmt
(
name
,
_
)
=
Format
.
fprintf
fmt
"{agroup:%s}"
name
let
print_model_group
fmt
(
name
,
_
)
=
Format
.
fprintf
fmt
"{mgroup:%s}"
name
let
print_attribute_group
fmt
(
name
,
_
)
=
Format
.
fprintf
fmt
"{agroup:%a}"
Utf8
.
dump
name
let
print_model_group
fmt
(
name
,
_
)
=
Format
.
fprintf
fmt
"{mgroup:%a}"
Utf8
.
dump
name
let
print_schema
fmt
schema
=
let
defined_types
=
(* filter out built-in types *)
List
.
filter
...
...
@@ -277,4 +282,85 @@ let string_of_component_kind (kind: component_kind) =
|
Some
`Model_group
->
"model group"
|
None
->
"component"
(** Events *)
type
to_be_visited
=
|
Fully
of
Value
.
t
(* xml values still to be visited *)
|
Half
of
Value
.
t
(* xml values half visited (i.e. E_start_tag generated) *)
|
Other
of
Encodings
.
Utf8
.
t
(* other values *)
|
Backlog
of
event
(* old events not yet delivered *)
let
stream_of_value
v
=
let
stack
=
ref
[
Fully
v
]
in
let
f
_
=
(* lazy visit of a tree of CDuce XML values, stack keeps track of
what is still to be visited *)
match
!
stack
with
|
(
Fully
((
Value
.
Xml
(
Value
.
Atom
atom
,
attrs
,
_
))
as
v
))
::
tl
->
stack
:=
(
Half
v
)
::
tl
;
let
children
=
ref
[]
in
(* TODO inefficient *)
let
push
v
s
=
(
s
:=
v
::
!
s
)
in
Value
.
iter_xml
(
fun
pcdata
->
push
(
Other
pcdata
)
children
)
(
fun
v
->
match
v
with
|
(
Value
.
Xml
(
_
,
_
,
_
))
as
v
->
push
(
Fully
v
)
children
|
v
->
raise
(
Invalid_argument
"Schema_events.stream_of_value"
))
v
;
stack
:=
(
List
.
rev
!
children
)
@
!
stack
;
List
.
iter
(* push attributes as events on the stack *)
(
fun
(
qname
,
v
)
->
push
(
Backlog
(
E_attribute
(
qname
,
fst
(
Value
.
get_string_utf8
v
))))
stack
)
(
Value
.
get_fields
attrs
);
Some
(
E_start_tag
(
Atoms
.
V
.
value
atom
))
|
(
Half
(
Value
.
Xml
(
Value
.
Atom
atom
,
_
,
_
)))
::
tl
->
stack
:=
tl
;
Some
(
E_end_tag
(
Atoms
.
V
.
value
atom
))
|
(
Fully
(
Value
.
Xml
(
_
,
_
,
_
)))
::_
|
(
Half
(
Value
.
Xml
(
_
,
_
,
_
)))
::_
->
failwith
"Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
|
(
Backlog
ev
)
::
tl
->
(* consume backlog *)
stack
:=
tl
;
Some
ev
|
(
Other
v
)
::
tl
->
stack
:=
tl
;
Some
(
E_char_data
v
)
|
[]
->
None
|
_
->
assert
false
in
Stream
.
from
f
let
string_of_event
=
function
|
E_start_tag
qname
->
sprintf
"<%s>"
(
Ns
.
QName
.
to_string
qname
)
|
E_end_tag
qname
->
sprintf
"</%s>"
(
Ns
.
QName
.
to_string
qname
)
|
E_attribute
(
qname
,
value
)
->
sprintf
"@%s=%s"
(
Ns
.
QName
.
to_string
qname
)
(
Utf8
.
to_string
value
)
|
E_char_data
value
->
Utf8
.
to_string
value
(*
let test v =
let s = stream_of_value v in
let rec aux () =
(match Stream.peek s with
| None -> ()
| Some (E_start_tag qname) ->
Ns.QName.print Format.std_formatter qname
| Some (E_end_tag qname) ->
Format.fprintf Format.std_formatter "/";
Ns.QName.print Format.std_formatter qname
| Some (E_attribute (qname, value)) ->
Format.fprintf Format.std_formatter "@@";
Ns.QName.print Format.std_formatter qname;
Format.fprintf Format.std_formatter " ";
Encodings.Utf8.print Format.std_formatter value
| Some (E_char_data value) ->
Encodings.Utf8.print Format.std_formatter value);
Format.fprintf Format.std_formatter "\n";
(match Stream.peek s with
| None -> ()
| _ ->
Stream.junk s;
aux ())
in
aux ()
*)
schema/schema_common.mli
View file @
c5e7054e
(** Schema common functionalities depending only on Schema_types *)
open
Encodings
open
Schema_types
(** {2 Exceptions} *)
exception
XSD_validation_error
of
string
exception
XSI_validation_error
of
validation_context
*
string
exception
XSI_validation_error
of
string
(** {2 XSD printer *)
...
...
@@ -22,15 +23,15 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
val
name_of_element_declaration
:
element_declaration
->
string
val
name_of_type_definition
:
type_definition
->
string
val
name_of_simple_type_definition
:
simple_type_definition
->
string
val
name_of_complex_type_definition
:
complex_type_definition
->
string
val
name_of_attribute_declaration
:
attribute_declaration
->
string
val
name_of_attribute_use
:
attribute_use
->
string
val
name_of_attribute_group_definition
:
attribute_group_definition
->
string
val
name_of_model_group_definition
:
model_group_definition
->
string
val
name_of_particle
:
particle
->
string
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
string_of_component_kind
:
component_kind
->
string
...
...
@@ -40,13 +41,13 @@ 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
:
string
->
schema
->
type_definition
val
get_attribute
:
string
->
schema
->
attribute_declaration
val
get_element
:
string
->
schema
->
element_declaration
val
get_attribute_group
:
string
->
schema
->
attribute_group_definition
val
get_model_group
:
string
->
schema
->
model_group_definition
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_component
:
component_kind
->
string
->
schema
->
component
val
get_component
:
component_kind
->
Utf8
.
t
->
schema
->
component
val
iter_types
:
schema
->
(
type_definition
->
unit
)
->
unit
val
iter_attributes
:
schema
->
(
attribute_declaration
->
unit
)
->
unit
...
...
@@ -61,7 +62,7 @@ val merge_facets: facets -> facets -> facets
(** restrict base new_facets new_name
* Implements simple type derivition by restriction *)
val
restrict
:
simple_type_definition
->
facets
->
string
option
->
val
restrict
:
simple_type_definition
->
facets
->
Utf8
.
t
option
->
simple_type_definition
(** {2 Miscellaneous} *)
...
...
@@ -77,5 +78,10 @@ val anyType: type_definition
val
get_interval
:
facets
->
Intervals
.
t
(** perform white space normalization according to XML recommendation *)
val
normalize_white_space
:
white_space_handling
->
string
->
string
val
normalize_white_space
:
white_space_handling
->
Utf8
.
t
->
Utf8
.
t
(** event interface on top of CDuce values *)
val
stream_of_value
:
Value
.
t
->
event
Stream
.
t
val
string_of_event
:
event
->
string
schema/schema_parser.ml
View file @
c5e7054e
...
...
@@ -2,6 +2,8 @@
open
Printf
open
Pxp_document
open
Encodings
open
Encodings
.
Utf8
.
Pcre
open
Schema_common
open
Schema_types
open
Schema_validator
...
...
@@ -18,9 +20,8 @@ let debug_print ?(n: pxp_node option) s =
prerr_endline
(
sprintf
"[%d] %s"
line
s
);
flush
stderr
)
let
regexp'
s
=
Pcre
.
regexp
~
flags
:
[
`UTF8
]
s
let
space_RE
=
regexp'
" "
let
split
s
=
Pcre
.
split
~
rex
:
space_RE
s
let
space_RE
=
pcre_regexp
" "
let
split
s
=
pcre_split
~
rex
:
space_RE
s
let
hashtbl_deref
tbl
=
(* ASSUMPTION: no multiple bindings *)
let
tbl'
=
Hashtbl
.
create
1024
in
...
...
@@ -34,15 +35,15 @@ class type resolver =
@raise Osv_validation_error if the same node is seen twice *)
method
see
:
pxp_node
->
unit
method
resolve_att
:
?
fix_ns
:
bool
->
string
->
attribute_declaration
method
resolve_att
:
?
fix_ns
:
bool
->
Utf8
.
t
->
attribute_declaration
method
resolve_elt
:
?
fix_ns
:
bool
->
now
:
bool
->
string
->
element_declaration
ref
?
fix_ns
:
bool
->
now
:
bool
->
Utf8
.
t
->
element_declaration
ref
method
resolve_typ
:
?
fix_ns
:
bool
->
now
:
bool
->
string
->
type_definition
ref
?
fix_ns
:
bool
->
now
:
bool
->
Utf8
.
t
->
type_definition
ref
method
resolve_att_group
:
?
fix_ns
:
bool
->
string
->
attribute_group_definition
method
resolve_model_group
:
?
fix_ns
:
bool
->
string
->
model_group_definition
method
resolve_simple_typ
:
?
fix_ns
:
bool
->
string
->
simple_type_definition
?
fix_ns
:
bool
->
Utf8
.
t
->
attribute_group_definition
method
resolve_model_group
:
?
fix_ns
:
bool
->
Utf8
.
t
->
model_group_definition
method
resolve_simple_typ
:
?
fix_ns
:
bool
->
Utf8
.
t
->
simple_type_definition
end
module
OrderedNode
=
...
...
@@ -73,11 +74,14 @@ let parse_facets base n =
debug_print
~
n
"Schema_parser.parse_facet"
;
let
validate_base_type
=
Schema_validator
.
validate_simple_type
base
in
let
validate_nonNegativeInteger
=
Schema_builtin
.
validate_builtin
"xsd:nonNegativeInteger"
Schema_builtin
.
validate_builtin
(
Schema_xml
.
add_xsd_prefix
(
Utf8
.
mk
"nonNegativeInteger"
))
in
let
facets
=
ref
no_facets
in
n
#
iter_nodes
(
fun
n
->
let
fixed
=
(
_has_attribute
"fixed"
n
)
&&
(
_attribute
"fixed"
n
=
"true"
)
in
let
fixed
=
(
_has_attribute
"fixed"
n
)
&&
(
_attribute
"fixed"
n
=
Utf8
.
mk
"true"
)
in
match
n
#
node_type
with
|
T_element
"xsd:length"
->
let
value
=
_attribute
"value"
n
in
...
...
@@ -92,7 +96,7 @@ let parse_facets base n =
let
length
=
integer_of_value_t
(
validate_nonNegativeInteger
value
)
in
facets
:=
{
!
facets
with
maxLength
=
Some
(
length
,
fixed
)
}
|
T_element
"xsd:enumeration"
->
let
value
=
Value
.
string_
latin1
(
_attribute
"value"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"value"
n
)
in
let
value
=
validate_base_type
value
in
let
new_enumeration
=
(
match
!
facets
.
enumeration
with
...
...
@@ -101,7 +105,7 @@ let parse_facets base n =
in
facets
:=
{
!
facets
with
enumeration
=
new_enumeration
}
|
T_element
"xsd:whiteSpace"
->
let
value
=
_attribute
"value"
n
in
let
value
=
Utf8
.
get_str
(
_attribute
"value"
n
)
in
facets
:=
{
!
facets
with
whiteSpace
=
((
match
value
with
|
"collapse"
->
`Collapse
...
...
@@ -110,19 +114,19 @@ let parse_facets base n =
|
_
->
assert
false
)
,
fixed
)
}
|
T_element
"xsd:maxInclusive"
->
let
value
=
Value
.
string_
latin1
(
_attribute
"value"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"value"
n
)
in
facets
:=
{
!
facets
with
maxInclusive
=
Some
(
validate_base_type
value
,
fixed
)
}
|
T_element
"xsd:maxExclusive"
->
let
value
=
Value
.
string_
latin1
(
_attribute
"value"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"value"
n
)
in
facets
:=
{
!
facets
with
maxExclusive
=
Some
(
validate_base_type
value
,
fixed
)
}
|
T_element
"xsd:minInclusive"
->
let
value
=
Value
.
string_
latin1
(
_attribute
"value"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"value"
n
)
in
facets
:=
{
!
facets
with
minInclusive
=
Some
(
validate_base_type
value
,
fixed
)
}
|
T_element
"xsd:minExclusive"
->
let
value
=
Value
.
string_
latin1
(
_attribute
"value"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"value"
n
)
in
facets
:=
{
!
facets
with
minExclusive
=
Some
(
validate_base_type
value
,
fixed
)
}
|
_
->
()
);
...
...
@@ -195,11 +199,11 @@ and find_member_types (resolver: resolver) n =
let
parse_att_value_constraint
stype_def
n
=
debug_print
~
n
"Schema_parser.parse_att_value_constraint"
;
if
_has_attribute
"default"
n
then
let
value
=
Value
.
string_
latin1
(
_attribute
"default"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"default"
n
)
in
let
value
=
validate_simple_type
stype_def
value
in
Some
(
`Default
value
)
else
if
_has_attribute
"fixed"
n
then
let
value
=
Value
.
string_
latin1
(
_attribute
"fixed"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"fixed"
n
)
in
let
value
=
validate_simple_type
stype_def
value
in
Some
(
`Fixed
value
)
else
...
...
@@ -212,14 +216,14 @@ let parse_elt_value_constraint type_def n =
match
type_def
with
|
Simple
st_def
|
Complex
(
_
,
_
,
_
,
_
,
_
,
CT_simple
st_def
)
->
validate_simple_type
st_def
|
_
->
validate_simple_type
(
Primitive
"xsd:string"
)
|
_
->
validate_simple_type
(
Primitive
(
Utf8
.
mk
"xsd:string"
)
)
in
if
_has_attribute
"default"
n
then
let
value
=
Value
.
string_
latin1
(
_attribute
"default"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"default"
n
)
in
let
value
=
validate_value
value
in
Some
(
`Default
value
)
else
if
_has_attribute
"fixed"
n
then
let
value
=
Value
.
string_
latin1
(
_attribute
"fixed"
n
)
in
let
value
=
Value
.
string_
utf8
(
_attribute
"fixed"
n
)
in
let
value
=
validate_value
value
in
Some
(
`Fixed
value
)
else
...
...
@@ -246,7 +250,7 @@ let parse_att_decl (resolver: resolver) n =
let
parse_attribute_use
(
resolver
:
resolver
)
n
=
debug_print
~
n
"Schema_parser.parse_attribute_use"
;
let
required
=
(
_has_attribute
"use"
n
)
&&
(
_attribute
"use"
n
=
"required"
)
(
_has_attribute
"use"
n
)
&&
(
_attribute
"use"
n
=
Utf8
.
mk
"required"
)
in
let
(
name
,
type_def
,
value_constr
)
as
att_decl
=
if
_has_attribute
"ref"
n
then
...
...
@@ -291,11 +295,11 @@ let parse_attribute_uses (resolver: resolver) derivation_type base n =
let
parse_min_max
n
=
((
if
_has_attribute
"minOccurs"
n
then
Intervals
.
V
.
mk
(
_attribute
"minOccurs"
n
)
Intervals
.
V
.
mk
(
Utf8
.
get_str
(
_attribute
"minOccurs"
n
)
)
else
Intervals
.
V
.
one
)
,
(
if
_has_attribute
"maxOccurs"
n
then
match
_attribute
"maxOccurs"
n
with
match
Utf8
.
get_str
(
_attribute
"maxOccurs"
n
)
with
|
"unbounded"
->
None
|
s
->
Some
(
Intervals
.
V
.
mk
s
)
else
...
...
@@ -366,8 +370,9 @@ let rec parse_complex_type (resolver: resolver) n =
let
base
=
resolver
#
resolve_typ
~
now
:
true
(
_attribute
"base"
derivation
)
in
let
uses
=
parse_attribute_uses
resolver
derivation_type
!
base
derivation
in
let
mixed
=
(
_has_attribute
"mixed"
content
&&
(
_attribute
"mixed"
content
=
"true"
))
||
(
_has_attribute
"mixed"
n
&&
(
_attribute
"mixed"
n
=
"true"
))
(
_has_attribute
"mixed"
content
&&
(
_attribute
"mixed"
content
=
Utf8
.
mk
"true"
))
||
(
_has_attribute
"mixed"
n
&&
(
_attribute
"mixed"
n
=
Utf8
.
mk
"true"
))
in
let
particle_node
=
find_particle
derivation
in
let
content_type
=
...
...
@@ -397,7 +402,9 @@ let rec parse_complex_type (resolver: resolver) n =
else
(* neither simpleContent nor complexContent *)
let
base
=
anyType
in
let
uses
=
parse_attribute_uses
resolver
`Restriction
base
n
in
let
mixed
=
_has_attribute
"mixed"
n
&&
(
_attribute
"mixed"
n
=
"true"
)
in
let
mixed
=
_has_attribute
"mixed"
n
&&
(
_attribute
"mixed"
n
=
Utf8
.
mk
"true"
)
in
let
content_type
=
match
find_particle
n
with
|
None
->
CT_empty
...
...
@@ -488,27 +495,29 @@ let parse_model_group_def (resolver: resolver) n =
(** @param root schema document root node *)
class
lazy_resolver
=
let
fake_type_def
=
Complex
(
~-
1
,
Some
" FAKE TYP "
,
AnyType
,
`Restriction
,
[]
,
CT_empty
)
Complex
(
~-
1
,
Some
(
Utf8
.
mk
" FAKE TYP "
)
,
AnyType
,
`Restriction
,
[]
,
CT_empty
)
in
let
fake_elt_decl
=
~-
2
,
" FAKE ELT "
,
ref
fake_type_def
,
None
in
let
fake_elt_decl
=
~-
2
,
Utf8
.
mk
" FAKE ELT "
,
ref
fake_type_def
,
None
in
let
is_fake_type_def
=
(
==
)
fake_type_def
in
let
is_fake_elt_decl
=
(
==
)
fake_elt_decl
in
let
validation_error
s
=
raise
(
XSD_validation_error
s
)
in
let
get_ns_prefix
n
=
match
n
#
node_type
with
T_namespace
p
->
p
|
_
->
assert
false
in
let
(
^^
)
x
y
=
Utf8
.
concat
x
y
in
fun
root
->
object
(
self
)
val
typs
:
(
string
,
type_definition
ref
)
Hashtbl
.
t
=
val
typs
:
(
Utf8
.
t
,
type_definition
ref
)
Hashtbl
.
t
=
Hashtbl
.
create
17
val
attrs
:
(
string
,
attribute_declaration
)
Hashtbl
.
t
=
val
attrs
:
(
Utf8
.
t
,
attribute_declaration
)
Hashtbl
.
t
=
Hashtbl
.
create
17
val
elts
:
(
string
,
element_declaration
ref
)
Hashtbl
.
t
=
val
elts
:
(
Utf8
.
t
,
element_declaration
ref
)
Hashtbl
.
t
=
Hashtbl
.
create
17
val
attr_groups
:
(
string
,
attribute_group_definition
)
Hashtbl
.
t
=
val
attr_groups
:
(
Utf8
.
t
,
attribute_group_definition
)
Hashtbl
.
t
=
Hashtbl
.
create
17