Commit a05a8842 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-11-28 14:07:48 by szach] added time_kind field to value and types...

[r2003-11-28 14:07:48 by szach] added time_kind field to value and types created when validating time
related types

Original author: szach
Date: 2003-11-28 14:07:48+00:00
parent 2b7f8f7e
......@@ -80,9 +80,13 @@ let second_field = false, qualify "second", Builtin_defs.int
let time_type_fields = [ hour_field; minute_field; second_field ]
let date_type_fields = [ year_field; month_field; day_field ]
let time_kind_field = false, qualify "time_kind", Builtin_defs.time_kind
let time_kind kind = (qualify "time_kind", Value.string_latin1 kind)
(* TODO the constraint that at least one part should be present isn't easily
expressible with CDuce types *)
let duration_type = Types.rec_of_list' [
time_kind_field;
positive_field;
true, qualify "year", Builtin_defs.int;
true, qualify "month", Builtin_defs.int;
......@@ -96,18 +100,18 @@ let timezone_type = Types.rec_of_list' [
hour_field; minute_field
]
let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
let time_type = Types.rec_of_list' (time_type_fields @ timezone_type_fields)
let date_type = Types.rec_of_list' (positive_field :: date_type_fields)
let time_type = Types.rec_of_list' (time_kind_field :: time_type_fields @ timezone_type_fields)
let date_type = Types.rec_of_list' (time_kind_field :: positive_field :: date_type_fields)
let dateTime_type =
Types.rec_of_list' (positive_field ::
Types.rec_of_list' (time_kind_field :: positive_field ::
(date_type_fields @ time_type_fields @ timezone_type_fields))
let gYearMonth_type = Types.rec_of_list' [
positive_field; year_field; month_field
positive_field; time_kind_field; year_field; month_field
]
let gYear_type = Types.rec_of_list' [ positive_field; year_field ]
let gMonthDay_type = Types.rec_of_list' [ month_field; day_field ]
let gDay_type = Types.rec_of_list' [ day_field ]
let gMonth_type = Types.rec_of_list' [ month_field ]
let gYear_type = Types.rec_of_list' [ time_kind_field; positive_field; year_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 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
......@@ -223,6 +227,7 @@ let validate_duration =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "duration" ::
[qualify "positive", parse_sign subs.(1) ] @
(if is_empty subs.(3) then []
else [qualify "year", validate_integer subs.(3)]) @
......@@ -250,6 +255,7 @@ let validate_dateTime =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "dateTime" ::
[ qualify "positive", parse_sign subs.(1) ] @
parse_date subs.(2) @
parse_time subs.(3) @
......@@ -265,6 +271,7 @@ let validate_gYearMonth =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields = [
time_kind "gYearMonth";
qualify "positive", parse_sign subs.(1);
qualify "year", validate_integer subs.(2);
qualify "month", validate_integer subs.(3)
......@@ -280,6 +287,7 @@ let validate_gYear =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields = [
time_kind "gYear";
qualify "positive", parse_sign subs.(1);
qualify "year", validate_integer subs.(2);
] @ parse_timezone' subs.(3)
......@@ -294,6 +302,7 @@ let validate_gMonthDay =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields = [
time_kind "gMonthDay";
qualify "month", validate_integer subs.(1);
qualify "day", validate_integer subs.(2);
] @ parse_timezone' subs.(3)
......@@ -308,8 +317,9 @@ let validate_gDay =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "gDay" ::
(qualify "day", validate_integer subs.(1)) ::
(parse_timezone' subs.(2))
(parse_timezone' subs.(2))
in
Value.vrecord fields
with Schema_builtin_error _ -> abort ()
......@@ -321,8 +331,9 @@ let validate_gMonth =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "gMonth" ::
(qualify "month", validate_integer subs.(1)) ::
(parse_timezone' subs.(2))
(parse_timezone' subs.(2))
in
Value.vrecord fields
with Schema_builtin_error _ -> abort ()
......@@ -336,6 +347,7 @@ let validate_time =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "time" ::
parse_time subs.(1) @
(if is_empty subs.(2) then []
else [ qualify "timezone", Value.vrecord (parse_timezone subs.(2)) ])
......@@ -352,6 +364,7 @@ let validate_date =
let subs = try pcre_extract ~rex s with Not_found -> abort () in
try
let fields =
time_kind "date" ::
[ qualify "positive", parse_sign subs.(1) ] @
parse_date subs.(2) @
(if is_empty subs.(3) then []
......@@ -541,11 +554,6 @@ let snd (_,y,_) = y
let trd (_,_,z) = z
let get_builtin name = fst (lookup name)
let cd_type_of_builtin name =
if List.mem name unsupported then
Format.fprintf Format.err_formatter
"Warning: %s isn't properly supported and is thread as a string by CDuce@."
(Utf8.get_str name);
snd (lookup name)
let cd_type_of_builtin name = snd (lookup name)
let validate_builtin name = trd (lookup name)
open Encodings
let pos_int = Types.interval (Intervals.right (Intervals.V.mk "1"))
let non_neg_int = Types.interval (Intervals.right (Intervals.V.mk "0"))
let neg_int = Types.interval (Intervals.left (Intervals.V.mk "-1"))
......@@ -40,6 +42,12 @@ let atom = Types.atom Atoms.any
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = Sequence.star char_latin1
let time_kind =
List.fold_left (fun acc t -> Types.cup acc t) Types.empty
(List.map
(fun s -> Types.atom (Atoms.atom (Atoms.V.mk Ns.empty (Utf8.mk s))))
[ "duration"; "dateTime"; "time"; "date"; "gYearMonth"; "gYear";
"gMonthDay"; "gDay"; "gMonth" ])
open Ident
let get_label = LabelPool.mk (Ns.empty, U.mk "get")
......
......@@ -31,5 +31,7 @@ val string : Types.t
val char_latin1 : Types.t
val string_latin1 : Types.t
val time_kind: Types.t
val mk_ref: get:'a -> set:'a -> 'a Ident.label_map
val ref_type: Types.Node.t -> Types.t
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment