[r2003-11-29 11:31:26 by szach] added string_of_time_type

Original author: szach
Date: 2003-11-29 11:31:26+00:00

schema/schema_builtin.ml

@@ -81,7 +81,7 @@ 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)
+let time_kind kind = (qualify "time_kind", Value.Atom (Atoms.V.mk_ascii kind))
 
   (* TODO the constraint that at least one part should be present isn't easily
   expressible with CDuce types *)
@@ -541,6 +541,156 @@ let fill () = (* fill "builtins" hashtbl *)
 
 let _ = try fill () with Not_found -> assert false
 
+  (** {2 Printing} *)
+
+open Big_int
+
+type kind =
+  Duration | DateTime | Time | Date | GYearMonth | GYear | GMonthDay | GDay |
+  GMonth
+type timezone = bool * Intervals.V.t * Intervals.V.t
+  (* positive, hour, minute *)
+type time_value = {
+  kind: kind option; positive: bool option; year: Intervals.V.t option;
+  month: Intervals.V.t option; day: Intervals.V.t option;
+  hour: Intervals.V.t option; minute: Intervals.V.t option;
+  second: Intervals.V.t option; timezone: timezone option
+}
+let null_value = {
+  kind = None; positive = None; year = None; month = None; day = None;
+  hour = None; minute = None; second = None; timezone = None
+}
+
+let string_of_time_type fields =
+  let fail () = raise (Schema_builtin_error (Utf8.mk "")) in
+  let parse_int = function Value.Integer i -> i | _ -> fail () in
+  let parse_timezone v =
+    let fields =
+      try
+        Value.get_fields v
+      with Invalid_argument _ -> fail ()
+    in
+    let (positive, hour, minute) = (ref true, ref zero, ref zero) in
+    List.iter
+      (fun ((ns, name), value) ->
+        if ns <> Ns.empty then fail ();
+        (match Utf8.get_str name with
+        | "positive" -> positive :=  (Value.equal value Value.vtrue)
+        | "hour" -> hour := parse_int value
+        | "minute" -> minute := parse_int value
+        | _ -> fail ()))
+      fields;
+    !positive, !hour, !minute
+  in
+  let parse_time_kind = function
+    | Value.Atom a ->
+        (match Utf8.get_str (snd (Atoms.V.value a)) with
+        | "duration" -> Duration | "dateTime" -> DateTime | "time" -> Time
+        | "date" -> Date | "gYearMonth" -> GYearMonth | "gYear" -> GYear
+        | "gMonthDay" -> GMonthDay | "gDay" -> GDay | "gMonth" -> GMonth
+        | _ -> fail ())
+    | _ -> fail ()
+  in
+  let parse_positive = function
+    | v when Value.equal v Value.vfalse -> false
+    | _ -> true
+  in
+  let string_of_positive v =
+    match v.positive with Some false -> "-" | _ -> ""
+  in
+  let string_of_year v =
+    match v.year with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_month v =
+    match v.month with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_day v =
+    match v.day with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_hour v =
+    match v.hour with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_minute v =
+    match v.minute with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_second v =
+    match v.second with None -> fail () | Some i -> Intervals.V.to_string i
+  in
+  let string_of_date v =
+    sprintf "%s-%s-%s" (string_of_year v) (string_of_month v) (string_of_day v)
+  in
+  let string_of_timezone v =
+    match v.timezone with
+    | Some (positive, hour, minute) ->
+        sprintf "Z%s%s:%s" (if not positive then "-" else "")
+          (Intervals.V.to_string hour) (Intervals.V.to_string minute)
+    | None -> ""
+  in
+  let string_of_time v =
+    sprintf "%s:%s:%s" (string_of_hour v) (string_of_minute v)
+      (string_of_second v)
+  in
+  let v =
+    List.fold_left
+      (fun acc ((ns, name), value) ->
+        if ns <> Ns.empty then fail ();
+        (match Utf8.get_str name with
+        | "year" -> { acc with year = Some (parse_int value) }
+        | "month" -> { acc with month = Some (parse_int value) }
+        | "day" -> { acc with day = Some (parse_int value) }
+        | "hour" -> { acc with hour = Some (parse_int value) }
+        | "minute" -> { acc with minute = Some (parse_int value) }
+        | "second" -> { acc with second = Some (parse_int value) }
+        | "timezone" -> { acc with timezone = Some (parse_timezone value) }
+        | "time_kind" -> { acc with kind = Some (parse_time_kind value) }
+        | "positive" -> { acc with positive = Some (parse_positive value) }
+        | s -> assert false))
+      null_value fields
+  in
+  let s =
+    match v.kind with
+    | None -> fail ()
+    | Some Duration ->
+        sprintf "%sP%s%s%s%s"
+          (string_of_positive v)
+          (match v.year with Some v -> Intervals.V.to_string v ^ "Y" | _ -> "")
+          (match v.month with Some v -> Intervals.V.to_string v ^ "M" | _ -> "")
+          (match v.day with Some v -> Intervals.V.to_string v ^ "D" | _ -> "")
+          (if v.hour = None && v.minute = None && v.second = None then
+            ""
+          else
+            "T" ^
+            (match v.hour with Some v -> Intervals.V.to_string v ^ "H" | _ ->
+              "") ^
+            (match v.minute with Some v -> Intervals.V.to_string v ^ "M" | _ ->
+              "") ^
+            (match v.second with Some v -> Intervals.V.to_string v ^ "S" | _ ->
+              ""))
+    | Some DateTime ->
+        sprintf "%s%sT%s%s" (string_of_positive v) (string_of_date v)
+          (string_of_time v) (string_of_timezone v)
+    | Some Time ->
+        sprintf "%s%s%s" (string_of_positive v) (string_of_time v)
+          (string_of_timezone v)
+    | Some Date ->
+        sprintf "%s%s%s" (string_of_positive v) (string_of_date v)
+          (string_of_timezone v)
+    | Some GYearMonth ->
+        sprintf "%s%s-%s%s" (string_of_positive v) (string_of_year v)
+          (string_of_month v) (string_of_timezone v)
+    | Some GYear ->
+        sprintf "%s%s%s" (string_of_positive v) (string_of_year v)
+          (string_of_timezone v)
+    | Some GMonthDay ->
+        sprintf "--%s%s%s" (string_of_month v) (string_of_day v)
+          (string_of_timezone v)
+    | Some GDay ->
+        sprintf "---%s%s" (string_of_day v) (string_of_timezone v)
+    | Some GMonth ->
+        sprintf "--%s--%s" (string_of_month v) (string_of_timezone v)
+  in
+  Utf8.mk s
+
   (** {2 API} *)
 
 let is_builtin = Hashtbl.mem builtins

schema/schema_builtin.mli

@@ -20,3 +20,5 @@ val cd_type_of_builtin: Utf8.t -> Types.descr
    * Schema_xml.xsd_prefix *)
 val validate_builtin: Utf8.t -> Utf8.t -> Value.t
 
+val string_of_time_type: (Ns.qname * Value.t) list -> Utf8.t
+