schema_builtin.ml 25 KB
Newer Older
1

2
open Printf
3

4
open Encodings
5
open Schema_pcre
6
open Schema_common
7
open Schema_types
8 9 10 11 12

(* TODO dates: boundary checks (e.g. 95/26/2003) *)
(* TODO a lot of almost cut-and-paste code, expecially in gFoo types validation
*)

13 14
  (** {2 Aux/Misc stuff} *)

15 16
let xsd = Schema_xml.xsd
let add_xsd_prefix s = (xsd, Utf8.mk s)
17

18 19 20 21
let unsupported =
  List.map (fun s -> add_xsd_prefix s)
    [ "decimal"; "float"; "double"; "NOTATION"; "QName" ]

22 23
let is_empty s = Utf8.equal s (Utf8.mk "")

24 25 26 27 28 29 30 31 32 33 34 35
let zero = Intervals.V.zero
let one = (Intervals.V.succ Intervals.V.zero)
let minus_one = (Intervals.V.pred Intervals.V.zero)
let long_l = (Intervals.V.mk "-9223372036854775808")
let long_r = (Intervals.V.mk "9223372036854775807")
let int_l = (Intervals.V.mk "-2147483648")
let int_r = (Intervals.V.mk "2147483647")
let short_l = (Intervals.V.mk "-32768")
let short_r = (Intervals.V.mk "32767")
let byte_l = (Intervals.V.mk "-128")
let byte_r = (Intervals.V.mk "127")

36
let xml_S_RE = pcre_regexp "[ \\t\\r\\n]+"
37
  (* split a string at XML recommendation "S" production boundaries *)
38 39
let split_xml_S s = pcre_split ~rex:xml_S_RE s
let norm_RE = pcre_regexp "[\\t\\r\\n]"
40 41 42 43 44 45 46 47 48 49 50

let char_of_hex =
  let int_of_hex_char = function
    | '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5 | '6' -> 6
    | '7' -> 7 | '8' -> 8 | '9' -> 9 | 'a' | 'A' -> 10 | 'b' | 'B' -> 11
    | 'c' | 'C' -> 12 | 'd' | 'D' -> 13 | 'e' | 'E' -> 14 | 'f' | 'F' -> 15
    | _ -> assert false
  in
    (* most significative, least significative *)
  fun ms ls -> Char.unsafe_chr (int_of_hex_char ms * 16 + int_of_hex_char ls)

51 52
let strip_parens s = Pcre.replace ~pat:"[()]" s
let add_limits s = "^" ^ s ^ "$"
53

54 55
exception Schema_builtin_error of string
let simple_type_error name = raise (Schema_builtin_error name)
56

57
let qualify s = (Ns.empty, Encodings.Utf8.mk s)
58

59 60
  (* regular expressions used to validate built-in types *)

61 62 63 64 65 66 67 68 69 70
let timezone_RE_raw = "(Z)|(([+-])?(\\d{2}):(\\d{2}))"
let date_RE_raw = "(\\d{4,})-(\\d{2})-(\\d{2})"
let time_RE_raw = "(\\d{2}):(\\d{2}):(\\d{2})"

let gYearMonth_RE_raw = sprintf "(-)?(\\d{4,})-(\\d{2})(%s)?" timezone_RE_raw
let gYear_RE_raw = sprintf "(-)?(\\d{4,})(%s)?" timezone_RE_raw
let gMonthDay_RE_raw = sprintf "--(\\d{2})-(\\d{2})(%s)?" timezone_RE_raw
let gDay_RE_raw = sprintf "---(\\d{2})(%s)?" timezone_RE_raw
let gMonth_RE_raw = "--(\\d{2})--(%s)?"

71 72
  (** {2 CDuce types} *)

73 74 75 76 77 78 79
let positive_field = false, qualify "positive", Builtin_defs.bool
let year_field = false, qualify "year", Builtin_defs.int
let month_field = false, qualify "month", Builtin_defs.int
let day_field = false, qualify "day", Builtin_defs.int
let hour_field = false, qualify "hour", Builtin_defs.int
let minute_field = false, qualify "minute", Builtin_defs.int
let second_field = false, qualify "second", Builtin_defs.int
80 81 82
  (* TODO this should be a decimal *)
let time_type_fields = [ hour_field; minute_field; second_field ]
let date_type_fields = [ year_field; month_field; day_field ]
83

