Skip to content

GitLab

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
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_error _ -> raise exn_print_xml)
with Schema_builtin.Error _ -> 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_error of string
let simple_type_error name = raise (Schema_builtin_error name)
exception Error of string
let simple_type_error name = raise (Error 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error _ -> abort ()
with Error _ -> 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_error "") in
let fail () = raise (Error "") 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 =
QTable.fold (fun _ v acc -> (Lazy.force v) :: acc) tbl []