open Ast
open AstT

exception VarUndef of (path * (Lexing.position * Lexing.position))
exception ModuleExpected of (path * (Lexing.position * Lexing.position))
exception VariableExpected of (path * (Lexing.position * Lexing.position))
exception ExprTypeError of ((Lexing.position * Lexing.position) * typ * typ)
exception MatchSameNameError of (string  * (Lexing.position * Lexing.position))
exception BadNumberOfArgs of (Lexing.position * Lexing.position)
exception NonUniqueName of (string * (Lexing.position * Lexing.position))
exception SigNonCompatible of (Lexing.position * Lexing.position)
(* TODO : meilleure affichage des signatures non compatibles *)

(* Module utilise pour creer des id uniques *)
module Id = struct
  let i = ref 1
  let fresh () = let j = !i in incr i; j
  let fresh2 p = p ^ "_" ^ (string_of_int (fresh ()))
end

module Sset = Set.Make(String)
module Smap = Map.Make(String)


let rec typ_to_typT = function
  | Ast.Tint -> Tint
  | Ast.Tbool -> Tbool
  | Ast.Tunit -> Tunit
  | Ast.Tlist t -> Tlist (typ_to_typT t)
  | Ast.Tref t -> Tref (typ_to_typT t)

let binOp_typ = function
  | Add | Sub | Mul | Div | Mod -> (Tint, Tint)
  | Comp _ -> (Tint, Tbool)
  | And | Or -> (Tbool, Tbool)
  | _ -> failwith "Error"

(* Fonctions/modules proches de celles du TD 4 *)

module V = struct
  type t = tvar
  let compare v1 v2 = Pervasives.compare v1.id v2.id
  let equal v1 v2 = v1.id = v2.id
  let create = let r = ref 0 in fun () -> incr r; Tvar { id = !r; t = None }
end

(** Réduction en tête *)
let rec head = function
  | Tvar {t = Some t} -> head t
  | t -> t