84
let time_kind_field = false, qualify "time_kind", Builtin_defs.time_kind
85
let time_kind kind = (qualify "time_kind", Value.Atom (Atoms.V.mk_ascii kind))
86

87 88 89
  (* 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' [
90
  time_kind_field;
91
  positive_field;
92 93 94 95 96 97
  true, qualify "year", Builtin_defs.int;
  true, qualify "month", Builtin_defs.int;
  true, qualify "day", Builtin_defs.int;
  true, qualify "hour", Builtin_defs.int;
  true, qualify "minute", Builtin_defs.int;
  true, qualify "second", Builtin_defs.int; (* TODO this should be a decimal *)
98
]
99
let timezone_type = Types.rec_of_list' [
100
  positive_field;
101
  hour_field; minute_field
102
]
103
let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
104 105
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)
106
let dateTime_type =
107
  Types.rec_of_list' (time_kind_field :: positive_field ::
108 109
    (date_type_fields @ time_type_fields @ timezone_type_fields))
let gYearMonth_type = Types.rec_of_list' [
110
  positive_field; time_kind_field; year_field; month_field
111
]
112 113 114 115
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 ]
116

117 118 119 120
let nonPositiveInteger_type = Builtin_defs.non_pos_int
let negativeInteger_type = Builtin_defs.neg_int
let nonNegativeInteger_type = Builtin_defs.non_neg_int
let positiveInteger_type = Builtin_defs.pos_int
121 122 123 124
let long_type = Builtin_defs.long_int
let int_type = Builtin_defs.int_int
let short_type = Builtin_defs.short_int
let byte_type = Builtin_defs.byte_int
125

126 127 128
let string_list_type = Sequence.star Builtin_defs.string

  (** {2 Validation functions (string -> Value.t)} *)
129

130 131 132 133 134
let parse_sign s =
  if Utf8.equal s (Utf8.mk "+") || Utf8.equal s (Utf8.mk "") then
    Value.vtrue
  else
    Value.vfalse
135 136 137

let validate_integer s =
  try
138
    Value.Integer (Intervals.V.mk (Utf8.get_str s))
139 140 141
  with Failure _ -> simple_type_error "integer"

let strip_decimal_RE = Pcre.regexp "\\..*$"
142 143 144 145

let parse_date =
  let rex = Pcre.regexp (add_limits date_RE_raw) in
  fun s ->
146
  let abort () = simple_type_error "date" in
147 148 149 150
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
  [ qualify "year", validate_integer subs.(1);
    qualify "month", validate_integer subs.(2);
    qualify "day", validate_integer subs.(3) ]
151 152 153 154

let parse_time =
  let rex = Pcre.regexp (add_limits time_RE_raw) in
  fun s ->
155
  let abort () = simple_type_error "time" in
156 157 158 159
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
  [ qualify "hour", validate_integer subs.(1);
    qualify "minute", validate_integer subs.(2);
    qualify "second", validate_integer subs.(3) ]
160 161 162 163

let parse_timezone =
  let rex = Pcre.regexp (add_limits timezone_RE_raw) in
  fun s ->
164 165 166 167 168 169 170 171 172 173
  let abort () = simple_type_error "timezone" in
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
  if Utf8.equal subs.(1) (Utf8.mk "Z") then
    [qualify "positive", Value.vtrue;
     qualify "hour", validate_integer (Utf8.mk "0");
     qualify "minute", validate_integer (Utf8.mk "0")]
  else
    [qualify "positive", parse_sign subs.(3);
     qualify "hour", validate_integer subs.(4);
     qualify "minute", validate_integer subs.(5)]
174 175
  (* parse a timezone from a string, if it's empty return the empty list,
  otherwise return a list containing a pair <"timezone", timezone value> *)
176 177 178 179 180
let parse_timezone' s =
  if is_empty s then
    []
  else
    [ qualify "timezone", Value.vrecord (parse_timezone s) ]
181

182
let validate_string s = Value.string_utf8 s
183 184 185 186 187 188 189 190 191 192
let validate_normalizedString s =
  validate_string (normalize_white_space `Replace s)
let validate_token s =
  validate_string (normalize_white_space `Collapse s)
let validate_token_list s =
  Value.sequence (List.map validate_token (split_xml_S s))

let validate_interval interval type_name s =
  let integer =
    try
193
      Intervals.V.mk (Utf8.get_str s)
