schema_builtin.ml 22.3 KB
Newer Older
1
open Printf
2

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

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

12 13
(* TODO: distinguish primitive and derived types in the interface *)

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

16 17
let zero = Intervals.V.mk "0"

18 19
let xsd = Schema_xml.xsd
let add_xsd_prefix s = (xsd, Utf8.mk s)
20

21
let unsupported = [ "NOTATION"; "QName" ]
22

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

let xml_S_RE = pcre_regexp "[ \\t\\r\\n]+"
26
  (* split a string at XML recommendation "S" production boundaries *)
27 28
let split_xml_S s = pcre_split ~rex:xml_S_RE s
let norm_RE = pcre_regexp "[\\t\\r\\n]"
29 30 31 32 33 34 35 36 37 38 39

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)

40 41
let strip_parens s = Pcre.replace ~pat:"[()]" s
let add_limits s = "^" ^ s ^ "$"
42

43 44
exception Error of string
let simple_type_error name = raise (Error name)
45

46
let qualify = Ns.Label.mk_ascii
47

48 49
  (* regular expressions used to validate built-in types *)

50 51 52 53 54 55 56 57 58 59
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)?"

60 61
  (** {2 CDuce types} *)

62 63 64 65 66 67 68
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
69 70 71
  (* 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 ]
72

73
let time_kind_field = false, qualify "time_kind", Builtin_defs.time_kind
74
let time_kind kind = (qualify "time_kind", Value.Atom (Atoms.V.mk_ascii kind))
75

76 77
  (* TODO the constraint that at least one part should be present isn't easily
  expressible with CDuce types *)
78
let duration_type = Types.rec_of_list false [
79
  time_kind_field;
80
  positive_field;
81 82 83 84 85 86
  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 *)
87
]
88
let timezone_type = Types.rec_of_list false [
89
  positive_field;
90
  hour_field; minute_field
91
]
92
let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
93 94
let time_type = Types.rec_of_list false (time_kind_field :: time_type_fields @ timezone_type_fields)
let date_type = Types.rec_of_list false (time_kind_field :: positive_field :: date_type_fields)
95
let dateTime_type =
96
  Types.rec_of_list false (time_kind_field :: positive_field ::
97
    (date_type_fields @ time_type_fields @ timezone_type_fields))
98
let gYearMonth_type = Types.rec_of_list false [
99
  positive_field; time_kind_field; year_field; month_field
100
]
101 102 103 104
let gYear_type = Types.rec_of_list false [ time_kind_field; positive_field; year_field ]
let gMonthDay_type = Types.rec_of_list false [ time_kind_field; month_field; day_field ]
let gDay_type = Types.rec_of_list false [ time_kind_field; day_field ]
let gMonth_type = Types.rec_of_list false [ time_kind_field; month_field ]
105 106 107 108
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
109 110 111 112
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
113

114 115 116
let string_list_type = Sequence.star Builtin_defs.string

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

118 119 120 121 122
let parse_sign s =
  if Utf8.equal s (Utf8.mk "+") || Utf8.equal s (Utf8.mk "") then
    Value.vtrue
  else
    Value.vfalse
123 124

let validate_integer s =
125 126 127 128 129
  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"
130

131 132 133 134 135
let validate_decimal s =
  let s = Utf8.get_str s in
  try Value.float (float_of_string s)
  with Failure _ -> simple_type_error "decimal"

136
let strip_decimal_RE = Pcre.regexp "\\..*$"
137 138 139 140

let parse_date =
  let rex = Pcre.regexp (add_limits date_RE_raw) in
  fun s ->
141
  let abort () = simple_type_error "date" in
142 143 144 145
  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) ]
146 147 148 149

let parse_time =
  let rex = Pcre.regexp (add_limits time_RE_raw) in
  fun s ->
150
  let abort () = simple_type_error "time" in
151 152 153 154
  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) ]
155 156 157 158

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

177
let validate_string s = Value.string_utf8 s
178 179 180 181 182 183 184 185
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 =
186 187 188 189 190 191
  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"
192 193 194 195
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
196
    simple_type_error type_name
197

198 199 200 201 202 203 204
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"
205

