viewcvs.cgi/schema/schema_builtin.ml


open Printf

open Schema_types
open Schema_common

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

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

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")

let regexp' s = Pcre.regexp ~flags:[`UTF8] s
let xml_S_RE = regexp' "[ \\t\\r\\n]+"
  (* split a string at XML recommendation "S" production boundaries *)
let split_xml_S s = Pcre.split ~rex:xml_S_RE s
let norm_RE = regexp' "[\\t\\r\\n]"

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)

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

exception Schema_builtin_error of string
let simple_type_error name =
  raise (Schema_builtin_error (Schema_xml.xsd_prefix ^ name))

let qualify s = (Schema_xml.xsd_namespace, Encodings.Utf8.mk s)

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

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)?"

  (** {2 CDuce types} *)

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
  (* 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 ]

  (* 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' [
  positive_field;
  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 *)
]
let timezone_type = Types.rec_of_list' [
  positive_field;
  hour_field; minute_field
]
let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
let time_type = Types.rec_of_list' (time_type_fields @ timezone_type_fields)
let date_type = Types.rec_of_list' (positive_field :: date_type_fields)
let dateTime_type =
  Types.rec_of_list' (positive_field ::
    (date_type_fields @ time_type_fields @ timezone_type_fields))
let gYearMonth_type = Types.rec_of_list' [
  positive_field; year_field; month_field
]
let gYear_type = Types.rec_of_list' [ positive_field; year_field ]
let gMonthDay_type = Types.rec_of_list' [ month_field; day_field ]
let gDay_type = Types.rec_of_list' [ day_field ]
let gMonth_type = Types.rec_of_list' [ month_field ]

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
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

let string_list_type = Sequence.star Builtin_defs.string

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

let parse_sign = function "+" | "" -> Value.vtrue | _ -> Value.vfalse

let validate_integer s =
  try
    Value.Integer (Intervals.V.mk s)
  with Failure _ -> simple_type_error "integer"

let strip_decimal_RE = Pcre.regexp "\\..*$"
let validate_decimal s = validate_integer (Pcre.replace ~rex:strip_decimal_RE s)

let parse_date =
  let rex = Pcre.regexp (add_limits date_RE_raw) in
  fun s ->
  let abort () = simple_type_error "date" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  [ "year", validate_integer subs.(1);
  "month", validate_integer subs.(2);
  "day", validate_integer subs.(3) ]

let parse_time =
  let rex = Pcre.regexp (add_limits time_RE_raw) in
  fun s ->
  let abort () = simple_type_error "time" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  [ "hour", validate_integer subs.(1);
  "minute", validate_integer subs.(2);
  "second", validate_integer subs.(3) ]

let parse_timezone =
  let rex = Pcre.regexp (add_limits timezone_RE_raw) in
  fun s ->
  let abort () = raise (Schema_builtin_error "timezone") in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  match subs.(1) with
  | "Z" ->
      ["positive", Value.vtrue;
      "hour", validate_integer "0";
      "minute", validate_integer "0"]
  | _ ->
      ["positive", parse_sign subs.(3);
      "hour", validate_integer subs.(4);

      "minute", validate_integer subs.(5)]
  (* parse a timezone from a string, if it's empty return the empty list,
  otherwise return a list containing a pair <"timezone", timezone value> *)
let parse_timezone' = function
  | "" -> []
  | v -> [ "timezone", Value.vrecord (parse_timezone v) ]

let validate_string s = Value.string_utf8 (Encodings.Utf8.mk s)
let validate_normalizedString s =
  validate_string (normalize_white_space `Replace s)
let validate_token s =
  validate_string (normalize_white_space `Collapse s)
let validate_token_list s =
  Value.sequence (List.map validate_token (split_xml_S s))

let validate_interval interval type_name s =
  let integer =
    try
      Intervals.V.mk s
    with Failure _ -> simple_type_error type_name
  in
  if Intervals.contains integer interval then
    Value.Integer integer
  else
    simple_type_error type_name
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"
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"

let validate_bool = function
  | "true" | "1" -> Value.vtrue
  | "false" | "0" -> Value.vfalse
  | v -> simple_type_error "boolean"

let validate_duration =
  let rex = Pcre.regexp
  "^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
  in
  fun s ->
  let abort () = simple_type_error "duration" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      ["positive", parse_sign subs.(1) ]                                @
      (match subs.(3) with "" -> [] | v -> ["year", validate_integer v])    @
      (match subs.(5) with "" -> [] | v -> ["month", validate_integer v])   @
      (match subs.(7) with "" -> [] | v -> ["day", validate_integer v])     @
      (match subs.(10) with "" -> [] | v -> ["hour", validate_integer v])   @
      (match subs.(12) with "" -> [] | v -> ["minute", validate_integer v]) @
      (match subs.(14) with "" -> [] | v -> ["second", validate_integer v])
    in
    Value.vrecord fields
  with Schema_builtin_error _ -> abort ()

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 ->
  let abort () = simple_type_error "dateTime" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      [ "positive", parse_sign subs.(1) ] @
      parse_date subs.(2) @
      parse_time subs.(3) @
      parse_timezone' subs.(4)
    in
    Value.vrecord fields
  with Schema_builtin_error _ -> abort ()