194
    with Failure _ -> simple_type_error type_name
195 196 197 198
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
199
    simple_type_error type_name
200 201 202 203 204 205 206 207
let validate_nonPositiveInteger =
  validate_interval (Intervals.left Intervals.V.zero) "nonPositiveInteger"
let validate_negativeInteger =
  validate_interval (Intervals.left Intervals.V.minus_one) "negativeInteger"
let validate_nonNegativeInteger =
  validate_interval (Intervals.right Intervals.V.zero) "nonNegativeInteger"
let validate_positiveInteger =
  validate_interval (Intervals.right Intervals.V.one) "positiveInteger"
208 209 210 211 212
let validate_long = validate_interval (Intervals.bounded long_l long_r) "long"
let validate_int = validate_interval (Intervals.bounded int_l int_r) "int"
let validate_short =
  validate_interval (Intervals.bounded short_l short_r) "short"
let validate_byte = validate_interval (Intervals.bounded byte_l byte_r) "byte"
213

214 215 216 217 218 219 220
let validate_bool s =
  if Utf8.equal s (Utf8.mk "true") || Utf8.equal s (Utf8.mk "1") then
    Value.vtrue
  else if Utf8.equal s (Utf8.mk "false") || Utf8.equal s (Utf8.mk "0") then
    Value.vfalse
  else
    simple_type_error "boolean"
221

222
let validate_duration =
223
  let rex = pcre_regexp
224 225 226
  "^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
  in
  fun s ->
227
  let abort () = simple_type_error "duration" in
228
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
229 230
  try
    let fields =
231
      time_kind "duration" ::
232 233 234 235 236 237 238 239 240 241 242 243 244
      [qualify "positive", parse_sign subs.(1) ] @
      (if is_empty subs.(3) then []
      else [qualify "year", validate_integer subs.(3)]) @
      (if is_empty subs.(5) then []
      else [qualify "month", validate_integer subs.(5)]) @
      (if is_empty subs.(7) then []
      else [qualify "day", validate_integer subs.(7)]) @
      (if is_empty subs.(10) then []
      else [qualify "hour", validate_integer subs.(10)]) @
      (if is_empty subs.(12) then []
      else [qualify "minute", validate_integer subs.(12)]) @
      (if is_empty subs.(14) then []
      else [qualify "second", validate_integer subs.(14)])
245 246
    in
    Value.vrecord fields
247
  with Schema_builtin_error _ -> abort ()
248 249 250 251 252 253 254