206
let validate_duration =
207
  let rex = pcre_regexp
208 209 210
  "^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
  in
  fun s ->
211
  let abort () = simple_type_error "duration" in
212
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
213 214
  try
    let fields =
215
      time_kind "duration" ::
216 217 218 219 220 221 222 223 224 225 226 227 228
      [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)])
229 230
    in
    Value.vrecord fields
231
  with Error _ -> abort ()
232 233 234 235 236 237 238

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 ->
239
  let abort () = simple_type_error "dateTime" in
240
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
241 242
  try
    let fields =
243
      time_kind "dateTime" ::
244
      [ qualify "positive", parse_sign subs.(1) ] @
245 246 247 248 249
      parse_date subs.(2) @
      parse_time subs.(3) @
      parse_timezone' subs.(4)
    in
    Value.vrecord fields
250
  with Error _ -> abort ()
251 252 253 254

let validate_gYearMonth =
  let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
  fun s ->
255
    let abort () = simple_type_error "gYearMonth" in
256
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
257 258
    try
      let fields = [
259
        time_kind "gYearMonth";
260 261 262
        qualify "positive", parse_sign subs.(1);
        qualify "year", validate_integer subs.(2);
        qualify "month", validate_integer subs.(3)
263 264 265
      ] @ parse_timezone' subs.(4)
      in
      Value.vrecord fields
266
    with Error _ -> abort ()
267 268 269 270

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

let validate_gMonthDay =
  let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
  fun s ->
286
    let abort () = simple_type_error "gMonthDay" in
