(** Time-stamp: <modified the 03/06/2008 (at 11:34) by Erwan Jahier> *)

open Lxm
open SyntaxTree
open SyntaxTreeCore
open Errors
open SyntaxTabUtils

let (doit:
       (Ident.t, SyntaxTree.model_info Lxm.srcflagged) Hashtbl.t ->
      (SyntaxTree.pack_info  Lxm.srcflagged) ->
      SyntaxTree.pack_given) =
  fun mtab pdata -> (
    match (pdata.it.pa_def) with
	PackGiven pg -> pg
	  (* on garde tel-quel ... *)
	  
      | PackInstance pi -> (
	  (* recherche du mod�le *)
	  let mi = try Hashtbl.find mtab pi.pi_model 
	  with Not_found ->
	    let msg = Printf.sprintf "bad pack instance: model %s undeclared"
	      (Ident.to_string pi.pi_model)
	    in
	      raise ( Compile_error (pdata.src, msg))
	  in
	    (*-----------INIT-----------------------------------*)
	    (* On part du packbody du mod�le, dont on duplique les tables :*)
	  let ctab = Hashtbl.copy mi.it.mo_body.pk_const_table in
	  let ttab = Hashtbl.copy mi.it.mo_body.pk_type_table in
	  let otab = Hashtbl.copy mi.it.mo_body.pk_node_table in
	    (* liste des nouveaux define ... *)
	  let newdefs = ref [] in
	    (* liste des nouveaux provides ... *)
	  let newprov = ref [] in
	    (* On met en correspondance les pi_args avec les mo_needs *)
	  let args = pi.pi_args in
	  let pars = mi.it.mo_needs in
	    (*--------------------------------------------------*)

	  (* la fonction qui traite un couple ... *)
	  let (check_arg : static_param srcflagged -> static_arg srcflagged -> unit) =
	    fun param arg -> 
	      (* message d'erreur standard *)
	      let instance_error () = 
		let msg = Printf.sprintf
		  "bad argument in package instance: %s" (Lxm.details param.src)
		in
		  raise (Compile_error (arg.src, msg)) 
	      in
		(* on a soit un ident, � checker plus tard, soit une
		   expression de la bonne nature *)
		match (param.it) with
		  | StaticParamType s -> (
		      let te = match (arg.it) with
			  StaticArgIdent idr -> 
			    Lxm.flagit (Named_type_exp idr) arg.src
			| StaticArgType x -> x
			| _ -> instance_error ()
		      in
		      let ti = AliasedType (s, te) in
		      let x = Lxm.flagit (TypeInfo ti) param.src in
			newprov := x::!newprov ;
			let y = Lxm.flagit ti param.src in
			  put_in_tab "type" ttab s y ;
			  newdefs := (TypeItem s)::!newdefs
		    ) 
		  | StaticParamConst (s,te) -> (
		      let ce = match (arg.it) with
			| StaticArgIdent idr -> 
			    ParserUtils.leafexp arg.src (IDENT_n idr) 
			| StaticArgConst x -> x
			| _ -> instance_error ()
		      in
		      let ci = DefinedConst (s, Some te, ce) in
		      let x = Lxm.flagit (ConstInfo ci) param.src in
			newprov := x::!newprov ;
			let y = Lxm.flagit ci param.src in
			  put_in_tab "const" ctab s y ;
			  newdefs := (ConstItem s)::!newdefs
		    ) 
		  | StaticParamNode (s, inl, outl, has_memory) -> (
		      let by_pos_op = match (arg.it) with
			| StaticArgIdent idr -> 
			    CALL_n(Lxm.flagit ((idr,[])) arg.src)
			| StaticArgNode by_pos_op -> by_pos_op 
			| _ -> instance_error () 
		      in
		      let sparams = [] in
		      let ni = {
			name = s;
			static_params = sparams;
			vars = Some (ParserUtils.build_node_var inl outl None);
			def = Alias (flagit by_pos_op arg.src);
			has_mem = has_memory;
			is_safe = true;
		      } 
		      in
		      let x = Lxm.flagit (NodeInfo ni) param.src in
			newprov := x::!newprov ;
			let y = Lxm.flagit ni param.src in
			  put_in_tab "node" otab s y ;
			  newdefs := (NodeItem (s,sparams))::!newdefs
		    ) 
		      (* check_arg *)
	  in
	  let (sargs_pack : Ident.pack_name srcflagged list) =
	    List.fold_left
	      (fun acc arg -> 
		(match arg.it with
		   | StaticArgIdent(idref) ->
		       (match Ident.pack_of_idref idref with
			  | None -> acc
			  | Some p -> 
			      let p_flagged = Lxm.flagit p arg.src in
				if List.mem p_flagged acc then acc else p_flagged::acc
		       )
		   | _ -> acc
		)
	      )
	      []
	      args
	  in
	  let pars_nb = string_of_int (List.length pars)
	  and args_nb = string_of_int (List.length args) in
	    try (
	      (*------------TRAITEMENT---------------------------------*)
	      if (pars_nb <> args_nb) then
		raise(Compile_error 
			(pdata.src, 
			 ("\n*** " ^pars_nb ^ 
			    " arguments are expected, but "^args_nb^
			    " were provided when defining package "^
			    (Ident.pack_name_to_string pdata.it.pa_name)
			 )));
	      List.iter2 check_arg pars args;
	      (* on fabrique un pack_given valide avec les infos r�colt�es *)	
	      let body = {
		pk_const_table = ctab ;
		pk_type_table = ttab ;
		pk_node_table = otab ;
		pk_def_list = List.append
		  (mi.it.mo_body.pk_def_list) 
		  (List.rev !newdefs)
	      } in
		(* les provides du mod�le + les nouveaux de newprov *)
		(* SAUF SI ON EXPORTE DEJA TOUT !                   *)
	      let prov = match (mi.it.mo_provides) with
		  Some l -> (
		    Some (List.append l (List.rev !newprov))
		  ) 
		|  None -> None
	      in
	      let pg = {
		(* les uses du mod�le + les packages utilis�s par les arg statiques *)
		pg_uses = mi.it.mo_uses @ sargs_pack;
		pg_provides = prov ;
		pg_body = body ;
	      } in
		pg
	    ) with Invalid_argument _ -> (
	      let msg = Printf.sprintf
		"bad pack instance: %d args provided while model %s has %d params"
		(List.length args)
		(Ident.to_string pi.pi_model)
		(List.length pars)
	      in
		raise ( Compile_error (pdata.src, msg))
	    )
	)
  )