let validate_dateTime =
  let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
    (strip_parens date_RE_raw) (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
255
  let abort () = simple_type_error "dateTime" in
256
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
257 258
  try
    let fields =
259
      time_kind "dateTime" ::
260
      [ qualify "positive", parse_sign subs.(1) ] @
261 262 263 264 265
      parse_date subs.(2) @
      parse_time subs.(3) @
      parse_timezone' subs.(4)
    in
    Value.vrecord fields
266
  with Schema_builtin_error _ -> abort ()
267 268 269 270

let validate_gYearMonth =
  let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
  fun s ->
271
    let abort () = simple_type_error "gYearMonth" in
272
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
273 274
    try
      let fields = [
275
        time_kind "gYearMonth";
276 277 278
        qualify "positive", parse_sign subs.(1);
        qualify "year", validate_integer subs.(2);
        qualify "month", validate_integer subs.(3)
279 280 281
      ] @ parse_timezone' subs.(4)
      in
      Value.vrecord fields
282
    with Schema_builtin_error _ -> abort ()
283 284 285 286

let validate_gYear =
  let rex = Pcre.regexp (add_limits gYear_RE_raw) in
  fun s ->
287
    let abort () = simple_type_error "gYear" in
288
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
289 290
    try
      let fields = [
291
        time_kind "gYear";
292 293
        qualify "positive", parse_sign subs.(1);
        qualify "year", validate_integer subs.(2);
294 295 296
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
297
    with Schema_builtin_error _ -> abort ()
298 299 300 301

let validate_gMonthDay =
  let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
  fun s ->
302
    let abort () = simple_type_error "gMonthDay" in
303
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
304 305
    try
      let fields = [
306
        time_kind "gMonthDay";
307 308
        qualify "month", validate_integer subs.(1);
        qualify "day", validate_integer subs.(2);
309 310 311
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
312
    with Schema_builtin_error _ -> abort ()
313 314 315 316

let validate_gDay =
  let rex = Pcre.regexp (add_limits gDay_RE_raw) in
  fun s ->
317
    let abort () = simple_type_error "gDay" in
318
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
319 320
    try
      let fields =
321
        time_kind "gDay" ::
322
        (qualify "day", validate_integer subs.(1)) ::
323
        (parse_timezone' subs.(2))
324 325
      in
      Value.vrecord fields
326
    with Schema_builtin_error _ -> abort ()
327 328 329 330

let validate_gMonth =
  let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
  fun s ->
331
    let abort () = simple_type_error "gMonth" in
332
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
333 334
    try
      let fields =
335
        time_kind "gMonth" ::
336
        (qualify "month", validate_integer subs.(1)) ::
337
        (parse_timezone' subs.(2))
338 339
      in
      Value.vrecord fields
340
    with Schema_builtin_error _ -> abort ()
341 342 343 344 345 346

let validate_time =
  let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
347
  let abort () = simple_type_error "time" in
348
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
349 350
  try
    let fields =
351
      time_kind "time" ::
352
      parse_time subs.(1) @
353 354
      (if is_empty subs.(2) then []
      else [ qualify "timezone", Value.vrecord (parse_timezone subs.(2)) ])
355 356
    in
    Value.vrecord fields
357
  with Schema_builtin_error _ -> abort ()
358 359 360 361 362 363

let validate_date =
  let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
364
  let abort () = simple_type_error "date" in
365
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
366 367
  try
    let fields =
368
      time_kind "date" ::
369
      [ qualify "positive", parse_sign subs.(1) ] @
370
      parse_date subs.(2) @
371 372
      (if is_empty subs.(3) then []
      else [ qualify "timezone", Value.vrecord (parse_timezone subs.(3)) ])
373 374
    in
    Value.vrecord fields
375
  with Schema_builtin_error _ -> abort ()
376 377

let validate_hexBinary s =
378
  let s = Utf8.get_str s in
379 380
  let len = String.length s in
  if len mod 2 <> 0 then
381
    simple_type_error "hexBinary";
382 383 384 385 386 387 388 389 390
  let res = String.create (len / 2) in
  let rec aux idx =
    if idx < len then begin
      String.unsafe_set res (idx / 2)
        (char_of_hex (String.unsafe_get s idx) (String.unsafe_get s (idx + 1)));
      aux (idx + 2)
    end
  in
  aux 0;
391
  validate_string (Utf8.mk res)
392

393 394 395
let validate_base64Binary s =
  let s = Utf8.get_str s in
  validate_string (Utf8.mk (Netencoding.Base64.decode s))
396 397

let validate_anyURI s =
398
  let s = Utf8.get_str s in
399
  try
400 401
    validate_string (Utf8.mk (Neturl.string_of_url (Neturl.url_of_string
      Neturl.ip_url_syntax s)))
402
  with Neturl.Malformed_URL -> simple_type_error "anyURI"
403

404 405
  (** {2 API backend} *)

406 407 408 409
module QTable = Hashtbl.Make(Ns.QName)

let builtins = QTable.create 50
let reg name spec = QTable.add builtins (add_xsd_prefix name) spec
410
let alias alias name =
411
  let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
412 413
  QTable.add builtins alias
    (let (st_def, descr, validator) = QTable.find builtins name in
414 415 416 417 418 419 420 421
    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 =
422
  let (name, basename) = (add_xsd_prefix name, add_xsd_prefix basename) in
423
  let (base, _, _) = QTable.find builtins basename in
424 425 426 427
  let variety = variety_of_simple_type_definition base in
  let facets =
    merge_facets (facets_of_simple_type_definition base) new_facets
  in
428
  Derived (Some name, variety, facets, lazy (Simple base))
429
let list' name itemname =
430
  let (name, itemname) = (add_xsd_prefix name, add_xsd_prefix itemname) in
431
  let (base, _, _) = QTable.find builtins itemname in
432
  let base = lazy (Simple base) in
433 434 435
  Derived (Some name, List base, no_facets, base)

let fill () = (* fill "builtins" hashtbl *)
436
  let primitive name = Primitive (add_xsd_prefix name) in
437 438 439

  (* primitive builtins *)

440 441
  reg "anySimpleType"
    (primitive "anySimpleType", Builtin_defs.string, validate_string);
442
  alias "anyType" "anySimpleType";  (* TODO BUG HERE *)
443 444
  reg "string"
    (primitive "string", Builtin_defs.string, validate_string);
445 446 447 448 449 450 451 452

    (* TODO following types not yet supported (see "unsupported" above) *)
  alias "decimal" "string";
  alias "float" "string";
  alias "double" "string";
  alias "NOTATION" "string";
  alias "QName" "string";

453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
  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);
479 480 481

  (* derived builtins *)

482 483
  reg "integer"
    (restrict' "integer" "decimal" no_facets, (* fake restriction *)
484
    Builtin_defs.int, validate_integer);
485 486
  reg "nonPositiveInteger"
    (restrict' "nonPositiveInteger" "integer"
487
      { no_facets with maxInclusive = Some (lazy (Value.Integer zero), false) },
488
    nonPositiveInteger_type, validate_nonPositiveInteger);
489 490
  reg "negativeInteger"
    (restrict' "negativeInteger" "nonPositiveInteger"
491
      { no_facets with maxInclusive = Some (lazy (Value.Integer minus_one), false) },
492
    negativeInteger_type, validate_negativeInteger);
493 494
  reg "nonNegativeInteger"
    (restrict' "nonNegativeInteger" "integer"
495
      { no_facets with minInclusive = Some (lazy (Value.Integer zero), false) },
496
    nonNegativeInteger_type, validate_nonNegativeInteger);
497 498
  reg "positiveInteger"
    (restrict' "positiveInteger" "nonNegativeInteger"
499
      { no_facets with minInclusive = Some (lazy (Value.Integer one), false) },
500
    positiveInteger_type, validate_positiveInteger);
501 502
  reg "long"
    (restrict' "long" "integer"
503
      { no_facets with
504 505
          minInclusive = Some (lazy (Value.Integer long_l), false);
          maxInclusive = Some (lazy (Value.Integer long_r), false)},
506
    long_type, validate_long);
507 508
  reg "int"
    (restrict' "int" "long"
509
      { no_facets with
510 511
          minInclusive = Some (lazy (Value.Integer int_l), false);
          maxInclusive = Some (lazy (Value.Integer int_r), false)},
512
    int_type, validate_int);
513 514
  reg "short"
    (restrict' "short" "int"
515
      { no_facets with
516 517
          minInclusive = Some (lazy (Value.Integer short_l), false);
          maxInclusive = Some (lazy (Value.Integer short_r), false)},
518
    short_type, validate_short);
519 520
  reg "byte"
    (restrict' "byte" "short"
521
      { no_facets with
522 523
          minInclusive = Some (lazy (Value.Integer byte_l), false);
          maxInclusive = Some (lazy (Value.Integer byte_r), false)},
524
    byte_type, validate_short);
525 526
  reg "normalizedString"
    (restrict' "normalizedString" "string"
527 528
      { no_facets with whiteSpace = `Replace, false },
    Builtin_defs.string, validate_normalizedString);
529 530
  reg "token"
    (restrict' "token" "normalizedString"
531 532
      { no_facets with whiteSpace = `Collapse, false },
    Builtin_defs.string, validate_token);
533 534 535 536 537 538 539 540 541
  alias "language" "token";
  alias "Name" "token";
  alias "NMTOKEN" "token";
  alias "NCName" "token";
  alias "ID" "token";
  alias "IDREF" "token";
  alias "ENTITY" "token";
  reg "NMTOKENS"
    (list' "NMTOKENS" "token",
542
    string_list_type, validate_token_list);
543 544
  alias "IDREFS" "NMTOKENS";
  alias "ENTITIES" "NMTOKENS"
545 546 547

let _ = try fill () with Not_found -> assert false

548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568
  (** {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 =
569
  let fail () = raise (Schema_builtin_error "") in
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
  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

698 699
  (** {2 API} *)

700
let is_builtin = QTable.mem builtins
701
let iter_builtin f =
702
  QTable.iter (fun _ (type_def, _, _) -> f type_def) builtins
703

704
let lookup name = QTable.find builtins name
705 706 707 708 709 710

let fst (x,_,_) = x
let snd (_,y,_) = y
let trd (_,_,z) = z

let get_builtin name          = fst (lookup name)
711
let cd_type_of_builtin name   = snd (lookup name)
712
let validate_builtin name     = trd (lookup name)
713