(** Conversion d'un type en string *)
let rec type_to_string = function
  | Tvar {id=i;t=None} -> "'a"^(string_of_int i)
  | Tvar {t=Some t} -> type_to_string t
  | Tint -> "int"
  | Tbool -> "bool"
  | Tunit -> "unit"
  | Tlist t -> (type_to_string t)^" list"
  | Tref t -> (type_to_string t)^" ref"

(** Regarde si tvar est utilisé dans t 
  * Suppose que tvar est un enregistrement de la force {t=None}
  * (la réduction en tête a déjà été faite pour tvar) *)
let rec tvar_occur tvar t = match head t with
  | Tvar tvar' -> V.equal tvar tvar'
  | Tlist t -> tvar_occur tvar t
  | Tref t -> tvar_occur tvar t
  | _ -> false

(** Vérifie si deux types sont compatibles (grâce aux Tvar)
 * et met à jour proprement les Tvar
 * normalement t2_ est le type "attendu" et t1_ est le type correspondant à
 * sp/ep *)
let unify sp ep t1_ t2_ = 
  let rec aux t1 t2 = match (head t1, head t2) with
    | (Tint, Tint) ->
        ()
    | (Tbool,Tbool) ->
        ()
    | (Tunit,Tunit) ->
        ()
    (* les tvar? sont de la forme {t=None} car on a réduit en tête *)
    | (Tvar tvar1, Tvar tvar2) when V.equal tvar1 tvar2 ->
        ()
    | (Tvar tvar, t2) when not (tvar_occur tvar t2) ->
        tvar.t<-Some t2
    | (t1, Tvar tvar) ->
        aux (Tvar tvar) t1
    | (Tlist t1, Tlist t2) ->
        aux t1 t2
    | (Tref t1, Tref t2) ->
        aux t1 t2
    | _ ->
        raise (ExprTypeError ((sp, ep),t1_,t2_))
  in
  aux t1_ t2_

(** Raccourcis pour éviter d'avoir à appeler unify avec les bons sp/ep *)
let unifyE {expr_loc=(sp,ep);expr_desc=_} t1 t2 = unify sp ep t1 t2


let path_to_string p =
    String.concat "." p

(* Récupère une variable p dans l'environnement donné : suit bêtement les modules
 * Suppose que le chemin part effectivement de l'environnement donné 
 *
 * Considère les lengthMo premiers éléments du path p comme étant le module
 * courant et accepte donc les foncteurs dans cette partie du path ;
 * elle les refuse dans l'autre partie
 *
 * Renvoie un triplet (from_open,p',t) où :
     * p' est le nom complet de la variable
     * from_open vaut true si la variable provient d'un module ouvert avec open
     * t est le type de la variable *)
let get_var_simple env p lengthMo sp ep = let p_ = p in
    let rec aux1 = function
        | ("!open"::s,t) -> (true,s,t)
        | (l,t) -> (false,l,t)
    in
    let rec aux env p n = match p with
        | [] -> (false,[], Tmod ([],env)) (* renvoie juste le module principal *)
        | [name] -> 
            (try
                let (p',t) = Smap.find name env in (aux1 (p',t))
            with
                Not_found -> raise (VarUndef (p_,(sp,ep)))
            )
        | name::p ->
            (try
                (match Smap.find name env with
                    | (name2,Tmod (l, env)) when l=[] || n>0 ->
                            let (from_open1,p',t) = aux env p (n-1) in 
                            if from_open1 then (true, p',t) else
                            let (from_open2,name2,_) = aux1 (name2,()) in
                            (from_open2,name2@p',t)
                    | _ -> raise (ModuleExpected (p_,(sp,ep)))
                )
            with
                Not_found -> raise (VarUndef (p_,(sp,ep)))
            )
    in
    aux env p lengthMo


(* Récupère une variable dans l'environnement donné mais en sachant que l'on se
 * trouve dans le module mo : essaye de chercher dans le module lui-même puis
 * dans ses arguments (si c'est un foncteur) et enfin dans ses modules parents
 * si rien n'est trouvé *)
let get_var mo env p sp ep = let p_ = p in
    (* Permet de chercher le premier module qui contient la bonne variable
     * exception Not_found tant que la variable n'est pas dans le
     * module considéré - recherche aussi à chaque étape dans !args *)
    let rec find env mo = 
        (* Il faut bien noter que mo est un vrai module : pas un open donc tout
         * les path unique retournés par l'env sont en fait de taille 1
         * et il n'y a absolument pas de "!open" qui traîne dans le path
         * retourné !! *)

        (* on récupère l'environnement du "module" !args *)
        let (nameArgs,envArgs) = try
            (match Smap.find "!args" env with
                | (nameArgs,Tmod (_, envArgs)) -> (nameArgs,envArgs)
                | _ -> raise (ModuleExpected (p_,(sp,ep)))
            )
        with
            Not_found -> failwith "ERREUR INTERNE 7 : fonction get_var : fichier typing.ml"
            (* l'argument de cette fonction est sensé être un vrai module !!! *)
        in
        try match mo with
            (* On cherche d'abord dans les modules enfants si possible *)
            | [] -> raise Not_found
            | name::s ->
                (* On commence par récupérer l'environnement du module name *)
                let (name2,env') = try
                    (match Smap.find name env with
                        | (name2,Tmod (_, env')) -> (name2,env')
                        | _ -> raise (ModuleExpected (p_,(sp,ep)))
                    )
                with
                    Not_found -> failwith "ERREUR INTERNE 2 : fonction get_var : fichier typing.ml"
                    (* l'argument de cette fonction est sensé être un vrai module !!! *)
                in
                    let (from_open,p',t) = find env' s in if from_open=false then
                        (false,name2@p',t) else (true,p',t)
        with
        Not_found ->
            (* Puis on cherche dans l'environnement env (module courant) 
             * puis dans l'environnement envArgs (module !args) *)
            if Smap.mem (List.hd p) env then
                (* La variable est nécessairement ici *)
                let (from_open,p',t) = get_var_simple env p 0 sp ep in
                (from_open,p',t)
            else if Smap.mem (List.hd p) envArgs then
                (* La variable est nécessairement ici *)
                let (from_open,p',t) = get_var_simple envArgs p 0 sp ep in
                assert (from_open=false);
                (false,nameArgs@p',t)
            else
                (* Elle n'est pas ici *)
                raise Not_found
            
    in
    try
        let (_,a,b) = find env mo in (a,b)
    with
        Not_found -> raise (VarUndef (p,(sp,ep)))

(** Retourne un couple (p',env) où env est le nouveau environnement et p'
 * le path complet *)
let set_var_path mo env name p' t sp ep= 
    let rec aux env p = match p with
    | [] -> failwith "ERREUR INTERNE 3 : dans fonction set_var - fichier typing.ml"
    | [name] -> (p',Smap.add name (p',t) env)
    | name::p ->
            try
            (match Smap.find name env with
                | (name2,Tmod (largs, env')) when largs=[] || name="!" ->
                        let (p',env') = (aux env' p) in
                        (name2@p', Smap.add name (name2,Tmod(largs,env')) env)
                | _ -> raise (ModuleExpected (mo,(sp,ep)))
            )
            with
                Not_found -> failwith "ERREUR INTERNE 4 : dans fonction set_var - fichier typing.ml"
    in
    aux env (mo@[name]) 

(** Permet de supprimer les éléments ajoutés avec un open de envMo dans
 * l'environnement env' et
 * restaure quand nécessaire les variables grâce à l'environnement originel env
 * *)
let restaure_open mo envMo env env' sp ep =
    let (_, _, Tmod(_,env)) = get_var_simple env mo (List.length mo) sp ep in
    let rec restaure env' =
        Smap.fold
           (fun name _ env' -> 
               let (p',t) = Smap.find name env' in
               if (List.hd p')="!open" then 
                   (* name est encore présent et provient de l'open envMo *)
                   if Smap.mem name env then
                       (* on peut restaurer qqc de l'env précédent env *)
                       Smap.add name (Smap.find name env) env'
                   else
                       (* on ne peut rien restaurer *)
                       Smap.remove name env'
               else
                   (* name est une nouvelle variable, on n'y touche pas *)
                   env'
           )
           envMo
           env'
    in
    let rec aux env p = match p with
    | [] -> restaure env
    | name::p ->
            try
            (match Smap.find name env with
                | (name2,Tmod (largs, env')) when largs=[] || name="!" ->
                        Smap.add name (name2,Tmod(largs,aux env' p)) env
                | _ -> raise (ModuleExpected (mo,(sp,ep)))
            )
            with
                Not_found -> failwith "ERREUR INTERNE 4 : dans fonction set_var - fichier typing.ml"
    in
    aux env' mo 

(** Cas particulier où p' est remplacé par name' un simple nom *)
let set_var mo env name name' t sp ep = set_var_path mo env name [name'] t sp ep

(** Retourne un couple : (dernier élément de la liste, reste de la liste) *)
let rec separe_dernier = function
  | [] -> failwith "ERREUR INTERNE ? : dans fonction list_sauf_dernier - fichier typing.ml"
  | [x] -> (x,[])
  | x::s -> let (d,l) = separe_dernier s in (d,x::l)

(** Transforme une signature en un vrai environnement - les noms etant deja
 * unique, on ne leur ajoute pas d'id unique *)
let rec sig_to_env = function
  | [] -> Smap.empty
  | {decl_desc=Val (name, lt) ; decl_loc=(sp,ep)}::s ->
          let lt = List.map typ_to_typT lt in
          let env = sig_to_env s in
          if Smap.mem name env then raise (NonUniqueName (name,(sp,ep)));
          let (t,lt) = (separe_dernier lt) in
          Smap.add name ([name],Tval (lt,t)) env
  | {decl_desc=ModuleS (name, args, sigm) ; decl_loc=(sp,ep)}::s ->
          let envMo = sig_to_env sigm in
          let env = sig_to_env s in
          if Smap.mem name env then raise (NonUniqueName (name,(sp,ep)));
          let args = List.map (fun (name,sigS) -> (name,sig_to_env sigS)) args
          in
          Smap.add name ([name],Tmod (args,envMo)) env

(** Verifie que sig1 est une sous-signature de sig2 et retourne une signature
 * identique à sig1 sauf que les noms uniques sont ceux de sig2 *)
let sub_sig_env sig1 sig2 sp ep = 
    let rec aux sig1 sig2 =
        let fmap name1 (name1',t1) =
            let (name2',t2) = 
                try Smap.find name1 sig2 with
                Not_found -> raise (SigNonCompatible (sp,ep))
            in
            match (t1,t2) with
            | (Tval (lt1,t1'), Tval (lt2,t2')) when lt1=lt2 && t1'=t2' ->
                    (name2',t1)
            | (Tmod (la1,env1), Tmod (la2,env2))
            when List.length la1=List.length la2->
                (* TODO verifier les choix des noms ici *)
                let la =List.map2 
                (fun (n1,a1) (n2,a2) -> (n2,(aux a1 a2))) la1 la2 in
                (name2',Tmod (la,aux env1 env2))
            | _ -> raise (SigNonCompatible (sp,ep))
        in
        Smap.mapi fmap sig1
    in
    aux sig1 sig2
                

let rec typings_args mo env sp ep args targs = match (args,targs) with
  | [], [] -> []
  | e_::s, t::ts ->
          let (t',e) = typing_expr mo env e_ in
          unifyE e_ t' t;
          let largs = (typings_args mo env sp ep s ts) in
          (t=Tunit,e)::largs
  | _ -> raise (BadNumberOfArgs (sp,ep))

(** ut est le type attendu en retour
 * il sert a calculer proprement les types
 * des listes et des références
 *
 * Arguments :
 * * mo est le path du module courant
 * * env est l'environnement de typage courant
 * * {} est l'expression à typer
 *
 * Cette fonction renvoie un triplet (env',t',e')
 * * env' est le nouveau environnement (modifie a cause des listes)
 * * t' est le type de l'expresseion e
 * * e' est le nouveau AstT
 **)
and typing_expr mo (env : type_env) {expr_desc = e; expr_loc =
        (sp,ep)} : typ*expr = match e with
  | Ast.Cst (Ast.Int c) ->  (Tint, Cst (Int c))
  | Ast.Cst (Ast.Bool b) -> (Tbool, Cst (Bool b))
  | Ast.Cst (Ast.Unit) -> (Tunit, Cst Unit)
  | Ast.Cst (Ast.EmptyList) -> ((Tlist (V.create ())), Cst EmptyList)
  | Ast.Var p ->
          (match (get_var mo env p sp ep) with
            | (p',Tval ([],t)) ->  (t,Var p')
            | _ -> raise (VariableExpected (p,(sp,ep)))
          )
  | Ast.App (p, args) ->
          (try 
              let (p,t) = get_var mo env p sp ep in 
              (match t with
                | Tval (targs,t) ->
                     let (args') = typings_args mo env sp ep args targs in
                     (t,App (p,args'))
                | _ -> failwith "ERREUR INTERNE 1 : dans fonction typing_expr - fichier typing.ml"
              )
          with
              VarUndef _ when p=["ref"] ->
                     if List.length args<>1 then
                        raise (BadNumberOfArgs (sp,ep))
                     else begin
                        let [e] = args in
                        let (t,e) = typing_expr mo env e in
                        (Tref t,Ref e)
                     end
          )
  | Ast.Binop (Concat, e1, e2_) ->
          let (t1,e1) = typing_expr mo env e1 in
          let (t2,e2) = typing_expr mo env e2_ in
          unifyE e2_ t2 (Tlist t1);
            (t2, Binop(Concat,e1,e2))
  | Ast.Binop (Assert, e1_, e2_) ->
          (* On commence d'abord par typer e2 pour pouvoir modifier le
           * type de e1 si nécessaire *)
          let (t2,e2) = typing_expr mo env e2_ in
          let (t1,e1) = typing_expr mo env e1_ in
          unifyE e1_ t1 (Tref t2);
          (Tunit, Binop(Assert,e1,e2))
  | Ast.Binop (Semi, e1_, e2) ->
          let (t1,e1) = typing_expr mo env e1_ in
          unifyE e1_ t1 Tunit;
          let (t2,e2) = typing_expr mo env e2 in
          (t2, Binop (Semi,e1,e2))
  | Ast.Binop (b, e1_, e2_) ->
          let (t,t') = binOp_typ b in
          let (t1,e1) = typing_expr mo env e1_ in
          unifyE e1_ t1 t;
          let (t2,e2) = typing_expr mo env e2_ in
          unifyE e2_ t2 t;
          (t', Binop (b,e1,e2))
  | Ast.Unop (Minus, e_) ->
          let (t,e) = typing_expr mo env e_ in
          unifyE e_ t Tint;
          (Tint, Unop (Minus, e))
  | Ast.Unop (Excl, e_) ->
          let (t,e) = typing_expr mo env e_ in
          let t_deref = V.create () in
          unifyE e_ t (Tref t_deref);
          (t_deref, Unop (Excl,e))
  | Ast.IfThenElse (e_,e1_,e2_) ->
          let (t,e) = typing_expr mo env e_ in
          unifyE e_ t Tbool;
          let (t1,e1) = typing_expr mo env e1_ in
          let (t2,e2) = typing_expr mo env e2_ in
          unifyE e2_ t2 t1;
          (t2, IfThenElse(e,e1,e2))
  | Ast.LetIn (p,e1,e2) ->
          let (t1,e1) = typing_expr mo env e1 in
          let p' = Id.fresh2 p in
          let (p',env) = set_var mo env p p' (Tval ([],t1)) sp ep in
          let (t2,e2) = typing_expr mo env e2 in
          (t2, LetIn (p',e1,e2))
  | Ast.MatchWith(e_,e1,p1,p2,e2_) ->
          let (tp,e) = typing_expr mo env e_ in
          let t_elt_list = V.create () in
          unifyE e_ tp (Tlist t_elt_list);
          let (t1,e1) = typing_expr mo env e1 in
          if p1=p2 then raise (MatchSameNameError (p1,(sp,ep))); 
          (* On ajoute à l'environnement les deux variables p1 et p2
             match e_ with []->e1 | p1::p2->e2 *)
          let p1' = Id.fresh2 p1 in
          let p2' = Id.fresh2 p2 in
          let (p1',env) = set_var mo env p1 p1' (Tval ([],t_elt_list)) sp ep in
          let (p2',env) = set_var mo env p2 p2' (Tval ([],Tlist t_elt_list)) sp ep in
          (* On type e2 *)
          let (t2,e2) = typing_expr mo env e2_ in
          (* On unifie e1 et e2 *)
          unifyE e2_ t2 t1;
          (t1,MatchWith(e,e1,p1',p2',e2))
(** args1 : arguments formels / args2 : arguments effectifs *)
let apply_functor mo env args1 args2 sp ep = 
    let rec aux args1 args2 = match (args1,args2) with
      | ([],[]) -> ([],[])
      | (args1, []) -> if !Option.app_partielle then (args1,[]) else raise
      (BadNumberOfArgs (sp,ep))
      | ([], args2) -> raise (BadNumberOfArgs (sp,ep))
      | ((p1,sigE1)::s1, p2::s2) ->
              let (p2',t2) = get_var mo env p2 sp ep in (* TODO sp/ep *)
              (match t2 with
              | Tmod ([],sigE2) -> sub_sig_env sigE1 sigE2 sp ep
              | _ -> (raise (ModuleExpected (p2,(sp,ep))))
              );
              let (l1,l2) = aux s1 s2 in (l1,p2'::l2)
    in
    aux args1 args2

let verif_unicite mo env name sp ep =
    (* Vérification de l'unicité *)
    try 
        let (from_open,p,_) = get_var_simple env (mo@[name]) (List.length mo) sp ep in
        if from_open || 
        (mo=[] && Sset.mem (List.hd p) Predef_fun.set_fun) then
            ()
        else raise (NonUniqueName (name,(sp,ep)))
    with VarUndef _->()
   

let rec typing_mexpr mo env args name {Ast.mexpr_desc = e; Ast.mexpr_loc = (sp,ep)} =
    let name' = Id.fresh2 name in
    (* Rendons unique les arguments du foncteur *)
    let args' =
        List.map
            (fun (name,sigS) ->
                (Id.fresh2 name,sig_to_env sigS)
            )
            args
    in
    (* Ajoute les arguments du foncteur à un environnement *)
    let argsEnv =
        List.fold_left2
            (fun env (name,sigS) (name',sigEnv) ->
                Smap.add name ([name'],Tmod ([],sigEnv)) env
            )
            Smap.empty args args'
    in

    (* Crée nom mo@["!"]  qui représente le module/foncteur en cours de création
     * comme cela le module/foncteur ne peut pas s'utiliser lui-même. *)
    let (pMo',env) = set_var mo env "!" name' (Tmod (args',Smap.empty)) sp ep in
    let (_,env) = set_var (mo@["!"]) env "!args" "!args" (Tmod ([],argsEnv))
    sp ep in

    begin match e with 
        | Ast.Struct prog ->
            let (env,prog) = typing_program2 (mo@["!"]) env prog in
            (* puis on remet le bon nom au module, comme cela il peut maintenant
             * être utilisé ! - notons que l'on laisse le !, cela n'est pas
             * grave *)
            let (_,t') = get_var mo env ["!"] sp ep in
            let (_,env) =
                set_var mo env name name' t' sp ep
            in
            (env,pMo',List.map fst args',Struct prog)
        | Ast.Functor (p,args2) ->
            let (p',t') = get_var mo env p sp ep in
            (match t' with
                | Tmod (argsForm,sigS) -> 
                    let (args3,args2) = apply_functor mo env argsForm args2 sp ep in
                    (* args3 sont les arguments restant du foncteur *)
                    let (_,env) = 
                        set_var mo env name name' (Tmod (args'@args3,sigS)) sp
                        ep
                    in
                    (env,pMo',List.map fst (args'),Functor (p',args2))
                | _ -> raise (ModuleExpected (p,(sp,ep)))
            )
    end
and typing_program2 mo env = function
    | [] -> (env,[])
    | {Ast.elt_desc = elt; Ast.elt_loc = (sp,ep)}::s -> match elt with
        | Ast.LetIgnore e_ ->
                let (t,e) = typing_expr mo env e_ in
                unifyE e_ t Tunit;
                let (env,prog) = typing_program2 mo env s in
                (env, (LetIgnore e)::prog)
        | Ast.Let (re, p, args, t, e) ->
                verif_unicite mo env p sp ep;
                (* Nom unique pour la fonction *)
                let name' = Id.fresh2 p in
                (* Type des arguments de la fonction *)
                let targs = (List.map (fun (p,t)->typ_to_typT t) args) in
                (* Nom unique pour les arguments et sauvegarde des types *)
                let args' = List.map 
                    (fun (p,t)->
                        let p'=Id.fresh2 p in
                        (p',typ_to_typT t)
                    ) 
                    args in
                (* Association des nouveaux noms aux anciens
                 * Ajout des types aux nouveaux noms des arguments
                 *)         
                let env' = List.fold_left2
                  (fun env (p,t) (p',t') -> snd (set_var mo env p p' (Tval
                  ([],t')) sp ep))
                   env args args'
                   in
                let t2 = (Tval (targs,typ_to_typT t)) in
                (* Le nom de la fonction est utilisable dans son corps
                 * si et seulement si la fonction est recursive
                 * (re=true)
                 *)
                let env' = if re then snd (set_var mo env' p name' t2 sp ep) else env' in
                (* On verifie que le type de retour est bien celui
                 * demande : t est un type particulier de t'
                 *)
                let (t',e') = typing_expr mo env' e in
                unifyE e t' (typ_to_typT t);
                (* On calcule les noms complets des arguments et on indique si
                 * le type est unit ou non *)
                let args'' = List.map2
                  (fun (p,t) (p',t') -> 
                    (
                      t = Ast.Tunit,
                      fst (set_var mo env p p' (Tval ([],t')) sp ep)
                    )
                  )
                  args args' in
                (* Et on continue à typer le programme sans oublier
                 * d'ajouter le nom de la fonction aux Smap des noms
                 * uniques (env)
                 *)
                let (p',env) =  (set_var mo env p name' t2 sp ep) in
                let (env,prog) =
                    typing_program2 mo env s
                in
                (env, (Let (p', args'', e'))::prog)
        | Ast.Module (name, args, sigOpt, e) ->
                verif_unicite mo env name sp ep;
                let (env,pMo',args,e) = typing_mexpr mo env args name e in
                let env = 
                (match sigOpt with
                | None -> env  
                | Some sigS -> 
                        let (name',Tmod (args,sigE)) = get_var mo env [name] sp ep in
                        let sigE = sub_sig_env (sig_to_env sigS) sigE sp ep in
                        let (_,env) = 
                            set_var mo env name (List.hd (List.rev name')) (Tmod
                            (args,sigE)) sp ep
                        in env
                ) in
                let (env,prog) = typing_program2 mo env s in
                (env,(Module (pMo', List.map (fun x->pMo'@["!args";x]) args, e))::prog)
        | Ast.Open p ->
                let (p',t') = get_var mo env p sp ep in
                let (envMo,env') = match t' with
                | Tmod ([],envMo) ->
                    (envMo,Smap.fold (fun x (p'',t) env -> 
                        snd (set_var_path mo env x (["!open"]@p'@p'') t sp ep)) envMo env)
                | _ -> raise (ModuleExpected (p,(sp,ep)))
                in
                let (env',prog) = typing_program2 mo env' s in
                (* L'instruction Open ne sert à rien ! 
                 * mais il faut restaurer les variables cachées par le open
                 * et supprimer les variables rajouter ! *)
                let env = restaure_open mo envMo env env' sp ep in
                (env,prog)

let typing_program prog = 
    (* Preparation de l'environnement de typage initial *)
    (* WARNING : when you modify this list, DO NOT FORGET to modify
     * verif_unicite function !!!! *)
    let env = Smap.add "!args" (["!args"], Tmod ([], Smap.empty)) Predef_fun.base_env in
    snd (typing_program2 [] env prog)
        
