Commit 30ec2f64 authored by Pietro Abate's avatar 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
...@@ -21,7 +21,7 @@ let rec schema_value ?(recurs=true) ~wds v = ...@@ -21,7 +21,7 @@ let rec schema_value ?(recurs=true) ~wds v =
| Record _ as v -> | Record _ as v ->
(try (try
wds (Schema_builtin.string_of_time_type (Value.get_fields v)) wds (Schema_builtin.string_of_time_type (Value.get_fields v))
with Schema_builtin.Schema_builtin_error _ -> raise exn_print_xml) with Schema_builtin.Error _ -> raise exn_print_xml)
| Integer i -> wds (U.mk (Intervals.V.to_string i)) | 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.vtrue -> wds true_literal
| v when Value.equal v Value.vfalse -> wds false_literal | v when Value.equal v Value.vfalse -> wds false_literal
......
...@@ -51,8 +51,8 @@ let char_of_hex = ...@@ -51,8 +51,8 @@ let char_of_hex =
let strip_parens s = Pcre.replace ~pat:"[()]" s let strip_parens s = Pcre.replace ~pat:"[()]" s
let add_limits s = "^" ^ s ^ "$" let add_limits s = "^" ^ s ^ "$"
exception Schema_builtin_error of string exception Error of string
let simple_type_error name = raise (Schema_builtin_error name) let simple_type_error name = raise (Error name)
let qualify s = (Ns.empty, Encodings.Utf8.mk s) 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 ...@@ -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 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 gDay_type = Types.rec_of_list' [ time_kind_field; day_field ]
let gMonth_type = Types.rec_of_list' [ time_kind_field; month_field ] let gMonth_type = Types.rec_of_list' [ time_kind_field; month_field ]
let nonPositiveInteger_type = Builtin_defs.non_pos_int let nonPositiveInteger_type = Builtin_defs.non_pos_int
let negativeInteger_type = Builtin_defs.neg_int let negativeInteger_type = Builtin_defs.neg_int
let nonNegativeInteger_type = Builtin_defs.non_neg_int let nonNegativeInteger_type = Builtin_defs.non_neg_int
...@@ -248,7 +247,7 @@ let validate_duration = ...@@ -248,7 +247,7 @@ let validate_duration =
else [qualify "second", validate_integer subs.(14)]) else [qualify "second", validate_integer subs.(14)])
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_dateTime = let validate_dateTime =
let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$" let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
...@@ -267,7 +266,7 @@ let validate_dateTime = ...@@ -267,7 +266,7 @@ let validate_dateTime =
parse_timezone' subs.(4) parse_timezone' subs.(4)
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_gYearMonth = let validate_gYearMonth =
let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
...@@ -283,7 +282,7 @@ let validate_gYearMonth = ...@@ -283,7 +282,7 @@ let validate_gYearMonth =
] @ parse_timezone' subs.(4) ] @ parse_timezone' subs.(4)
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_gYear = let validate_gYear =
let rex = Pcre.regexp (add_limits gYear_RE_raw) in let rex = Pcre.regexp (add_limits gYear_RE_raw) in
...@@ -298,7 +297,7 @@ let validate_gYear = ...@@ -298,7 +297,7 @@ let validate_gYear =
] @ parse_timezone' subs.(3) ] @ parse_timezone' subs.(3)
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_gMonthDay = let validate_gMonthDay =
let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
...@@ -313,7 +312,7 @@ let validate_gMonthDay = ...@@ -313,7 +312,7 @@ let validate_gMonthDay =
] @ parse_timezone' subs.(3) ] @ parse_timezone' subs.(3)
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_gDay = let validate_gDay =
let rex = Pcre.regexp (add_limits gDay_RE_raw) in let rex = Pcre.regexp (add_limits gDay_RE_raw) in
...@@ -327,7 +326,7 @@ let validate_gDay = ...@@ -327,7 +326,7 @@ let validate_gDay =
(parse_timezone' subs.(2)) (parse_timezone' subs.(2))
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_gMonth = let validate_gMonth =
let rex = Pcre.regexp (add_limits gMonth_RE_raw) in let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
...@@ -341,7 +340,7 @@ let validate_gMonth = ...@@ -341,7 +340,7 @@ let validate_gMonth =
(parse_timezone' subs.(2)) (parse_timezone' subs.(2))
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_time = let validate_time =
let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw) let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
...@@ -358,7 +357,7 @@ let validate_time = ...@@ -358,7 +357,7 @@ let validate_time =
else [ qualify "timezone", Value.vrecord (parse_timezone subs.(2)) ]) else [ qualify "timezone", Value.vrecord (parse_timezone subs.(2)) ])
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_date = let validate_date =
let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw) let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
...@@ -376,7 +375,7 @@ let validate_date = ...@@ -376,7 +375,7 @@ let validate_date =
else [ qualify "timezone", Value.vrecord (parse_timezone subs.(3)) ]) else [ qualify "timezone", Value.vrecord (parse_timezone subs.(3)) ])
in in
Value.vrecord fields Value.vrecord fields
with Schema_builtin_error _ -> abort () with Error _ -> abort ()
let validate_hexBinary s = let validate_hexBinary s =
let s = Utf8.get_str s in let s = Utf8.get_str s in
...@@ -407,133 +406,131 @@ let validate_anyURI s = ...@@ -407,133 +406,131 @@ let validate_anyURI s =
(** {2 API backend} *) (** {2 API backend} *)
type t = simple_type_definition * Types.t * (Utf8.t -> Value.t)
module QTable = Hashtbl.Make(Ns.QName) module QTable = Hashtbl.Make(Ns.QName)
let builtins = QTable.create 50 let builtins : t QTable.t = QTable.create 50
let reg name spec = QTable.add builtins (add_xsd_prefix name) spec let reg = QTable.add builtins
(*
let alias alias name = let alias alias name =
let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
QTable.add builtins alias QTable.add builtins alias (QTable.find builtins name)
(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);
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) *) (* TODO following types not yet supported (see "unsupported" above) *)
alias "decimal" "string"; alias "decimal" "string";
alias "float" "string"; alias "float" "string";
alias "double" "string"; alias "double" "string";
alias "NOTATION" "string"; alias "NOTATION" "string";
alias "QName" "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 *) (* derived builtins *)
reg "integer" let nonpos =
(restrict' "integer" "decimal" no_facets, (* fake restriction *) restrict "nonPositiveInteger" integer
Builtin_defs.int, validate_integer); { no_facets with maxInclusive = Some (Value.Integer zero, false) }
reg "nonPositiveInteger" nonPositiveInteger_type validate_nonPositiveInteger
(restrict' "nonPositiveInteger" "integer" let _ =
{ no_facets with maxInclusive = Some (lazy (Value.Integer zero), false) }, restrict "negativeInteger" nonpos
nonPositiveInteger_type, validate_nonPositiveInteger); { no_facets with maxInclusive = Some (Value.Integer minus_one, false) }
reg "negativeInteger" negativeInteger_type validate_negativeInteger
(restrict' "negativeInteger" "nonPositiveInteger" let nonneg =
{ no_facets with maxInclusive = Some (lazy (Value.Integer minus_one), false) }, restrict "nonNegativeInteger" integer
negativeInteger_type, validate_negativeInteger); { no_facets with minInclusive = Some (Value.Integer zero, false) }
reg "nonNegativeInteger" nonNegativeInteger_type validate_nonNegativeInteger
(restrict' "nonNegativeInteger" "integer" let _ =
{ no_facets with minInclusive = Some (lazy (Value.Integer zero), false) }, restrict "positiveInteger" nonneg
nonNegativeInteger_type, validate_nonNegativeInteger); { no_facets with minInclusive = Some (Value.Integer one, false) }
reg "positiveInteger" positiveInteger_type validate_positiveInteger
(restrict' "positiveInteger" "nonNegativeInteger" let long =
{ no_facets with minInclusive = Some (lazy (Value.Integer one), false) }, restrict "long" integer
positiveInteger_type, validate_positiveInteger); { no_facets with
reg "long" minInclusive = Some (Value.Integer long_l, false);
(restrict' "long" "integer" maxInclusive = Some (Value.Integer long_r, false)}
{ no_facets with long_type validate_long
minInclusive = Some (lazy (Value.Integer long_l), false); let int =
maxInclusive = Some (lazy (Value.Integer long_r), false)}, restrict "int" long
long_type, validate_long); { no_facets with
reg "int" minInclusive = Some (Value.Integer int_l, false);
(restrict' "int" "long" maxInclusive = Some (Value.Integer int_r, false)}
{ no_facets with int_type validate_int
minInclusive = Some (lazy (Value.Integer int_l), false); let short =
maxInclusive = Some (lazy (Value.Integer int_r), false)}, restrict "short" int
int_type, validate_int); { no_facets with
reg "short" minInclusive = Some (Value.Integer short_l, false);
(restrict' "short" "int" maxInclusive = Some (Value.Integer short_r, false)}
{ no_facets with short_type validate_short
minInclusive = Some (lazy (Value.Integer short_l), false); let _ =
maxInclusive = Some (lazy (Value.Integer short_r), false)}, restrict "byte" short
short_type, validate_short); { no_facets with
reg "byte" minInclusive = Some (Value.Integer byte_l, false);
(restrict' "byte" "short" maxInclusive = Some (Value.Integer byte_r, false)}
{ no_facets with byte_type validate_short
minInclusive = Some (lazy (Value.Integer byte_l), false); let normalized_string =
maxInclusive = Some (lazy (Value.Integer byte_r), false)}, restrict "normalizedString" string
byte_type, validate_short); { no_facets with whiteSpace = `Replace, false }
reg "normalizedString" Builtin_defs.string validate_normalizedString
(restrict' "normalizedString" "string" let token =
{ no_facets with whiteSpace = `Replace, false }, restrict "token" normalized_string
Builtin_defs.string, validate_normalizedString); { no_facets with whiteSpace = `Collapse, false }
reg "token" Builtin_defs.string validate_token
(restrict' "token" "normalizedString"
{ no_facets with whiteSpace = `Collapse, false }, (*
Builtin_defs.string, validate_token);
alias "language" "token"; alias "language" "token";
alias "Name" "token"; alias "Name" "token";
alias "NMTOKEN" "token"; alias "NMTOKEN" "token";
...@@ -546,8 +543,8 @@ let fill () = (* fill "builtins" hashtbl *) ...@@ -546,8 +543,8 @@ let fill () = (* fill "builtins" hashtbl *)
string_list_type, validate_token_list); string_list_type, validate_token_list);
alias "IDREFS" "NMTOKENS"; alias "IDREFS" "NMTOKENS";
alias "ENTITIES" "NMTOKENS" alias "ENTITIES" "NMTOKENS"
*)
let _ = try fill () with Not_found -> assert false
(** {2 Printing} *) (** {2 Printing} *)
...@@ -570,7 +567,7 @@ let null_value = { ...@@ -570,7 +567,7 @@ let null_value = {
} }
let string_of_time_type fields = let string_of_time_type fields =
let fail () = raise (Schema_builtin_error "") in let fail () = raise (Error "") in
let parse_int = function Value.Integer i -> i | _ -> fail () in let parse_int = function Value.Integer i -> i | _ -> fail () in
let parse_timezone v = let parse_timezone v =
let fields = let fields =
...@@ -701,17 +698,16 @@ let string_of_time_type fields = ...@@ -701,17 +698,16 @@ let string_of_time_type fields =
(** {2 API} *) (** {2 API} *)
let is_builtin = QTable.mem builtins let is = QTable.mem builtins
let iter_builtin f = let iter f = QTable.iter f builtins
QTable.iter (fun _ (type_def, _, _) -> f type_def) 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 of_st = function
let snd (_,y,_) = y | { st_name = Some n } -> get n
let trd (_,_,z) = z | _ -> 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)
open Encodings open Encodings
open Schema_types
(** all schema simple type names used in this API are prefixed with exception Error of string
* Schema_xml.xsd_prefix *) 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 simple_type: t -> simple_type_definition
val get_builtin: Ns.QName.t -> Schema_types.simple_type_definition val cd_type: t -> Types.t
val iter_builtin: (Schema_types.simple_type_definition -> unit) -> unit val validate: t -> Utf8.t -> Value.t
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 string_of_time_type: (Ns.qname * Value.t) list -> Utf8.t val string_of_time_type: (Ns.qname * Value.t) list -> Utf8.t
val any_simple_type: t
val string: t
...@@ -62,20 +62,19 @@ let merge_facets old_facets new_facets = ...@@ -62,20 +62,19 @@ let merge_facets old_facets new_facets =
minExclusive = minExclusive; minExclusive = minExclusive;
} }
let rec facets_of_simple_type_definition = function let rec facets_of_simple_type_definition st = st.st_facets
| Primitive _ -> no_facets
| Derived (_, _, facets, _) -> facets
let rec variety_of_simple_type_definition = function let rec variety_of_simple_type_definition st = st.st_variety
| (Primitive name) as st -> Atomic (lazy (Simple st))
| Derived (_, variety, _, _) -> variety
(*
let get_simple_type c = match Lazy.force c with let get_simple_type c = match Lazy.force c with
| Simple c -> c | Simple c -> c
| AnyType -> Primitive (xsd,Utf8.mk "anySimpleType") | AnyType -> Primitive (xsd,Utf8.mk "anySimpleType")
| _ -> assert false | _ -> assert false
*)
(*
let rec normalize_simple_type = function let rec normalize_simple_type = function
| Derived (name, Restrict, new_facets, base) -> | Derived (name, Restrict, new_facets, base) ->
(match normalize_simple_type (get_simple_type base) with (match normalize_simple_type (get_simple_type base) with
...@@ -85,11 +84,11 @@ let rec normalize_simple_type = function ...@@ -85,11 +84,11 @@ let rec normalize_simple_type = function
let b = lazy (Simple st) in let b = lazy (Simple st) in
Derived (name,Atomic b,new_facets,b)) Derived (name,Atomic b,new_facets,b))
| st -> st | st -> st
*)
let name_of_element_declaration elt = elt.elt_name let name_of_element_declaration elt = elt.elt_name
let name_of_simple_type_definition = function let name_of_simple_type_definition = function
| Primitive name -> name | { st_name = Some name } -> name
| Derived (Some name, _, _, _) -> name
| _ -> raise (Invalid_argument "anonymous simple type definition") | _ -> raise (Invalid_argument "anonymous simple type definition")
let name_of_complex_type_definition = function let name_of_complex_type_definition = function
| { ct_name = Some name } -> name | { ct_name = Some name } -> name
...@@ -105,9 +104,6 @@ let name_of_model_group_definition mg = mg.mg_name ...@@ -105,9 +104,6 @@ let name_of_model_group_definition mg = mg.mg_name
let name_of_particle = function let name_of_particle = function
| { part_term = Elt e } -> name_of_element_declaration e | { part_term = Elt e } -> name_of_element_declaration e
| _ -> assert false | _ -> 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 let simple_type_of_type = function
| Simple s -> s | Simple s -> s
| _ -> raise (Invalid_argument "simple_type_of_type") | _ -> raise (Invalid_argument "simple_type_of_type")
...@@ -117,7 +113,7 @@ let complex_type_of_type = function ...@@ -117,7 +113,7 @@ let complex_type_of_type = function
let content_type_of_type = function let content_type_of_type = function
| AnyType -> assert false | AnyType -> assert false
| Complex { ct_content = ct } -> ct | 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_types schema f = List.iter f schema.types
let iter_attributes schema f = List.iter f schema.attributes let iter_attributes schema f = List.iter f schema.attributes
...@@ -143,7 +139,9 @@ let rec normalize_white_space = ...@@ -143,7 +139,9 @@ let rec normalize_white_space =
in in