schema_builtin.ml 25.1 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

let validate_integer s =
137
138
139
140
141
  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"
142
143

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

let fill () = (* fill "builtins" hashtbl *)
440
  let primitive name = Primitive (add_xsd_prefix name) in
441
442
443

  (* primitive builtins *)

444
445
  reg "anySimpleType"
    (primitive "anySimpleType", Builtin_defs.string, validate_string);
446
  alias "anyType" "anySimpleType";  (* TODO BUG HERE *)
447
448
  reg "string"
    (primitive "string", Builtin_defs.string, validate_string);
449
450
451
452
453
454
455
456

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

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
  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);
483
484
485

  (* derived builtins *)

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

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

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
  (** {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 =
573
  let fail () = raise (Schema_builtin_error "") in
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
  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) }
655
        | s -> fail ()))
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
699
700
701
      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

702
703
  (** {2 API} *)

704
let is_builtin = QTable.mem builtins
705
let iter_builtin f =
706
  QTable.iter (fun _ (type_def, _, _) -> f type_def) builtins
707

708
let lookup name = QTable.find builtins name
709
710
711
712
713
714

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

let get_builtin name          = fst (lookup name)
715
let cd_type_of_builtin name   = snd (lookup name)
716
let validate_builtin name     = trd (lookup name)
717