287
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
288 289
    try
      let fields = [
290
        time_kind "gMonthDay";
291 292
        qualify "month", validate_integer subs.(1);
        qualify "day", validate_integer subs.(2);
293 294 295
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
296
    with Error _ -> abort ()
297 298 299 300

let validate_gDay =
  let rex = Pcre.regexp (add_limits gDay_RE_raw) in
  fun s ->
301
    let abort () = simple_type_error "gDay" in
302
    let subs = try pcre_extract ~rex s with Not_found -> abort () in
303 304
    try
      let fields =
305
        time_kind "gDay" ::
306
        (qualify "day", validate_integer subs.(1)) ::
307
        (parse_timezone' subs.(2))
308 309
      in
      Value.vrecord fields
310
    with Error _ -> abort ()
311 312 313 314

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

let validate_time =
  let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
331
  let abort () = simple_type_error "time" in
332
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
333 334
  try
    let fields =
335
      time_kind "time" ::
336
      parse_time subs.(1) @
337 338
      (if is_empty subs.(2) then []
      else [ qualify "timezone", Value.vrecord (parse_timezone subs.(2)) ])
339 340
    in
    Value.vrecord fields
341
  with Error _ -> abort ()
342 343 344 345 346 347

let validate_date =
  let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
348
  let abort () = simple_type_error "date" in
349
  let subs = try pcre_extract ~rex s with Not_found -> abort () in
350 351
  try
    let fields =
352
      time_kind "date" ::
353
      [ qualify "positive", parse_sign subs.(1) ] @
354
      parse_date subs.(2) @
355 356
      (if is_empty subs.(3) then []
      else [ qualify "timezone", Value.vrecord (parse_timezone subs.(3)) ])
357 358
    in
    Value.vrecord fields
359
  with Error _ -> abort ()
360 361

let validate_hexBinary s =
362
  let s = Utf8.get_str s in
363 364
  let len = String.length s in
  if len mod 2 <> 0 then
365
    simple_type_error "hexBinary";
366 367 368 369 370 371 372 373 374
  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;
375
  validate_string (Utf8.mk res)
376

377 378 379
let validate_base64Binary s =
  let s = Utf8.get_str s in
  validate_string (Utf8.mk (Netencoding.Base64.decode s))
380 381

let validate_anyURI s =
382
  let s = Utf8.get_str s in
383
  try
384 385
    validate_string (Utf8.mk (Neturl.string_of_url (Neturl.url_of_string
      Neturl.ip_url_syntax s)))
386
  with Neturl.Malformed_URL -> simple_type_error "anyURI"
387

388 389
  (** {2 API backend} *)

390 391
type t = simple_type_definition * Types.t * (Utf8.t -> Value.t)

392 393
module QTable = Hashtbl.Make(Ns.QName)

394 395
let builtins : t QTable.t = QTable.create 50
let reg = QTable.add builtins
396

397

398 399 400 401 402 403 404
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
  
405 406 407 408 409 410 411 412
let list name (item,_,_) cd v =
  let name = add_xsd_prefix name in
  let t = simple_list (Some name) item in
  let b = (t,cd,v) in
  reg name b;
  b


413 414 415 416 417 418 419 420 421 422 423
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

424 425 426
let alias name b =
  let name = add_xsd_prefix name in
  reg name b
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

let any_simple_type = 
  primitive "anySimpleType" Builtin_defs.string validate_string
let string =
  primitive "string" Builtin_defs.string validate_string
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
458 459 460 461 462 463 464
let decimal = 
  primitive "decimal" Builtin_defs.float validate_decimal

let _ =
  alias "float" decimal;
  alias "double" decimal

465 466 467

let _ = 
  List.iter (fun n -> alias n string) unsupported
468

469 470 471 472 473 474 475 476 477 478 479 480
let int_type (name,min,max) = 
  let ival = match min,max with
    | Some min, Some max ->
	let min = Intervals.V.mk min and max = Intervals.V.mk max  in
	Intervals.bounded min max
    | None, Some max ->
	let max = Intervals.V.mk max  in
	Intervals.left max
    | Some min, None ->
	let min = Intervals.V.mk min  in
	Intervals.right min
    | None, None ->
481 482
	Intervals.any 
  in
483
  ignore (primitive name (Types.interval ival) (validate_interval ival name))
484

485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
let () =
  List.iter int_type [ 
    "integer", None, None;
    "nonPositiveInteger", None, Some "0";
    "negativeInteger", None, Some "-1";
    "long", Some "-9223372036854775808", Some "9223372036854775807";
    "int", Some "-2147483648", Some "2147483647"; 
    "short", Some "-32768", Some "32767";
    "byte", Some "-128", Some "127";
    "nonNegativeInteger", Some "0", None;
    "unsignedLong", Some "0", Some "18446744073709551615";
    "unsignedInt", Some "0", Some "4294967295";
    "unsignedShort", Some "0", Some "65535";
    "unsignedByte", Some "0", Some "255";
    "positiveInteger", Some "1", None 
  ]
    
502 503


504 505 506 507 508 509 510 511 512
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

513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528
let _ =
  alias "language" token;
  alias "Name" token;
  alias "NMTOKEN" token;
  alias "NCName" token;
  alias "ID" token;
  alias "IDREF" token;
  alias "ENTITY" token

let nmtokens =
  list "NMTOKENS" token string_list_type validate_token_list

let _ =
  alias "IDREFS" nmtokens;
  alias "ENTITIES" nmtokens

529 530


531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551
  (** {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 =
552
  let fail () = raise (Error "") in
553 554 555 556 557 558 559 560 561
  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
562 563 564
      (fun (lab, value) ->
	 let ns,name = Ns.Label.value lab in
        if ns != Ns.empty then fail ();
565 566 567 568 569 570 571 572 573
        (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
574 575 576
    | Value.Atom q ->
	let _,s = Atoms.V.value q in
        (match Utf8.get_str s with
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
        | "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
624 625 626 627
      (fun acc (lab, value) ->
	 let ns,local = Ns.Label.value lab in
         if ns != Ns.empty then fail ();
        (match Utf8.get_str local with
628 629 630 631 632 633 634 635 636
        | "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) }
637
        | s -> fail ()))
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
      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

684 685
  (** {2 API} *)

686
let xsd_any = add_xsd_prefix "anyType"
687
let is s = QTable.mem builtins s || (Ns.QName.equal s xsd_any)
688
let iter f = QTable.iter f builtins
689

690 691 692 693
let get name = QTable.find builtins name
let simple_type (st,_,_) = st
let cd_type (_,t,_) = t
let validate (_,_,v) = v
694

695 696 697
let of_st = function
  | { st_name = Some n } -> get n
  | _ -> assert false
698

699