schema_builtin.ml 23.8 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 xsd = Schema_xml.xsd
let add_xsd_prefix s = (xsd, Utf8.mk s)
18

19
let unsupported = [ "NOTATION"; "QName" ]
20

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

23
24
25
26
27
28
29
30
31
32
33
34
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")

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

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)

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

53
54
exception Error of string
let simple_type_error name = raise (Error name)
55

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

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

60
61
62
63
64
65
66
67
68
69
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)?"

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

72
73
74
75
76
77
78
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
79
80
81
  (* 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 ]
82

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

86
87
88
  (* 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' [
89
  time_kind_field;
90
  positive_field;
91
92
93
94
95
96
  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 *)
97
]
98
let timezone_type = Types.rec_of_list' [
99
  positive_field;
100
  hour_field; minute_field
101
]
102
let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
103
104
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)
105
let dateTime_type =
106
  Types.rec_of_list' (time_kind_field :: positive_field ::
107
108
    (date_type_fields @ time_type_fields @ timezone_type_fields))
let gYearMonth_type = Types.rec_of_list' [
109
  positive_field; time_kind_field; year_field; month_field
110
]
111
112
113
114
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 ]
115
116
117
118
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
119
120
121
122
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
123

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

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

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

let validate_integer s =
135
136
137
138
139
  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"
140

141
142
143
144
145
let validate_decimal s =
  let s = Utf8.get_str s in
  try Value.float (float_of_string s)
  with Failure _ -> simple_type_error "decimal"

146
let strip_decimal_RE = Pcre.regexp "\\..*$"
147
148
149
150

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

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

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

187
let validate_string s = Value.string_utf8 s
188
189
190
191
192
193
194
195
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 =
196
197
198
199
200
201
  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"
202
203
204
205
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
206
    simple_type_error type_name
207
208
209
210
211
212
213
214
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"
215
216
217
218
219
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"
220

221
222
223
224
225
226
227
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"
228

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

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

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

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

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

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

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

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

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

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

400
401
402
let validate_base64Binary s =
  let s = Utf8.get_str s in
  validate_string (Utf8.mk (Netencoding.Base64.decode s))
403
404

let validate_anyURI s =
405
  let s = Utf8.get_str s in
406
  try
407
408
    validate_string (Utf8.mk (Neturl.string_of_url (Neturl.url_of_string
      Neturl.ip_url_syntax s)))
409
  with Neturl.Malformed_URL -> simple_type_error "anyURI"
410

411
412
  (** {2 API backend} *)

413
414
type t = simple_type_definition * Types.t * (Utf8.t -> Value.t)

415
416
module QTable = Hashtbl.Make(Ns.QName)

417
418
let builtins : t QTable.t = QTable.create 50
let reg = QTable.add builtins
419

420

421
422
423
424
425
426
427
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
  
428
429
430
431
432
433
434
435
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


436
437
438
439
440
441
442
443
444
445
446
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

447
448
449
let alias name b =
  let name = add_xsd_prefix name in
  reg name b
450
451
452
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
479
480
481
482

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
483
484
485
486
487
488
489
let decimal = 
  primitive "decimal" Builtin_defs.float validate_decimal

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

490
491
492

let _ = 
  List.iter (fun n -> alias n string) unsupported
493
494
495

  (* derived builtins *)

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
534
535
536
537
538
539
540
541
542
543
544
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

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
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

561
562


563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
  (** {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 =
584
  let fail () = raise (Error "") in
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
  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) }
666
        | s -> fail ()))
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
699
700
701
702
703
704
705
706
707
708
709
710
711
712
      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

713
714
  (** {2 API} *)

715
716
let is = QTable.mem builtins
let iter f = QTable.iter f builtins
717

718
719
720
721
let get name = QTable.find builtins name
let simple_type (st,_,_) = st
let cd_type (_,t,_) = t
let validate (_,_,v) = v
722

723
724
725
let of_st = function
  | { st_name = Some n } -> get n
  | _ -> assert false
726

727