schema_builtin.ml 23.7 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 Error of string
let simple_type_error name = raise (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
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
120 121 122 123
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
124

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

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

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

let validate_integer s =
136 137 138 139 140
  let s = Utf8.get_str s in
  if (String.length s = 0) then simple_type_error "integer"
  else
    try Value.Integer (Intervals.V.mk s)
    with Failure _ -> simple_type_error "integer"
141 142

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

let parse_date =
  let rex = Pcre.regexp (add_limits date_RE_raw) in
  fun s ->
147
  let abort () = simple_type_error "date" in
148 149 150 151
  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) ]
152 153 154 155

let parse_time =
  let rex = Pcre.regexp (add_limits time_RE_raw) in
  fun s ->
156
  let abort () = simple_type_error "time" in
157 158 159 160
  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) ]
161 162 163 164

let parse_timezone =
  let rex = Pcre.regexp (add_limits timezone_RE_raw) in
  fun s ->
165 166 167 168 169 170 171 172 173 174
  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)]
175 176
  (* parse a timezone from a string, if it's empty return the empty list,
  otherwise return a list containing a pair <"timezone", timezone value> *)
177 178 179 180 181
let parse_timezone' s =
  if is_empty s then
    []
  else
    [ qualify "timezone", Value.vrecord (parse_timezone s) ]
182

183
let validate_string s = Value.string_utf8 s
184 185 186 187 188 189 190 191
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 =
192 193 194 195 196 197
  let integer =   
    let s = Utf8.get_str s in
    if (String.length s = 0) then simple_type_error "integer"
    else
      try Intervals.V.mk s
      with Failure _ -> simple_type_error "integer"
198 199 200 201
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
202
    simple_type_error type_name
203 204 205 206 207 208 209 210
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"
211 212 213 214 215
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"
216

217 218 219 220 221 222 223
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"
224

225
let validate_duration =
226
  let rex = pcre_regexp
227 228 229
  "^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
  in
  fun s ->
230
  let abort () = simple_type_error "duration" in
231
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
232 233
  try
    let fields =
234
      time_kind "duration" ::
235 236 237 238 239 240 241 242 243 244 245 246 247
      [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)])
248 249
    in
    Value.vrecord fields
250
  with Error _ -> abort ()
251 252 253 254 255 256 257

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 ->
258
  let abort () = simple_type_error "dateTime" in
259
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
260 261
  try
    let fields =
262
      time_kind "dateTime" ::
263
      [ qualify "positive", parse_sign subs.(1) ] @
264 265 266 267 268
      parse_date subs.(2) @
      parse_time subs.(3) @
      parse_timezone' subs.(4)
    in
    Value.vrecord fields
269
  with Error _ -> abort ()
270 271 272 273

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

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

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

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

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

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

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

let validate_hexBinary s =
381
  let s = Utf8.get_str s in
382 383
  let len = String.length s in
  if len mod 2 <> 0 then
384
    simple_type_error "hexBinary";
385 386 387 388 389 390 391 392 393
  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;
394
  validate_string (Utf8.mk res)
395

396 397 398
let validate_base64Binary s =
  let s = Utf8.get_str s in
  validate_string (Utf8.mk (Netencoding.Base64.decode s))
399 400

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

407 408
  (** {2 API backend} *)

409 410
type t = simple_type_definition * Types.t * (Utf8.t -> Value.t)

411 412
module QTable = Hashtbl.Make(Ns.QName)

413 414 415
let builtins : t QTable.t = QTable.create 50
let reg = QTable.add builtins
(*
416
let alias alias name =
417
  let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
418 419
  QTable.add builtins alias (QTable.find builtins name)
*)
420

421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
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
(*
474 475 476 477 478 479
    (* TODO following types not yet supported (see "unsupported" above) *)
  alias "decimal" "string";
  alias "float" "string";
  alias "double" "string";
  alias "NOTATION" "string";
  alias "QName" "string";
480
*)
481 482 483

  (* derived builtins *)

484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
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

(*
534 535 536 537 538 539 540 541 542
  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",
543
    string_list_type, validate_token_list);
544 545
  alias "IDREFS" "NMTOKENS";
  alias "ENTITIES" "NMTOKENS"
546
*)
547 548


549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569
  (** {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 =
570
  let fail () = raise (Error "") in
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
  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) }
652
        | s -> fail ()))
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 698
      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

699 700
  (** {2 API} *)

701 702
let is = QTable.mem builtins
let iter f = QTable.iter f builtins
703

704 705 706 707
let get name = QTable.find builtins name
let simple_type (st,_,_) = st
let cd_type (_,t,_) = t
let validate (_,_,v) = v
708

709 710 711
let of_st = function
  | { st_name = Some n } -> get n
  | _ -> assert false
712

713