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
30ec2f64
Commit
30ec2f64
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-24 15:27:50 by afrisch] Simple types
Original author: afrisch Date: 2005-02-24 15:27:51+00:00
parent
d74ebb0d
Changes
13
Hide whitespace changes
Inline
Side-by-side
runtime/print_xml.ml
View file @
30ec2f64
...
...
@@ -21,7 +21,7 @@ let rec schema_value ?(recurs=true) ~wds v =
|
Record
_
as
v
->
(
try
wds
(
Schema_builtin
.
string_of_time_type
(
Value
.
get_fields
v
))
with
Schema_builtin
.
Schema_builtin_e
rror
_
->
raise
exn_print_xml
)
with
Schema_builtin
.
E
rror
_
->
raise
exn_print_xml
)
|
Integer
i
->
wds
(
U
.
mk
(
Intervals
.
V
.
to_string
i
))
|
v
when
Value
.
equal
v
Value
.
vtrue
->
wds
true
_literal
|
v
when
Value
.
equal
v
Value
.
vfalse
->
wds
false
_literal
...
...
schema/schema_builtin.ml
View file @
30ec2f64
...
...
@@ -51,8 +51,8 @@ let char_of_hex =
let
strip_parens
s
=
Pcre
.
replace
~
pat
:
"[()]"
s
let
add_limits
s
=
"^"
^
s
^
"$"
exception
Schema_builtin_e
rror
of
string
let
simple_type_error
name
=
raise
(
Schema_builtin_e
rror
name
)
exception
E
rror
of
string
let
simple_type_error
name
=
raise
(
E
rror
name
)
let
qualify
s
=
(
Ns
.
empty
,
Encodings
.
Utf8
.
mk
s
)
...
...
@@ -113,7 +113,6 @@ let gYear_type = Types.rec_of_list' [ time_kind_field; positive_field; year_fiel
let
gMonthDay_type
=
Types
.
rec_of_list'
[
time_kind_field
;
month_field
;
day_field
]
let
gDay_type
=
Types
.
rec_of_list'
[
time_kind_field
;
day_field
]
let
gMonth_type
=
Types
.
rec_of_list'
[
time_kind_field
;
month_field
]
let
nonPositiveInteger_type
=
Builtin_defs
.
non_pos_int
let
negativeInteger_type
=
Builtin_defs
.
neg_int
let
nonNegativeInteger_type
=
Builtin_defs
.
non_neg_int
...
...
@@ -248,7 +247,7 @@ let validate_duration =
else
[
qualify
"second"
,
validate_integer
subs
.
(
14
)])
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_dateTime
=
let
rex
=
Pcre
.
regexp
(
sprintf
"^([+-])?(%s)T(%s)(%s)?$"
...
...
@@ -267,7 +266,7 @@ let validate_dateTime =
parse_timezone'
subs
.
(
4
)
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_gYearMonth
=
let
rex
=
Pcre
.
regexp
(
add_limits
gYearMonth_RE_raw
)
in
...
...
@@ -283,7 +282,7 @@ let validate_gYearMonth =
]
@
parse_timezone'
subs
.
(
4
)
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_gYear
=
let
rex
=
Pcre
.
regexp
(
add_limits
gYear_RE_raw
)
in
...
...
@@ -298,7 +297,7 @@ let validate_gYear =
]
@
parse_timezone'
subs
.
(
3
)
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_gMonthDay
=
let
rex
=
Pcre
.
regexp
(
add_limits
gMonthDay_RE_raw
)
in
...
...
@@ -313,7 +312,7 @@ let validate_gMonthDay =
]
@
parse_timezone'
subs
.
(
3
)
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_gDay
=
let
rex
=
Pcre
.
regexp
(
add_limits
gDay_RE_raw
)
in
...
...
@@ -327,7 +326,7 @@ let validate_gDay =
(
parse_timezone'
subs
.
(
2
))
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_gMonth
=
let
rex
=
Pcre
.
regexp
(
add_limits
gMonth_RE_raw
)
in
...
...
@@ -341,7 +340,7 @@ let validate_gMonth =
(
parse_timezone'
subs
.
(
2
))
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_time
=
let
rex
=
Pcre
.
regexp
(
sprintf
"^(%s)(%s)?$"
(
strip_parens
time_RE_raw
)
...
...
@@ -358,7 +357,7 @@ let validate_time =
else
[
qualify
"timezone"
,
Value
.
vrecord
(
parse_timezone
subs
.
(
2
))
])
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_date
=
let
rex
=
Pcre
.
regexp
(
sprintf
"^(-)?(%s)(%s)?$"
(
strip_parens
date_RE_raw
)
...
...
@@ -376,7 +375,7 @@ let validate_date =
else
[
qualify
"timezone"
,
Value
.
vrecord
(
parse_timezone
subs
.
(
3
))
])
in
Value
.
vrecord
fields
with
Schema_builtin_e
rror
_
->
abort
()
with
E
rror
_
->
abort
()
let
validate_hexBinary
s
=
let
s
=
Utf8
.
get_str
s
in
...
...
@@ -407,133 +406,131 @@ let validate_anyURI s =
(** {2 API backend} *)
type
t
=
simple_type_definition
*
Types
.
t
*
(
Utf8
.
t
->
Value
.
t
)
module
QTable
=
Hashtbl
.
Make
(
Ns
.
QName
)
let
builtins
=
QTable
.
create
50
let
reg
name
spec
=
QTable
.
add
builtins
(
add_xsd_prefix
name
)
spec
let
builtins
:
t
QTable
.
t
=
QTable
.
create
50
let
reg
=
QTable
.
add
builtins
(*
let alias alias name =
let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
QTable
.
add
builtins
alias
(
let
(
st_def
,
descr
,
validator
)
=
QTable
.
find
builtins
name
in
let
new_def
=
match
st_def
with
|
Primitive
_
->
Primitive
alias
|
Derived
(
_
,
variety
,
facets
,
base
)
->
Derived
(
Some
alias
,
variety
,
facets
,
base
)
in
(
new_def
,
descr
,
validator
))
let
restrict'
name
basename
new_facets
=
let
(
name
,
basename
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
basename
)
in
let
(
base
,
_
,
_
)
=
QTable
.
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
in
Derived
(
Some
name
,
variety
,
facets
,
lazy
(
Simple
base
))
let
list'
name
itemname
=
let
(
name
,
itemname
)
=
(
add_xsd_prefix
name
,
add_xsd_prefix
itemname
)
in
let
(
base
,
_
,
_
)
=
QTable
.
find
builtins
itemname
in
let
base
=
lazy
(
Simple
base
)
in
Derived
(
Some
name
,
List
base
,
no_facets
,
base
)
let
fill
()
=
(* fill "builtins" hashtbl *)
let
primitive
name
=
Primitive
(
add_xsd_prefix
name
)
in
(* primitive builtins *)
reg
"anySimpleType"
(
primitive
"anySimpleType"
,
Builtin_defs
.
string
,
validate_string
);
alias
"anyType"
"anySimpleType"
;
(* TODO BUG HERE *)
reg
"string"
(
primitive
"string"
,
Builtin_defs
.
string
,
validate_string
);
QTable.add builtins alias (QTable.find builtins name)
*)
let
restrict
name
(
base
,_,_
)
facets
cd
v
=
let
name
=
add_xsd_prefix
name
in
let
t
=
simple_restrict
(
Some
name
)
base
facets
in
let
b
=
(
t
,
cd
,
v
)
in
reg
name
b
;
b
let
list
name
=
simple_list
(
Some
(
add_xsd_prefix
name
))
let
primitive
name
cd
v
=
let
name
=
add_xsd_prefix
name
in
let
rec
t
=
{
st_name
=
Some
name
;
st_variety
=
Atomic
t
;
st_facets
=
no_facets
;
st_base
=
None
}
in
let
b
=
(
t
,
cd
,
v
)
in
reg
name
b
;
b
let
any_simple_type
=
primitive
"anySimpleType"
Builtin_defs
.
string
validate_string
let
string
=
primitive
"string"
Builtin_defs
.
string
validate_string
let
integer
=
primitive
"integer"
Builtin_defs
.
int
validate_integer
let
_
=
primitive
"boolean"
Builtin_defs
.
bool
validate_bool
let
_
=
primitive
"hexBinary"
Builtin_defs
.
string
validate_hexBinary
let
_
=
primitive
"base64Binary"
Builtin_defs
.
string
validate_base64Binary
let
_
=
primitive
"anyURI"
Builtin_defs
.
string
validate_anyURI
let
_
=
primitive
"duration"
duration_type
validate_duration
let
_
=
primitive
"dateTime"
dateTime_type
validate_dateTime
let
_
=
primitive
"time"
time_type
validate_time
let
_
=
primitive
"date"
date_type
validate_date
let
_
=
primitive
"gYearMonth"
gYearMonth_type
validate_gYearMonth
let
_
=
primitive
"gYear"
gYear_type
validate_gYear
let
_
=
primitive
"gMonthDay"
gMonthDay_type
validate_gMonthDay
let
_
=
primitive
"gDay"
gDay_type
validate_gDay
let
_
=
primitive
"gMonth"
gMonth_type
validate_gMonth
(*
(* TODO following types not yet supported (see "unsupported" above) *)
alias "decimal" "string";
alias "float" "string";
alias "double" "string";
alias "NOTATION" "string";
alias "QName" "string";
reg
"boolean"
(
primitive
"boolean"
,
Builtin_defs
.
bool
,
validate_bool
);
reg
"hexBinary"
(
primitive
"hexBinary"
,
Builtin_defs
.
string
,
validate_hexBinary
);
reg
"base64Binary"
(
primitive
"base64Binary"
,
Builtin_defs
.
string
,
validate_base64Binary
);
reg
"anyURI"
(
primitive
"anyURI"
,
Builtin_defs
.
string
,
validate_anyURI
);
reg
"duration"
(
primitive
"duration"
,
duration_type
,
validate_duration
);
reg
"dateTime"
(
primitive
"dateTime"
,
dateTime_type
,
validate_dateTime
);
reg
"time"
(
primitive
"time"
,
time_type
,
validate_time
);
reg
"date"
(
primitive
"date"
,
date_type
,
validate_date
);
reg
"gYearMonth"
(
primitive
"gYearMonth"
,
gYearMonth_type
,
validate_gYearMonth
);
reg
"gYear"
(
primitive
"gYear"
,
gYear_type
,
validate_gYear
);
reg
"gMonthDay"
(
primitive
"gMonthDay"
,
gMonthDay_type
,
validate_gMonthDay
);
reg
"gDay"
(
primitive
"gDay"
,
gDay_type
,
validate_gDay
);
reg
"gMonth"
(
primitive
"gMonth"
,
gMonth_type
,
validate_gMonth
);
*)
(* derived builtins *)
reg
"integer"
(
restrict'
"integer"
"decimal"
no_facets
,
(* fake restriction *)
Builtin_defs
.
int
,
validate_integer
);
reg
"nonPositiveInteger"
(
restrict'
"nonPositiveInteger"
"integer"
{
no_facets
with
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
zero
)
,
false
)
}
,
nonPositiveInteger_type
,
validate_nonPositiveInteger
);
reg
"negativeInteger"
(
restrict'
"negativeInteger"
"nonPositiveInteger"
{
no_facets
with
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
minus_one
)
,
false
)
}
,
negativeInteger_type
,
validate_negativeInteger
);
reg
"nonNegativeInteger"
(
restrict'
"nonNegativeInteger"
"integer"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
zero
)
,
false
)
}
,
nonNegativeInteger_type
,
validate_nonNegativeInteger
);
reg
"positiveInteger"
(
restrict'
"positiveInteger"
"nonNegativeInteger"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
one
)
,
false
)
}
,
positiveInteger_type
,
validate_positiveInteger
);
reg
"long"
(
restrict'
"long"
"integer"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
long_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
long_r
)
,
false
)}
,
long_type
,
validate_long
);
reg
"int"
(
restrict'
"int"
"long"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
int_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
int_r
)
,
false
)}
,
int_type
,
validate_int
);
reg
"short"
(
restrict'
"short"
"int"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
short_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
short_r
)
,
false
)}
,
short_type
,
validate_short
);
reg
"byte"
(
restrict'
"byte"
"short"
{
no_facets
with
minInclusive
=
Some
(
lazy
(
Value
.
Integer
byte_l
)
,
false
);
maxInclusive
=
Some
(
lazy
(
Value
.
Integer
byte_r
)
,
false
)}
,
byte_type
,
validate_short
);
reg
"normalizedString"
(
restrict'
"normalizedString"
"string"
{
no_facets
with
whiteSpace
=
`Replace
,
false
}
,
Builtin_defs
.
string
,
validate_normalizedString
);
reg
"token"
(
restrict'
"token"
"normalizedString"
{
no_facets
with
whiteSpace
=
`Collapse
,
false
}
,
Builtin_defs
.
string
,
validate_token
);
let
nonpos
=
restrict
"nonPositiveInteger"
integer
{
no_facets
with
maxInclusive
=
Some
(
Value
.
Integer
zero
,
false
)
}
nonPositiveInteger_type
validate_nonPositiveInteger
let
_
=
restrict
"negativeInteger"
nonpos
{
no_facets
with
maxInclusive
=
Some
(
Value
.
Integer
minus_one
,
false
)
}
negativeInteger_type
validate_negativeInteger
let
nonneg
=
restrict
"nonNegativeInteger"
integer
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
zero
,
false
)
}
nonNegativeInteger_type
validate_nonNegativeInteger
let
_
=
restrict
"positiveInteger"
nonneg
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
one
,
false
)
}
positiveInteger_type
validate_positiveInteger
let
long
=
restrict
"long"
integer
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
long_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
long_r
,
false
)}
long_type
validate_long
let
int
=
restrict
"int"
long
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
int_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
int_r
,
false
)}
int_type
validate_int
let
short
=
restrict
"short"
int
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
short_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
short_r
,
false
)}
short_type
validate_short
let
_
=
restrict
"byte"
short
{
no_facets
with
minInclusive
=
Some
(
Value
.
Integer
byte_l
,
false
);
maxInclusive
=
Some
(
Value
.
Integer
byte_r
,
false
)}
byte_type
validate_short
let
normalized_string
=
restrict
"normalizedString"
string
{
no_facets
with
whiteSpace
=
`Replace
,
false
}
Builtin_defs
.
string
validate_normalizedString
let
token
=
restrict
"token"
normalized_string
{
no_facets
with
whiteSpace
=
`Collapse
,
false
}
Builtin_defs
.
string
validate_token
(*
alias "language" "token";
alias "Name" "token";
alias "NMTOKEN" "token";
...
...
@@ -546,8 +543,8 @@ let fill () = (* fill "builtins" hashtbl *)
string_list_type, validate_token_list);
alias "IDREFS" "NMTOKENS";
alias "ENTITIES" "NMTOKENS"
*)
let
_
=
try
fill
()
with
Not_found
->
assert
false
(** {2 Printing} *)
...
...
@@ -570,7 +567,7 @@ let null_value = {
}
let
string_of_time_type
fields
=
let
fail
()
=
raise
(
Schema_builtin_e
rror
""
)
in
let
fail
()
=
raise
(
E
rror
""
)
in
let
parse_int
=
function
Value
.
Integer
i
->
i
|
_
->
fail
()
in
let
parse_timezone
v
=
let
fields
=
...
...
@@ -701,17 +698,16 @@ let string_of_time_type fields =
(** {2 API} *)
let
is_builtin
=
QTable
.
mem
builtins
let
iter_builtin
f
=
QTable
.
iter
(
fun
_
(
type_def
,
_
,
_
)
->
f
type_def
)
builtins
let
is
=
QTable
.
mem
builtins
let
iter
f
=
QTable
.
iter
f
builtins
let
lookup
name
=
QTable
.
find
builtins
name
let
get
name
=
QTable
.
find
builtins
name
let
simple_type
(
st
,_,_
)
=
st
let
cd_type
(
_
,
t
,_
)
=
t
let
validate
(
_
,_,
v
)
=
v
let
fst
(
x
,_,_
)
=
x
let
snd
(
_
,
y
,_
)
=
y
let
trd
(
_
,_,
z
)
=
z
let
of_st
=
function
|
{
st_name
=
Some
n
}
->
get
n
|
_
->
assert
false
let
get_builtin
name
=
fst
(
lookup
name
)
let
cd_type_of_builtin
name
=
snd
(
lookup
name
)
let
validate_builtin
name
=
trd
(
lookup
name
)
schema/schema_builtin.mli
View file @
30ec2f64
open
Encodings
open
Schema_types
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception
Error
of
string
type
t
exception
Schema_builtin_error
of
string
val
is
:
Ns
.
QName
.
t
->
bool
val
get
:
Ns
.
QName
.
t
->
t
val
iter
:
(
Ns
.
QName
.
t
->
t
->
unit
)
->
unit
val
of_st
:
simple_type_definition
->
t
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
:
Ns
.
QName
.
t
->
Types
.
descr
(** 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
:
Ns
.
QName
.
t
->
Utf8
.
t
->
Value
.
t
val
simple_type
:
t
->
simple_type_definition
val
cd_type
:
t
->
Types
.
t
val
validate
:
t
->
Utf8
.
t
->
Value
.
t
val
string_of_time_type
:
(
Ns
.
qname
*
Value
.
t
)
list
->
Utf8
.
t
val
any_simple_type
:
t
val
string
:
t
schema/schema_common.ml
View file @
30ec2f64
...
...
@@ -62,20 +62,19 @@ let merge_facets old_facets new_facets =
minExclusive
=
minExclusive
;
}
let
rec
facets_of_simple_type_definition
=
function
|
Primitive
_
->
no_facets
|
Derived
(
_
,
_
,
facets
,
_
)
->
facets
let
rec
facets_of_simple_type_definition
st
=
st
.
st_facets
let
rec
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
lazy
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
rec
variety_of_simple_type_definition
st
=
st
.
st_variety
(*
let get_simple_type c = match Lazy.force c with
| Simple c -> c
| AnyType -> Primitive (xsd,Utf8.mk "anySimpleType")
| _ -> assert false
*)
(*
let rec normalize_simple_type = function
| Derived (name, Restrict, new_facets, base) ->
(match normalize_simple_type (get_simple_type base) with
...
...
@@ -85,11 +84,11 @@ let rec normalize_simple_type = function
let b = lazy (Simple st) in
Derived (name,Atomic b,new_facets,b))
| st -> st
*)
let
name_of_element_declaration
elt
=
elt
.
elt_name
let
name_of_simple_type_definition
=
function
|
Primitive
name
->
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
name
|
{
st_name
=
Some
name
}
->
name
|
_
->
raise
(
Invalid_argument
"anonymous simple type definition"
)
let
name_of_complex_type_definition
=
function
|
{
ct_name
=
Some
name
}
->
name
...
...
@@ -105,9 +104,6 @@ let name_of_model_group_definition mg = mg.mg_name
let
name_of_particle
=
function
|
{
part_term
=
Elt
e
}
->
name_of_element_declaration
e
|
_
->
assert
false
let
variety_of_simple_type_definition
=
function
|
(
Primitive
name
)
as
st
->
Atomic
(
lazy
(
Simple
st
))
|
Derived
(
_
,
variety
,
_
,
_
)
->
variety
let
simple_type_of_type
=
function
|
Simple
s
->
s
|
_
->
raise
(
Invalid_argument
"simple_type_of_type"
)
...
...
@@ -117,7 +113,7 @@ let complex_type_of_type = function
let
content_type_of_type
=
function
|
AnyType
->
assert
false
|
Complex
{
ct_content
=
ct
}
->
ct
|
Simple
st
->
CT_simple
(
lazy
(
Simple
st
))
|
Simple
st
->
CT_simple
st
let
iter_types
schema
f
=
List
.
iter
f
schema
.
types
let
iter_attributes
schema
f
=
List
.
iter
f
schema
.
attributes
...
...
@@ -143,7 +139,9 @@ let rec normalize_white_space =
in
pcre_replace
~
rex
:
margins_RE
~
templ
:
(
Utf8
.
mk
"$1"
)
s'
(*
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
*)
let
anyType
=
AnyType
let
first_of_particle
p
=
p
.
part_first
...
...
@@ -172,7 +170,7 @@ let get_interval facets =
* Value.t is an integer! (no other intervals are actually supported
* by the CDuce type system)
*)
let
getint
f
=
Value
.
get_integer
(
Lazy
.
force
f
)
in
let
getint
f
=
Value
.
get_integer
f
in
let
min
=
match
facets
.
minInclusive
,
facets
.
minExclusive
with
|
Some
(
i
,
_
)
,
None
->
Some
(
getint
i
)
...
...
@@ -195,10 +193,8 @@ let get_interval facets =
let
print_simple_type
fmt
=
function
|
Primitive
name
->
Format
.
fprintf
fmt
"%a"
Ns
.
QName
.
print
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"%a'"
Ns
.
QName
.
print
name
|
Derived
(
None
,
_
,
_
,
_
)
->
Format
.
fprintf
fmt
"unnamed"
|
{
st_name
=
Some
name
}
->
Format
.
fprintf
fmt
"%a"
Ns
.
QName
.
print
name
|
_
->
Format
.
fprintf
fmt
"unnamed"
let
print_complex_type
fmt
=
function
|
{
ct_uid
=
id
;
ct_name
=
Some
name
}
->
Format
.
fprintf
fmt
"%d:%a"
id
Ns
.
QName
.
print
name
...
...
@@ -209,8 +205,7 @@ 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"
Ns
.
QName
.
print
name
print_simple_type
(
get_simple_type
t
)
Format
.
fprintf
fmt
"@@%a:%a"
Ns
.
QName
.
print
name
print_simple_type
t
let
print_element
fmt
{
elt_uid
=
id
;
elt_name
=
name
}
=
Format
.
fprintf
fmt
"E:%d:<%a>"
id
Ns
.
QName
.
print
name
let
print_attributes
fmt
=
List
.
iter
(
Format
.
fprintf
fmt
"%a"
print_attribute
)
...
...
@@ -399,3 +394,24 @@ and print_particle ppf p =
and
print_term
ppf
=
function
|
Elt
e
->
Format
.
fprintf
ppf
"E%i"
e
.
elt_uid
|
Model
m
->
print_model_group
ppf
m
let
simple_restrict
name
base
new_facets
=
{
st_name
=
name
;
st_variety
=
base
.
st_variety
;
st_facets
=
merge_facets
base
.
st_facets
new_facets
;
st_base
=
Some
base
}
let
simple_list
name
item
=
{
st_name
=
name
;
st_variety
=
List
item
;
st_facets
=
no_facets
;
st_base
=
None
}
let
simple_union
name
members
=
{
st_name
=
name
;
st_variety
=
Union
members
;
st_facets
=
no_facets
;
st_base
=
None
}
schema/schema_common.mli
View file @
30ec2f64
...
...
@@ -23,7 +23,9 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
(*
val get_simple_type: type_ref -> simple_type_definition
*)
val
name_of_element_declaration
:
element_declaration
->
Ns
.
qname
val
name_of_type_definition
:
type_definition
->
Ns
.
qname
...
...
@@ -69,8 +71,9 @@ val nullable_of_model_group: model_group -> bool
val
merge_facets
:
facets
->
facets
->
facets
(*
val normalize_simple_type: simple_type_definition -> simple_type_definition
*)
(** {2 Miscellaneous} *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
...
...
@@ -78,7 +81,6 @@ val normalize_simple_type: simple_type_definition -> simple_type_definition
types) *)
val
no_facets
:
facets
val
anySimpleType
:
simple_type_definition
val
anyType
:
type_definition
(** @return the integer interval corrisponding to boundary facets *)
...
...
@@ -96,3 +98,13 @@ val string_of_event: event -> string
val
print_model_group
:
Format
.
formatter
->
model_group
->
unit
val
print_particle
:
Format
.
formatter
->
particle
->
unit
val
simple_restrict
:
Ns
.
qname
option
->
simple_type_definition
->
facets
->
simple_type_definition
val
simple_list
:
Ns
.
qname
option
->
simple_type_definition
->
simple_type_definition
val
simple_union
:
Ns
.
qname
option
->
simple_type_definition
list
->
simple_type_definition
schema/schema_parser.ml
View file @
30ec2f64
...
...
@@ -24,6 +24,10 @@ let particle_model min max mg =
(
first_of_model_group
mg
)
(
nullable_of_model_group
mg
)
let
check_force
v
=
try
Lazy
.
force
v
with
Lazy
.
Undefined
->
failwith
"Cyclic type definition"
(* element and complex type constructors which take cares of unique id *)
let
element
,
complex
=
...
...
@@ -52,13 +56,13 @@ let split s = pcre_split ~rex:space_RE s
let
unqualify
s
=
snd
(
Ns
.
split_qname
s
)
let
hashtbl_deref
tbl
=