(**************************************************************************)
(*  The CDuce compiler                                                    *)
(*  Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team               *)
(*  Copyright CNRS,INRIA, 2003,2004 (see LICENSE for details)             *)
(**************************************************************************)

open Encodings

let pos_int = Types.interval (Intervals.right (Intervals.V.mk "1"))
let non_neg_int = Types.interval (Intervals.right (Intervals.V.mk "0"))
let neg_int = Types.interval (Intervals.left (Intervals.V.mk "-1"))
let non_pos_int = Types.interval (Intervals.left (Intervals.V.mk "0"))

let mk_interval_type l r =
  Types.interval (Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))
let long_int = mk_interval_type "-9223372036854775808" "9223372036854775807"
let int_int = mk_interval_type "-2147483648" "2147483647"
let short_int = mk_interval_type "-32768" "32767"
let byte_int = mk_interval_type "-128" "127"
let caml_int = mk_interval_type (string_of_int min_int) (string_of_int max_int)
let byte_int = mk_interval_type "0" "255"

let non_zero_int = Types.cup pos_int neg_int

let pos_intstr =
  Sequence.plus (Types.char (Chars.char_class
			       (Chars.V.mk_char '0')
			       (Chars.V.mk_char '9')
			    )
		)

let neg_intstr =
  Types.times 
    (Types.cons (Types.char (Chars.atom (Chars.V.mk_char '-'))))
    (Types.cons pos_intstr)

let intstr = Types.cup pos_intstr neg_intstr  (* [ '-'? '0'--'9'+ ] *)

let true_atom = Atoms.V.mk_ascii "true"
let false_atom = Atoms.V.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)

let bool = Types.cup true_type false_type
let nil = Sequence.nil_type
let string = Sequence.string
let char = Types.Char.any
let any = Types.any
let int = Types.Int.any
let atom = Types.atom Atoms.any

let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = Sequence.star char_latin1

let time_kind =
  List.fold_left (fun acc t -> Types.cup acc t) Types.empty
    (List.map
      (fun s -> Types.atom (Atoms.atom (Atoms.V.mk Ns.empty (Utf8.mk s))))
      [ "duration"; "dateTime"; "time"; "date"; "gYearMonth"; "gYear";
        "gMonthDay"; "gDay"; "gMonth" ])

open Ident
let get_label = LabelPool.mk (Ns.empty, U.mk "get") 
let set_label = LabelPool.mk (Ns.empty, U.mk "set")

let mk_ref ~get ~set =
  LabelMap.from_list_disj [ get_label, get; set_label, set ]

let ref_type t =
  let get = Types.cons (Types.arrow Sequence.nil_node t)
  and set = Types.cons (Types.arrow t Sequence.nil_node) in
  Types.record' (false , mk_ref ~get ~set)

let float_abs =
  "float"

let float =
  Types.abstract (Types.Abstract.atom float_abs)

let any_attr_node = Types.cons (Types.record' (true,LabelMap.empty)) 
let any_xml,any_xml_seq,any_xml_content = 
  let elt = Types.make () in
  let seq = Types.make () in
  let any_xml_content = Types.cons (Types.times any_attr_node seq) in
  let elt_d = Types.xml (Types.cons atom) any_xml_content in
  let elt_char_d = Types.cup elt_d char in
  let seq_d = Types.cup nil (Types.times (Types.cons elt_char_d) seq) in
  Types.define elt elt_d;
  Types.define seq seq_d;
  elt_d,seq_d,any_xml_content

let any_xml_with_tag t =
  Types.xml (Types.cons (Types.atom t)) any_xml_content
    
