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

open Ident
open Schema_types
open Schema_common
open Schema_validator
open Encodings
open Typer.IType

let xsd = Schema_xml.xsd
let is_xsd (ns,l) local =
  (Ns.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)

let complex_memo = Hashtbl.create 213
let rexp re = rexp (simplify_regexp re)
  
(* TODO: better approx *)
let xsd_any_type = Types.any
  
let nil_type = itype Sequence.nil_type
  
let mk_len_regexp min max base =
  let rec repeat_regexp re = function
    | 0 -> eps
    | n -> seq re (repeat_regexp re (pred n))
  in
  let min_regexp = repeat_regexp base min in
  match max with
    | Some max ->
	let rec aux acc = function
          | 0 -> acc
          | n -> aux (alt eps (seq base acc)) (pred n)
        in
        seq min_regexp (aux eps (max-min))
    | None -> seq min_regexp  (star base)
	
let mk_seq_derecurs base facets =
  let min,max = match facets with
    | { length = Some (v, _) } -> v, Some v
    | { minLength = Some (v, _); maxLength = None } -> v, None
    | { minLength = None; maxLength = Some (v, _) } -> 1, Some v
    | { minLength = Some (a,_); maxLength = Some (b, _) } -> a, Some b
    | _ -> 1, Some 1 in
  Sequence.repet min max base
    
let xsi_nil_type =
  let m = LabelMap.singleton xsi_nil_label (Types.cons Builtin_defs.true_type)
  in
  Types.record' (false,m)
    
    
    
let rec simple_type = function
  | { st_name = Some name } 
      when Schema_builtin.is name ->
      Schema_builtin.cd_type (Schema_builtin.get name)
  | { st_variety = Atomic st } ->
      (* TODO: apply facets *)
      Schema_builtin.cd_type (Schema_builtin.of_st st)
  | { st_variety = List item; st_facets = facets } ->
      mk_seq_derecurs (simple_type item) facets
  | { st_variety = Union members; st_facets = facets } ->
      let members = List.map simple_type members in
      List.fold_left (fun acc x -> Types.cup x acc) Types.empty members
	
let attr_uses (attrs,other) =
  let fields = 
    List.map 
      (fun at ->
         let r =
           match at.attr_use_cstr with
             | Some (`Fixed (_,v)) -> Types.constant (Value.inv_const v)
             | _ -> simple_type at.attr_decl.attr_typdef
         in
	 (not at.attr_required,  at.attr_decl.attr_name, r))
      attrs in
  Types.rec_of_list false fields
    
let rec regexp_of_term = function
  | Model group -> regexp_of_model_group group
  | Elt decl -> elem (elt_decl decl)
  | Wildcard w -> elem (wildcard w)
      
and wildcard w = 
  itype (Builtin_defs.any_xml_with_tag w.wild_first)
    
and regexp_of_model_group = function
  | Choice l ->
      List.fold_left
	(fun acc particle -> alt acc (regexp_of_particle particle))
        emp l
  | All l | Sequence l ->
      List.fold_left
        (fun acc particle -> seq acc (regexp_of_particle particle))
	eps l
	
and regexp_of_particle p =
  mk_len_regexp p.part_min p.part_max (regexp_of_term p.part_term)
    
and get_complex ct =
  try Hashtbl.find complex_memo ct.ct_uid
  with Not_found -> 
    let slot = delayed () in
    let attrs = attr_uses ct.ct_attrs in
    let r = times (itype attrs) slot in
    Hashtbl.add complex_memo ct.ct_uid r;
    link slot (content ct.ct_content);
    r
      
and complex nil ct =
  let c = get_complex ct in
  if nil then 
    let (attrs,content) = get_ct c in
    let attrs = Types.Record.merge attrs xsi_nil_type in
    ior c (itype (Types.times (Types.cons attrs) Sequence.nil_node))
  else c
    
and content = function
  | CT_empty -> itype Sequence.nil_type
  | CT_simple st -> itype (simple_type st)
  | CT_model (particle, mixed) ->
      let regexp = regexp_of_particle particle in
      rexp (if mixed then mix regexp else regexp)
	
    
and elt_decl elt =
  let atom_type = 
    itype (Types.atom (Atoms.atom (Atoms.V.of_qname elt.elt_name)))
  in
  let content=complex_type_def elt.elt_nillable (Lazy.force elt.elt_typdef) in
  let content =
    match elt.elt_cstr with
      | Some (`Fixed (_,v)) ->
	  iand content (
	    itype (Types.times 
		     (Types.cons Types.any)
		     (Types.cons (Types.constant (Value.inv_const v)))))
      | _ -> content in
  xml atom_type content

and complex_type_def nil = function
  | AnyType -> 
      itype (Types.times 
	       (Types.cons Types.empty_open_record)
	       (Types.cons xsd_any_type))
  | Simple st ->
      let nonnil =
	Types.times 
	  (Types.cons Types.empty_closed_record) 
	  (Types.cons (simple_type st))
      in
      let t =
	if nil then
	  Types.cup nonnil
	    (Types.times
	       (Types.cons xsi_nil_type)
	       (Types.cons Sequence.nil_type))
	else nonnil in
      itype t
  | Complex ct -> complex nil ct
      
let model_group g = rexp (regexp_of_model_group g)
  
let type_def = function
  | AnyType -> xsd_any_type
  | Simple st -> simple_type st
  | Complex ct -> get_type (xml (itype Types.any) (complex false ct))
let elt_decl x = get_type (elt_decl x)
let model_group x = get_type (model_group x.mg_def)
let attr_group ag = attr_uses ag.ag_def



let load_schema schema_name uri =
  let log_schema_component kind name cd_type =
    if not (Schema_builtin.is name) then begin
      Types.Print.register_global (Types.CompUnit.mk schema_name)
	name cd_type;
      
      Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind 
	Ns.QName.print name;
    end 
  in
  let env = ref Env.empty in
  let defs kind name cd_type v lst =
    List.iter
      (fun def ->
	 let name = name def in
	 let cd_type = cd_type def in
	 log_schema_component kind name cd_type;
	 env := Env.add (Ident.ident name) (cd_type, v def) !env
      ) lst
  in
  let schema = Schema_parser.schema_of_uri uri in
  defs "attribute group" (fun ag -> ag.ag_name) attr_group 
    validate_attribute_group schema.attribute_groups;
  defs "model group" (fun mg -> mg.mg_name) model_group 
    validate_model_group schema.model_groups;
  defs "type" name_of_type_definition type_def validate_type schema.types;
  defs "element" (fun e -> e.elt_name) elt_decl 
    validate_element schema.elements;
  !env


let () = Typer.load_schema := load_schema
