open AstT
open Typing
open AstD

module Smap = Map.Make(String)

let modules : (string, AstT.elt) Hashtbl.t = Hashtbl.create 17

(** Découpe la liste en deux parties - la première contient n éléments *)
let rec cut_list n = function
  | [] -> assert (n=0); ([],[])
  | x::s when n>=1 -> let l1,l2 = cut_list (n-1) s in (x::l1,l2)
  | l -> ([],l)

(** Découpe le path en coupant juste après "!args" si possible
 * renvoie (l1,l2,b) avec l1 la première partie du path
 * l2 la deuxième (éventuellement vide)
 * b=true si et seulement si "!args" est présent *)
let rec cut_list_args = function
  | [] -> ([],[],false)
  | [x] -> assert (x<>"!args"); ([x],[],false)
  | x::y::s when x="!args" -> ([x;y],s,true)
  | x::s -> let (a,b,c) = cut_list_args s in (x::a,b,c)

(** Récupère la dernière variable ayant pour nom name dans le programme prog *)
let get_last_variable name prog =
  (** Vérifie si name est le nom initial pointé par p' *)
  let is_ok name p' = 
      let name' = List.hd (List.rev p') in
      (* name' est le dernier élément du path p' *)
      let i = String.rindex name' ('_') in
      let name' = String.sub name' 0 i in
      (* name' est maintenant privé de son id unique *)
      name'=name
  in
  let rec aux = function
      | [] -> None
      | elt::s ->
          match elt with
          | AstT.LetIgnore _ -> aux s
          | AstT.Let (p,_,_) | AstT.Module (p,_,_) ->
               let res = aux s in begin
                   match res with
                   | None when is_ok name p -> Some elt
                   | None -> None
                   | Some a -> Some a
               end
  in
  match aux prog with
  | None ->
      failwith "ERREUR INTERNE 5 : fonction get_last_variable - fichier defunc.ml
      -> variable introuvable"
  | Some a -> a


(** Trouve le path dont le path initial (sans id unique) est le deuxième argument
 * et en partant du module m (premier argument) *)
let rec find_last_variable m = function
  | [] ->
      (match m with
      | AstT.Module (p',_,_) | AstT.Let (p',_,_) ->
          p'
      | _ ->
          failwith "ERREUR INTERNE 6 : fonction find_last_variable - fichier defunc.ml
          -> module/let attendu"
      )
  | name::p ->
      (match m with
      | AstT.Module (p',[],Struct prog) -> 
          let elt=get_last_variable name prog in
          find_last_variable elt p
      | _ ->
          failwith "ERREUR INTERNE 7 : fonction find_last_variable - fichier defunc.ml
          -> module attendu"
      )

(* DANS TOUTE LA SUITE : env est un environnement qui associe à chaque path
 * argument formel de foncteur, un path argument effectif *)

(** Modifie correctement le path p variable d'un (ex-)foncteur
 * sachant que le foncteur avait pour path oldP
 * et que le nouveau module défonctorisé a pour path newP
 *
 * Modifie aussi le path si le path contenait un argument de foncteurs ! *)
let defunc_struct_path oldP newP env p = 
  let rec changeModuleName oldP p = match (oldP,p) with
      | (x::s,y::p) when x=y ->
          let (b,l) = (changeModuleName s p) in
          if b then (true,l) else (false,y::l)
      | ([],p) -> (true,newP@p)
      | (_,p) -> (false,p)
  in
  let (p1,p2,b) = cut_list_args p in 
  if b=false then 
      snd (changeModuleName oldP p) (* le path donné n'était pas un argument de
      foncteur *)
  else begin
      if Smap.mem (path_to_string p1) env then begin
          (* le path donné est un argument formel de foncteur que l'on,
           * peut-être remplacé par l'argument effectif *)
          let p1 = Smap.find (path_to_string p1) env in
          if Hashtbl.mem modules (path_to_string p1) then begin
              (* Cette fois l'argument est bien effectif :
               * il y en effet un cas vicieux où l'on instancie un foncteur dans
               * un autre foncteur avec un argument formel non encore initialisé
               * C'est pour éviter ce cas qu'on a rajouté ce test ! *)
              let m = Hashtbl.find modules (path_to_string p1) in
              let p2 = find_last_variable m p2 in
              snd (changeModuleName oldP p2)
          end else
              (* le path était bien un argument formel de foncteur mais
               * n'ayant pas encore d'argument effectif : on se contente de changer
               * le nom : en prenant bien soin d'utiliser p1@p2 et non p !! *)
              snd (changeModuleName oldP (p1@p2))
      end else
          (* le path était bien un argument formel de foncteur mais
           * n'ayant pas encore d'argument effectif : on se contente de changer
           * le nom ! *)
          snd (changeModuleName oldP p)
  end

(** Défonctorise une expression d'un (ex-)foncteur
 * sachant que le foncteur avait pour path olP
 * et que le nouveau module défonctorisé a pour path newP
 *)
let rec defunc_struct_expr oldP newP env = function
  | AstT.Cst c ->
      AstT.Cst c
  | AstT.Var p ->
      AstT.Var (defunc_struct_path oldP newP env p)
  | AstT.App (p,le) ->
      AstT.App ((defunc_struct_path oldP newP env p),
      List.map (fun (b,e)->(b,defunc_struct_expr oldP newP env e)) le)
  | AstT.Ref e ->
      AstT.Ref (defunc_struct_expr oldP newP env e)
  | AstT.Binop (b,e1,e2) ->
      AstT.Binop (b,(defunc_struct_expr oldP newP env e1),
      (defunc_struct_expr oldP newP env e2))
  | AstT.Unop (u,e) ->
      AstT.Unop (u,(defunc_struct_expr oldP newP env e))
  | AstT.IfThenElse (e,e1,e2) ->
      AstT.IfThenElse ((defunc_struct_expr oldP newP env e),
      (defunc_struct_expr oldP newP env e1),(defunc_struct_expr oldP newP env e2))
  | AstT.LetIn (p,e1,e2) ->
      AstT.LetIn ((defunc_struct_path oldP newP env p),
      (defunc_struct_expr oldP newP env e1),(defunc_struct_expr oldP newP env e2))
  | AstT.MatchWith (e,e1,p1,p2,e2) ->
      AstT.MatchWith ((defunc_struct_expr oldP newP env e),(defunc_struct_expr oldP newP env e1),
      (defunc_struct_path oldP newP env p1),(defunc_struct_path oldP newP env p2),(defunc_struct_expr oldP newP env e2))

(** Idem mais pour des éléments d'une structure *)
let rec defunc_struct oldP newP env = function
  | [] -> []
  | x::s -> match x with
      | AstT.LetIgnore e ->
          (AstT.LetIgnore (defunc_struct_expr oldP newP env e))::defunc_struct oldP newP env s
      | AstT.Let (p,args,e) ->
          let p = defunc_struct_path oldP newP env p in
          let args = List.map (fun (b,p)->(b,defunc_struct_path oldP newP env p)) args in
          let e = defunc_struct_expr oldP newP env e in
          (AstT.Let (p,args,e))::defunc_struct oldP newP env s
      | AstT.Module (p,args,Struct prog) ->
          let p = defunc_struct_path oldP newP env p in
          let args = List.map (defunc_struct_path oldP newP env) args in
          let prog = defunc_struct oldP newP env prog in
          let m = AstT.Module (p,args,Struct prog) in
          Hashtbl.add modules (path_to_string p) m;
          m::defunc_struct oldP newP env s
      | AstT.Module (p,args,Functor (p',args')) -> 
          let p' = defunc_struct_path oldP newP env p' in
          let args' = List.map (defunc_struct_path oldP newP env) args' in
          let m = defunc p args p' args' in 
          defunc_struct oldP newP env (m::s)

and defunc p args p' args' =
  let AstT.Module (p',funcArgs,Struct func) = 
    try Hashtbl.find modules (path_to_string p') with _->failwith
    ("ERREUR INTERNE ?? "^(path_to_string p')) in
  let funcArgs1,funcArgs2 = cut_list (List.length args') funcArgs in
  let env = 
    List.fold_left2 (fun env x y ->Smap.add (path_to_string x) y env)
    Smap.empty funcArgs1 args'
  in
  (* On supprime les arguments possibles et on renomme ce qu'il faut *)
  let func = defunc_struct p' p env func in 
  (* sans oublier évidemment de renommer les arguments restant !!! *)
  let funcArgs2 = List.map (defunc_struct_path p' p env) funcArgs2 in
  AstT.Module (p,args@funcArgs2,Struct func)

let rec expr_T_to_D = function
  | AstT.Cst c ->
      Cst c
  | AstT.Var p ->
      Var (path_to_string p)
  | AstT.App (p,le) ->
      App ((path_to_string p),List.map (fun (b,e)->(b,expr_T_to_D e)) le)
  | AstT.Ref e ->
      Ref (expr_T_to_D e)
  | AstT.Binop (b,e1,e2) ->
      Binop (b,(expr_T_to_D e1),(expr_T_to_D e2))
  | AstT.Unop (u,e) ->
      Unop (u,(expr_T_to_D e))
  | AstT.IfThenElse (e,e1,e2) ->
      IfThenElse ((expr_T_to_D e),(expr_T_to_D e1),(expr_T_to_D e2))
  | AstT.LetIn (p,e1,e2) ->
      LetIn ((path_to_string p),(expr_T_to_D e1),(expr_T_to_D e2))
  | AstT.MatchWith (e,e1,p1,p2,e2) ->
      MatchWith ((expr_T_to_D e),(expr_T_to_D e1),
                 (path_to_string p1),(path_to_string p2),
                 (expr_T_to_D e2))

(** Fonction principale :
 * Défonctorise le programme (cf rapport) *)
let rec defunc_prog = function
  | [] -> []
  | x::s -> match x with
      | AstT.LetIgnore e ->
          (LetIgnore (expr_T_to_D e))::defunc_prog s
      | AstT.Let (p,args,e) ->
          let e = expr_T_to_D e in
          let p = path_to_string p in
          let args = List.map (fun (b,p)->(b,path_to_string p)) args in
            (Let (p,args,e))::defunc_prog s
      | AstT.Module (p,[],Struct prog) as m ->
          Hashtbl.add modules (path_to_string p) m;
          (defunc_prog prog)@(defunc_prog s)
      | AstT.Module (p,margs,Struct prog) as m -> 
          Hashtbl.add modules (path_to_string p) m;
          defunc_prog s
      | AstT.Module (p,args,Functor (p',args')) ->
          let m = defunc p args p' args' in
            defunc_prog (m::s)

