[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

schema/schema_builtin.ml

@@ -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)
 

types/builtin_defs.ml

+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") 

types/builtin_defs.mli

@@ -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