let validate_gYearMonth =
  let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
  fun s ->
    let abort () = simple_type_error "gYearMonth" in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "positive", parse_sign subs.(1);
        "year", validate_integer subs.(2);
        "month", validate_integer subs.(3)
      ] @ parse_timezone' subs.(4)
      in
      Value.vrecord fields
    with Schema_builtin_error _ -> abort ()

let validate_gYear =
  let rex = Pcre.regexp (add_limits gYear_RE_raw) in
  fun s ->
    let abort () = simple_type_error "gYear" in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "positive", parse_sign subs.(1);
        "year", validate_integer subs.(2);
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
    with Schema_builtin_error _ -> abort ()

let validate_gMonthDay =
  let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
  fun s ->
    let abort () = simple_type_error "gMonthDay" in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields = [
        "month", validate_integer subs.(1);
        "day", validate_integer subs.(2);
      ] @ parse_timezone' subs.(3)
      in
      Value.vrecord fields
    with Schema_builtin_error _ -> abort ()

let validate_gDay =
  let rex = Pcre.regexp (add_limits gDay_RE_raw) in
  fun s ->
    let abort () = simple_type_error "gDay" in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields =
        ("day", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
      in
      Value.vrecord fields
    with Schema_builtin_error _ -> abort ()

let validate_gMonth =
  let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
  fun s ->
    let abort () = simple_type_error "gMonth" in
    let subs = try Pcre.extract ~rex s with Not_found -> abort () in
    try
      let fields =
        ("month", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
      in
      Value.vrecord fields
    with Schema_builtin_error _ -> abort ()

let validate_time =
  let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
  let abort () = simple_type_error "time" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      parse_time subs.(1) @
      (match subs.(2) with
      | "" -> []
      | v -> [ "timezone", Value.vrecord (parse_timezone v) ])
    in
    Value.vrecord fields
  with Schema_builtin_error _ -> abort ()

let validate_date =
  let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
    (strip_parens timezone_RE_raw))
  in
  fun s ->
  let abort () = simple_type_error "date" in
  let subs = try Pcre.extract ~rex s with Not_found -> abort () in
  try
    let fields =
      [ "positive", parse_sign subs.(1) ] @
      parse_date subs.(2) @
      (match subs.(3) with
      | "" -> []
      | v -> [ "timezone", Value.vrecord (parse_timezone v) ])
    in
    Value.vrecord fields
  with Schema_builtin_error _ -> abort ()

let validate_hexBinary s =
  let len = String.length s in
  if len mod 2 <> 0 then
    simple_type_error "hexBinary";
  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;
  validate_string res

let validate_base64Binary s = validate_string (Netencoding.Base64.decode s)

let validate_anyURI s =
  try
    validate_string (Neturl.string_of_url (Neturl.url_of_string
      Neturl.ip_url_syntax s))
  with Neturl.Malformed_URL -> simple_type_error "anyURI"

  (** {2 API backend} *)

let builtins = Hashtbl.create 50
let reg name spec = Hashtbl.add builtins name spec
let alias alias name =
  Hashtbl.add builtins alias
    (let (st_def, descr, validator) = Hashtbl.find builtins name in
    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 =
  let (base, _, _) = Hashtbl.find builtins basename in
  let variety = variety_of_simple_type_definition base in
  let facets =
    merge_facets (facets_of_simple_type_definition base) new_facets
  in
  Derived (Some name, variety, facets, base)
let list' name itemname =
  let (base, _, _) = Hashtbl.find builtins itemname in
  Derived (Some name, List base, no_facets, base)

let fill () = (* fill "builtins" hashtbl *)

  (* TODO missing built-in simple types: xsd:float, xsd:double, xsd:QName,
   * xsd:NOTATION, xsd:decimal *)

  (* primitive builtins *)

  reg "xsd:anySimpleType"
    (Primitive "xsd:anySimpleType", Builtin_defs.string, validate_string);
  alias "xsd:anyType" "xsd:anySimpleType";
  reg "xsd:string"
    (Primitive "xsd:string", Builtin_defs.string, validate_string);
  reg "xsd:decimal"
    (* collapsed in CDuce to an integer, since CDuce has no decimal numbers *)
    (Primitive "xsd:decimal", Builtin_defs.int, validate_decimal);
  reg "xsd:boolean"
    (Primitive "xsd:boolean", Builtin_defs.bool, validate_bool);
  reg "xsd:hexBinary"
    (Primitive "xsd:hexBinary", Builtin_defs.string, validate_hexBinary);
  reg "xsd:base64Binary"
    (Primitive "xsd:base64Binary", Builtin_defs.string, validate_base64Binary);
  reg "xsd:anyURI"
    (Primitive "xsd:anyURI", Builtin_defs.string, validate_anyURI);
  reg "xsd:duration"
    (Primitive "xsd:duration", duration_type, validate_duration);
  reg "xsd:dateTime"
    (Primitive "xsd:dateTime", dateTime_type, validate_dateTime);
  reg "xsd:time"
    (Primitive "xsd:time", time_type, validate_time);
  reg "xsd:date"
    (Primitive "xsd:date", date_type, validate_date);
  reg "xsd:gYearMonth"
    (Primitive "xsd:gYearMonth", gYearMonth_type, validate_gYearMonth);
  reg "xsd:gYear"
    (Primitive "xsd:gYear", gYear_type, validate_gYear);
  reg "xsd:gMonthDay"
    (Primitive "xsd:gMonthDay", gMonthDay_type, validate_gMonthDay);
  reg "xsd:gDay"
    (Primitive "xsd:gDay", gDay_type, validate_gDay);
  reg "xsd:gMonth"
    (Primitive "xsd:gMonth", gMonth_type, validate_gMonth);

  (* derived builtins *)

  reg "xsd:integer"
    (restrict' "xsd:integer" "xsd:decimal" no_facets, (* fake restriction *)
    Builtin_defs.int, validate_integer);
  reg "xsd:nonPositiveInteger"
    (restrict' "xsd:nonPositiveInteger" "xsd:integer"
      { no_facets with maxInclusive = Some (Value.Integer zero, false) },
    nonPositiveInteger_type, validate_nonPositiveInteger);
  reg "xsd:negativeInteger"
    (restrict' "xsd:negativeInteger" "xsd:nonPositiveInteger"
      { no_facets with maxInclusive = Some (Value.Integer minus_one, false) },
    negativeInteger_type, validate_negativeInteger);
  reg "xsd:nonNegativeInteger"
    (restrict' "xsd:nonNegativeInteger" "xsd:integer"
      { no_facets with minInclusive = Some (Value.Integer zero, false) },
    nonNegativeInteger_type, validate_nonNegativeInteger);
  reg "xsd:positiveInteger"
    (restrict' "xsd:positiveInteger" "xsd:nonNegativeInteger"
      { no_facets with minInclusive = Some (Value.Integer one, false) },
    positiveInteger_type, validate_positiveInteger);
  reg "xsd:long"
    (restrict' "xsd:long" "xsd:integer"
      { no_facets with
          minInclusive = Some (Value.Integer long_l, false);
          maxInclusive = Some (Value.Integer long_r, false)},
    long_type, validate_long);
  reg "xsd:int"
    (restrict' "xsd:int" "xsd:long"
      { no_facets with
          minInclusive = Some (Value.Integer int_l, false);
          maxInclusive = Some (Value.Integer int_r, false)},
    int_type, validate_int);
  reg "xsd:short"
    (restrict' "xsd:short" "xsd:int"
      { no_facets with
          minInclusive = Some (Value.Integer short_l, false);
          maxInclusive = Some (Value.Integer short_r, false)},
    short_type, validate_short);
  reg "xsd:byte"
    (restrict' "xsd:byte" "xsd:short"
      { no_facets with
          minInclusive = Some (Value.Integer byte_l, false);
          maxInclusive = Some (Value.Integer byte_r, false)},
    byte_type, validate_short);
  reg "xsd:normalizedString"
    (restrict' "xsd:normalizedString" "xsd:string"
      { no_facets with whiteSpace = `Replace, false },
    Builtin_defs.string, validate_normalizedString);
  reg "xsd:token"
    (restrict' "xsd:token" "xsd:normalizedString"
      { no_facets with whiteSpace = `Collapse, false },
    Builtin_defs.string, validate_token);
  alias "xsd:language" "xsd:token";
  alias "xsd:Name" "xsd:token";
  alias "xsd:NMTOKEN" "xsd:token";
  alias "xsd:NCName" "xsd:token";
  alias "xsd:ID" "xsd:token";
  alias "xsd:IDREF" "xsd:token";
  alias "xsd:ENTITY" "xsd:token";
  reg "xsd:NMTOKENS"
    (list' "xsd:NMTOKENS" "xsd:token",
    string_list_type, validate_token_list);
  alias "xsd:IDREFS" "xsd:NMTOKENS";
  alias "xsd:ENTITIES" "xsd:NMTOKENS"

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

  (** {2 API} *)

let is_builtin = Hashtbl.mem builtins
let iter_builtin f =
  Hashtbl.iter (fun _ (type_def, _, _) -> f type_def) builtins

let lookup name = Hashtbl.find builtins name

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

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

1	abate	500
2	abate	507	open Printf
3	abate	801
4	abate	507	open Schema_types
5	abate	759	open Schema_common
6	abate	500
7			(* TODO dates: boundary checks (e.g. 95/26/2003) *)
8			(* TODO a lot of almost cut-and-paste code, expecially in gFoo types validation
9			*)
10
11	abate	759	(** {2 Aux/Misc stuff} *)
12	abate	500
13	abate	784	let zero = Intervals.V.zero
14			let one = (Intervals.V.succ Intervals.V.zero)
15			let minus_one = (Intervals.V.pred Intervals.V.zero)
16			let long_l = (Intervals.V.mk "-9223372036854775808")
17			let long_r = (Intervals.V.mk "9223372036854775807")
18			let int_l = (Intervals.V.mk "-2147483648")
19			let int_r = (Intervals.V.mk "2147483647")
20			let short_l = (Intervals.V.mk "-32768")
21			let short_r = (Intervals.V.mk "32767")
22			let byte_l = (Intervals.V.mk "-128")
23			let byte_r = (Intervals.V.mk "127")
24
25	abate	759	let regexp' s = Pcre.regexp ~flags:[`UTF8] s
26			let xml_S_RE = regexp' "[ \\t\\r\\n]+"
27			(* split a string at XML recommendation "S" production boundaries *)
28			let split_xml_S s = Pcre.split ~rex:xml_S_RE s
29			let norm_RE = regexp' "[\\t\\r\\n]"
30
31	abate	500	let char_of_hex =
32			let int_of_hex_char = function
33			\| '0' -> 0 \| '1' -> 1 \| '2' -> 2 \| '3' -> 3 \| '4' -> 4 \| '5' -> 5 \| '6' -> 6
34			\| '7' -> 7 \| '8' -> 8 \| '9' -> 9 \| 'a' \| 'A' -> 10 \| 'b' \| 'B' -> 11
35			\| 'c' \| 'C' -> 12 \| 'd' \| 'D' -> 13 \| 'e' \| 'E' -> 14 \| 'f' \| 'F' -> 15
36			\| _ -> assert false
37			in
38			(* most significative, least significative *)
39			fun ms ls -> Char.unsafe_chr (int_of_hex_char ms * 16 + int_of_hex_char ls)
40
41	abate	507	let strip_parens s = Pcre.replace ~pat:"[()]" s
42			let add_limits s = "^" ^ s ^ "$"
43	abate	500
44	abate	784	exception Schema_builtin_error of string
45			let simple_type_error name =
46			raise (Schema_builtin_error (Schema_xml.xsd_prefix ^ name))
47	abate	500
48	abate	801	let qualify s = (Schema_xml.xsd_namespace, Encodings.Utf8.mk s)
49
50	abate	500	(* regular expressions used to validate built-in types *)
51
52	abate	507	let timezone_RE_raw = "(Z)\|(([+-])?(\\d{2}):(\\d{2}))"
53			let date_RE_raw = "(\\d{4,})-(\\d{2})-(\\d{2})"
54			let time_RE_raw = "(\\d{2}):(\\d{2}):(\\d{2})"
55	abate	500
56	abate	507	let gYearMonth_RE_raw = sprintf "(-)?(\\d{4,})-(\\d{2})(%s)?" timezone_RE_raw
57			let gYear_RE_raw = sprintf "(-)?(\\d{4,})(%s)?" timezone_RE_raw
58			let gMonthDay_RE_raw = sprintf "--(\\d{2})-(\\d{2})(%s)?" timezone_RE_raw
59			let gDay_RE_raw = sprintf "---(\\d{2})(%s)?" timezone_RE_raw
60			let gMonth_RE_raw = "--(\\d{2})--(%s)?"
61	abate	500
62	abate	759	(** {2 CDuce types} *)
63
64	abate	801	let positive_field = false, qualify "positive", Builtin_defs.bool
65			let year_field = false, qualify "year", Builtin_defs.int
66			let month_field = false, qualify "month", Builtin_defs.int
67			let day_field = false, qualify "day", Builtin_defs.int
68			let hour_field = false, qualify "hour", Builtin_defs.int
69			let minute_field = false, qualify "minute", Builtin_defs.int
70			let second_field = false, qualify "second", Builtin_defs.int
71	abate	759	(* TODO this should be a decimal *)
72			let time_type_fields = [ hour_field; minute_field; second_field ]
73			let date_type_fields = [ year_field; month_field; day_field ]
74	abate	500
75			(* TODO the constraint that at least one part should be present isn't easily
76			expressible with CDuce types *)
77			let duration_type = Types.rec_of_list' [
78			positive_field;
79	abate	801	true, qualify "year", Builtin_defs.int;
80			true, qualify "month", Builtin_defs.int;
81			true, qualify "day", Builtin_defs.int;
82			true, qualify "hour", Builtin_defs.int;
83			true, qualify "minute", Builtin_defs.int;
84			true, qualify "second", Builtin_defs.int; (* TODO this should be a decimal *)
85	abate	507	]
86	abate	500	let timezone_type = Types.rec_of_list' [
87	abate	801	positive_field;
88	abate	500	hour_field; minute_field
89	abate	507	]
90	abate	801	let timezone_type_fields = [ true, qualify "timezone", timezone_type ]
91	abate	507	let time_type = Types.rec_of_list' (time_type_fields @ timezone_type_fields)
92			let date_type = Types.rec_of_list' (positive_field :: date_type_fields)
93	abate	500	let dateTime_type =
94			Types.rec_of_list' (positive_field ::
95			(date_type_fields @ time_type_fields @ timezone_type_fields))
96			let gYearMonth_type = Types.rec_of_list' [
97			positive_field; year_field; month_field
98	abate	507	]
99			let gYear_type = Types.rec_of_list' [ positive_field; year_field ]
100			let gMonthDay_type = Types.rec_of_list' [ month_field; day_field ]
101			let gDay_type = Types.rec_of_list' [ day_field ]
102			let gMonth_type = Types.rec_of_list' [ month_field ]
103	abate	500
104	abate	507	let nonPositiveInteger_type = Builtin_defs.non_pos_int
105			let negativeInteger_type = Builtin_defs.neg_int
106			let nonNegativeInteger_type = Builtin_defs.non_neg_int
107			let positiveInteger_type = Builtin_defs.pos_int
108	abate	784	let long_type = Builtin_defs.long_int
109			let int_type = Builtin_defs.int_int
110			let short_type = Builtin_defs.short_int
111			let byte_type = Builtin_defs.byte_int
112	abate	500
113	abate	759	let string_list_type = Sequence.star Builtin_defs.string
114	abate	500
115	abate	759	(** {2 Validation functions (string -> Value.t)} *)
116	abate	500
117	abate	759	let parse_sign = function "+" \| "" -> Value.vtrue \| _ -> Value.vfalse
118
119	abate	500	let validate_integer s =
120			try
121	abate	656	Value.Integer (Intervals.V.mk s)
122	abate	784	with Failure _ -> simple_type_error "integer"
123	abate	500
124	abate	784	let strip_decimal_RE = Pcre.regexp "\\..*$"
125			let validate_decimal s = validate_integer (Pcre.replace ~rex:strip_decimal_RE s)
126
127	abate	500	let parse_date =
128			let rex = Pcre.regexp (add_limits date_RE_raw) in
129			fun s ->
130	abate	784	let abort () = simple_type_error "date" in
131	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
132			[ "year", validate_integer subs.(1);
133			"month", validate_integer subs.(2);
134			"day", validate_integer subs.(3) ]
135
136			let parse_time =
137			let rex = Pcre.regexp (add_limits time_RE_raw) in
138			fun s ->
139	abate	784	let abort () = simple_type_error "time" in
140	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
141			[ "hour", validate_integer subs.(1);
142			"minute", validate_integer subs.(2);
143			"second", validate_integer subs.(3) ]
144
145			let parse_timezone =
146			let rex = Pcre.regexp (add_limits timezone_RE_raw) in
147			fun s ->
148	abate	784	let abort () = raise (Schema_builtin_error "timezone") in
149	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
150			match subs.(1) with
151			\| "Z" ->
152			["positive", Value.vtrue;
153			"hour", validate_integer "0";
154			"minute", validate_integer "0"]
155			\| _ ->
156			["positive", parse_sign subs.(3);
157			"hour", validate_integer subs.(4);
158	abate	759
159	abate	500	"minute", validate_integer subs.(5)]
160			(* parse a timezone from a string, if it's empty return the empty list,
161			otherwise return a list containing a pair <"timezone", timezone value> *)
162			let parse_timezone' = function
163			\| "" -> []
164			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ]
165
166	abate	801	let validate_string s = Value.string_utf8 (Encodings.Utf8.mk s)
167	abate	759	let validate_normalizedString s =
168			validate_string (normalize_white_space `Replace s)
169			let validate_token s =
170			validate_string (normalize_white_space `Collapse s)
171			let validate_token_list s =
172			Value.sequence (List.map validate_token (split_xml_S s))
173
174			let validate_interval interval type_name s =
175			let integer =
176			try
177			Intervals.V.mk s
178	abate	784	with Failure _ -> simple_type_error type_name
179	abate	759	in
180			if Intervals.contains integer interval then
181			Value.Integer integer
182			else
183	abate	784	simple_type_error type_name
184	abate	759	let validate_nonPositiveInteger =
185			validate_interval (Intervals.left Intervals.V.zero) "nonPositiveInteger"
186			let validate_negativeInteger =
187			validate_interval (Intervals.left Intervals.V.minus_one) "negativeInteger"
188			let validate_nonNegativeInteger =
189			validate_interval (Intervals.right Intervals.V.zero) "nonNegativeInteger"
190			let validate_positiveInteger =
191			validate_interval (Intervals.right Intervals.V.one) "positiveInteger"
192	abate	784	let validate_long = validate_interval (Intervals.bounded long_l long_r) "long"
193			let validate_int = validate_interval (Intervals.bounded int_l int_r) "int"
194			let validate_short =
195			validate_interval (Intervals.bounded short_l short_r) "short"
196			let validate_byte = validate_interval (Intervals.bounded byte_l byte_r) "byte"
197	abate	759
198			let validate_bool = function
199			\| "true" \| "1" -> Value.vtrue
200			\| "false" \| "0" -> Value.vfalse
201	abate	784	\| v -> simple_type_error "boolean"
202	abate	759
203	abate	500	let validate_duration =
204			let rex = Pcre.regexp
205			"^([+-])?P((\\d+)Y)?((\\d+)M)?((\\d+)D)?(T((\\d+)H)?((\\d+)M)?((\\d+)S)?)?$"
206			in
207			fun s ->
208	abate	784	let abort () = simple_type_error "duration" in
209	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
210			try
211			let fields =
212			["positive", parse_sign subs.(1) ] @
213			(match subs.(3) with "" -> [] \| v -> ["year", validate_integer v]) @
214			(match subs.(5) with "" -> [] \| v -> ["month", validate_integer v]) @
215			(match subs.(7) with "" -> [] \| v -> ["day", validate_integer v]) @
216			(match subs.(10) with "" -> [] \| v -> ["hour", validate_integer v]) @
217			(match subs.(12) with "" -> [] \| v -> ["minute", validate_integer v]) @
218			(match subs.(14) with "" -> [] \| v -> ["second", validate_integer v])
219			in
220			Value.vrecord fields
221	abate	784	with Schema_builtin_error _ -> abort ()
222	abate	500
223			let validate_dateTime =
224			let rex = Pcre.regexp (sprintf "^([+-])?(%s)T(%s)(%s)?$"
225			(strip_parens date_RE_raw) (strip_parens time_RE_raw)
226			(strip_parens timezone_RE_raw))
227			in
228			fun s ->
229	abate	784	let abort () = simple_type_error "dateTime" in
230	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
231			try
232			let fields =
233			[ "positive", parse_sign subs.(1) ] @
234			parse_date subs.(2) @
235			parse_time subs.(3) @
236			parse_timezone' subs.(4)
237			in
238			Value.vrecord fields
239	abate	784	with Schema_builtin_error _ -> abort ()
240	abate	500
241			let validate_gYearMonth =
242			let rex = Pcre.regexp (add_limits gYearMonth_RE_raw) in
243			fun s ->
244	abate	784	let abort () = simple_type_error "gYearMonth" in
245	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
246			try
247			let fields = [
248			"positive", parse_sign subs.(1);
249			"year", validate_integer subs.(2);
250			"month", validate_integer subs.(3)
251			] @ parse_timezone' subs.(4)
252			in
253			Value.vrecord fields
254	abate	784	with Schema_builtin_error _ -> abort ()
255	abate	500
256			let validate_gYear =
257			let rex = Pcre.regexp (add_limits gYear_RE_raw) in
258			fun s ->
259	abate	784	let abort () = simple_type_error "gYear" in
260	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
261			try
262			let fields = [
263			"positive", parse_sign subs.(1);
264			"year", validate_integer subs.(2);
265			] @ parse_timezone' subs.(3)
266			in
267			Value.vrecord fields
268	abate	784	with Schema_builtin_error _ -> abort ()
269	abate	500
270			let validate_gMonthDay =
271			let rex = Pcre.regexp (add_limits gMonthDay_RE_raw) in
272			fun s ->
273	abate	784	let abort () = simple_type_error "gMonthDay" in
274	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
275			try
276			let fields = [
277			"month", validate_integer subs.(1);
278			"day", validate_integer subs.(2);
279			] @ parse_timezone' subs.(3)
280			in
281			Value.vrecord fields
282	abate	784	with Schema_builtin_error _ -> abort ()
283	abate	500
284			let validate_gDay =
285			let rex = Pcre.regexp (add_limits gDay_RE_raw) in
286			fun s ->
287	abate	784	let abort () = simple_type_error "gDay" in
288	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
289			try
290			let fields =
291			("day", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
292			in
293			Value.vrecord fields
294	abate	784	with Schema_builtin_error _ -> abort ()
295	abate	500
296			let validate_gMonth =
297			let rex = Pcre.regexp (add_limits gMonth_RE_raw) in
298			fun s ->
299	abate	784	let abort () = simple_type_error "gMonth" in
300	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
301			try
302			let fields =
303			("month", validate_integer subs.(1)) :: (parse_timezone' subs.(2))
304			in
305			Value.vrecord fields
306	abate	784	with Schema_builtin_error _ -> abort ()
307	abate	500
308			let validate_time =
309			let rex = Pcre.regexp (sprintf "^(%s)(%s)?$" (strip_parens time_RE_raw)
310			(strip_parens timezone_RE_raw))
311			in
312			fun s ->
313	abate	784	let abort () = simple_type_error "time" in
314	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
315			try
316			let fields =
317			parse_time subs.(1) @
318			(match subs.(2) with
319			\| "" -> []
320			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
321			in
322			Value.vrecord fields
323	abate	784	with Schema_builtin_error _ -> abort ()
324	abate	500
325			let validate_date =
326			let rex = Pcre.regexp (sprintf "^(-)?(%s)(%s)?$" (strip_parens date_RE_raw)
327			(strip_parens timezone_RE_raw))
328			in
329			fun s ->
330	abate	784	let abort () = simple_type_error "date" in
331	abate	500	let subs = try Pcre.extract ~rex s with Not_found -> abort () in
332			try
333			let fields =
334			[ "positive", parse_sign subs.(1) ] @
335			parse_date subs.(2) @
336			(match subs.(3) with
337			\| "" -> []
338			\| v -> [ "timezone", Value.vrecord (parse_timezone v) ])
339			in
340			Value.vrecord fields
341	abate	784	with Schema_builtin_error _ -> abort ()
342	abate	500
343			let validate_hexBinary s =
344			let len = String.length s in
345			if len mod 2 <> 0 then
346	abate	784	simple_type_error "hexBinary";
347	abate	500	let res = String.create (len / 2) in
348			let rec aux idx =
349			if idx < len then begin
350			String.unsafe_set res (idx / 2)
351			(char_of_hex (String.unsafe_get s idx) (String.unsafe_get s (idx + 1)));
352			aux (idx + 2)
353			end
354			in
355			aux 0;
356			validate_string res
357
358	abate	507	let validate_base64Binary s = validate_string (Netencoding.Base64.decode s)
359	abate	500
360			let validate_anyURI s =
361			try
362			validate_string (Neturl.string_of_url (Neturl.url_of_string
363			Neturl.ip_url_syntax s))
364	abate	784	with Neturl.Malformed_URL -> simple_type_error "anyURI"
365	abate	500
366	abate	759	(** {2 API backend} *)
367	abate	500
368	abate	759	let builtins = Hashtbl.create 50
369			let reg name spec = Hashtbl.add builtins name spec
370			let alias alias name =
371			Hashtbl.add builtins alias
372			(let (st_def, descr, validator) = Hashtbl.find builtins name in
373			let new_def =
374			match st_def with
375			\| Primitive _ -> Primitive alias
376			\| Derived (_, variety, facets, base) ->
377			Derived (Some alias, variety, facets, base)
378			in
379			(new_def, descr, validator))
380			let restrict' name basename new_facets =
381			let (base, _, _) = Hashtbl.find builtins basename in
382			let variety = variety_of_simple_type_definition base in
383			let facets =
384			merge_facets (facets_of_simple_type_definition base) new_facets
385			in
386			Derived (Some name, variety, facets, base)
387			let list' name itemname =
388			let (base, _, _) = Hashtbl.find builtins itemname in
389			Derived (Some name, List base, no_facets, base)
390	abate	500
391	abate	759	let fill () = (* fill "builtins" hashtbl *)
392	abate	500
393	abate	759	(* TODO missing built-in simple types: xsd:float, xsd:double, xsd:QName,
394	abate	784	* xsd:NOTATION, xsd:decimal *)
395	abate	500
396	abate	759	(* primitive builtins *)
397
398			reg "xsd:anySimpleType"
399			(Primitive "xsd:anySimpleType", Builtin_defs.string, validate_string);
400			alias "xsd:anyType" "xsd:anySimpleType";
401			reg "xsd:string"
402			(Primitive "xsd:string", Builtin_defs.string, validate_string);
403	abate	784	reg "xsd:decimal"
404			(* collapsed in CDuce to an integer, since CDuce has no decimal numbers *)
405			(Primitive "xsd:decimal", Builtin_defs.int, validate_decimal);
406	abate	759	reg "xsd:boolean"
407			(Primitive "xsd:boolean", Builtin_defs.bool, validate_bool);
408			reg "xsd:hexBinary"
409			(Primitive "xsd:hexBinary", Builtin_defs.string, validate_hexBinary);
410			reg "xsd:base64Binary"
411			(Primitive "xsd:base64Binary", Builtin_defs.string, validate_base64Binary);
412			reg "xsd:anyURI"
413			(Primitive "xsd:anyURI", Builtin_defs.string, validate_anyURI);
414			reg "xsd:duration"
415			(Primitive "xsd:duration", duration_type, validate_duration);
416			reg "xsd:dateTime"
417			(Primitive "xsd:dateTime", dateTime_type, validate_dateTime);
418			reg "xsd:time"
419			(Primitive "xsd:time", time_type, validate_time);
420			reg "xsd:date"
421			(Primitive "xsd:date", date_type, validate_date);
422			reg "xsd:gYearMonth"
423			(Primitive "xsd:gYearMonth", gYearMonth_type, validate_gYearMonth);
424			reg "xsd:gYear"
425			(Primitive "xsd:gYear", gYear_type, validate_gYear);
426			reg "xsd:gMonthDay"
427			(Primitive "xsd:gMonthDay", gMonthDay_type, validate_gMonthDay);
428			reg "xsd:gDay"
429			(Primitive "xsd:gDay", gDay_type, validate_gDay);
430			reg "xsd:gMonth"
431			(Primitive "xsd:gMonth", gMonth_type, validate_gMonth);
432
433			(* derived builtins *)
434
435	abate	784	reg "xsd:integer"
436			(restrict' "xsd:integer" "xsd:decimal" no_facets, (* fake restriction *)
437			Builtin_defs.int, validate_integer);
438	abate	759	reg "xsd:nonPositiveInteger"
439			(restrict' "xsd:nonPositiveInteger" "xsd:integer"
440	abate	784	{ no_facets with maxInclusive = Some (Value.Integer zero, false) },
441	abate	759	nonPositiveInteger_type, validate_nonPositiveInteger);
442			reg "xsd:negativeInteger"
443			(restrict' "xsd:negativeInteger" "xsd:nonPositiveInteger"
444	abate	784	{ no_facets with maxInclusive = Some (Value.Integer minus_one, false) },
445	abate	759	negativeInteger_type, validate_negativeInteger);
446			reg "xsd:nonNegativeInteger"
447			(restrict' "xsd:nonNegativeInteger" "xsd:integer"
448	abate	784	{ no_facets with minInclusive = Some (Value.Integer zero, false) },
449	abate	759	nonNegativeInteger_type, validate_nonNegativeInteger);
450			reg "xsd:positiveInteger"
451			(restrict' "xsd:positiveInteger" "xsd:nonNegativeInteger"
452	abate	784	{ no_facets with minInclusive = Some (Value.Integer one, false) },
453	abate	759	positiveInteger_type, validate_positiveInteger);
454	abate	784	reg "xsd:long"
455			(restrict' "xsd:long" "xsd:integer"
456			{ no_facets with
457			minInclusive = Some (Value.Integer long_l, false);
458			maxInclusive = Some (Value.Integer long_r, false)},
459			long_type, validate_long);
460			reg "xsd:int"
461			(restrict' "xsd:int" "xsd:long"
462			{ no_facets with
463			minInclusive = Some (Value.Integer int_l, false);
464			maxInclusive = Some (Value.Integer int_r, false)},
465			int_type, validate_int);
466			reg "xsd:short"
467			(restrict' "xsd:short" "xsd:int"
468			{ no_facets with
469			minInclusive = Some (Value.Integer short_l, false);
470			maxInclusive = Some (Value.Integer short_r, false)},
471			short_type, validate_short);
472			reg "xsd:byte"
473			(restrict' "xsd:byte" "xsd:short"
474			{ no_facets with
475			minInclusive = Some (Value.Integer byte_l, false);
476			maxInclusive = Some (Value.Integer byte_r, false)},
477			byte_type, validate_short);
478	abate	759	reg "xsd:normalizedString"
479			(restrict' "xsd:normalizedString" "xsd:string"
480			{ no_facets with whiteSpace = `Replace, false },
481			Builtin_defs.string, validate_normalizedString);
482			reg "xsd:token"
483			(restrict' "xsd:token" "xsd:normalizedString"
484			{ no_facets with whiteSpace = `Collapse, false },
485			Builtin_defs.string, validate_token);
486			alias "xsd:language" "xsd:token";
487			alias "xsd:Name" "xsd:token";
488			alias "xsd:NMTOKEN" "xsd:token";
489			alias "xsd:NCName" "xsd:token";
490			alias "xsd:ID" "xsd:token";
491			alias "xsd:IDREF" "xsd:token";
492			alias "xsd:ENTITY" "xsd:token";
493			reg "xsd:NMTOKENS"
494			(list' "xsd:NMTOKENS" "xsd:token",
495			string_list_type, validate_token_list);
496			alias "xsd:IDREFS" "xsd:NMTOKENS";
497			alias "xsd:ENTITIES" "xsd:NMTOKENS"
498
499			let _ = try fill () with Not_found -> assert false
500
501			(** {2 API} *)
502
503			let is_builtin = Hashtbl.mem builtins
504			let iter_builtin f =
505			Hashtbl.iter (fun _ (type_def, _, _) -> f type_def) builtins
506
507			let lookup name = Hashtbl.find builtins name
508
509			let fst (x,_,_) = x
510			let snd (_,y,_) = y
511			let trd (_,_,z) = z
512
513			let get_builtin name = fst (lookup name)
514			let cd_type_of_builtin name = snd (lookup name)
515	abate	784	let validate_builtin name = trd (lookup name)
516	abate	759