(* Time-stamp: <modified the 18/12/2012 (at 10:20) by Erwan Jahier> *)

(*
Source 2 source transformation :
élimine polymorphisme et surcharge

*)

open Lxm
open Lic

let dbg=Some (Verbose.get_flag "poly")

(** utile : on ne traite que les poly non externe *)
let node_is_poly ne =
   (Lic.node_is_poly ne) && not (Lic.node_is_extern ne)

let types_of_operands ops =
   match ops with OperLic vl ->
   List.flatten (List.map Lic.type_of_val_exp vl)

(* transforme un type match en pseudo-arg statique
   plus homogene ... *)
let static_args_of_matches matches =
   List.map (fun (tv, te) ->
      let tid = Lic.string_of_type_var tv in
      TypeStaticArgLic (tid, te)
   ) matches

let rec doit (inprg : LicPrg.t) : LicPrg.t =
   (* n.b. on fait un minumum d'effet de bord pour
      pas avoir trop d'acummulateur ... *)
   let res = ref LicPrg.empty in

   (** TRAITE LES TYPES *)
   let do_type k (te:Lic.type_) =
      res := LicPrg.add_type k te !res
   in
   LicPrg.iter_types do_type inprg;

   (** TRAITE LES CONSTANTES *)
   let do_const k (ec: Lic.const) =
      res := LicPrg.add_const k ec !res
   in 
   LicPrg.iter_consts do_const inprg ;

   (** TRAITE LES NOEUDS : *)
   let rec do_node k (ne:Lic.node_exp) = (
      if node_is_poly ne then
         (* pour les noeuds polymorphes/surchagés, on fait rien du tout *)
         Verbose.printf "### Warning: no code generated for polymorphic/overloaded node '%s'\n"
            (Lic.string_of_node_key ne.node_key_eff)
      else
         let def' = match ne.def_eff with
         | MetaOpLic _
         | ExternLic -> ne.def_eff 
         | AbstractLic _ -> assert false
         | BodyLic nb ->    BodyLic (do_body [] nb)
         in
         res := LicPrg.add_node k { ne with def_eff = def'} !res
   )
   (** TRAITEMENT DES BODY *)
   and do_body (m: Lic.type_matches) (nb: Lic.node_body) : Lic.node_body =
      (* parcours les expressions du body
         à la recherche d'appel de noeuds poly *)
      let do_assert a = Lxm.flagit (do_exp m a.it) a.src
      and do_eq eq =
         Lxm.flagit (
            fst eq.it,
            do_exp m (snd eq.it)
         ) eq.src
      in
      {
         asserts_eff = List.map do_assert nb.asserts_eff;
         eqs_eff = List.map do_eq nb.eqs_eff;
      }
   (* TRAITEMENT DES EXP : on passe en parametre un Lic.type_matches *)
   and do_exp
      (m: Lic.type_matches)
      (e: Lic.val_exp)
   : Lic.val_exp =
      let typ' = Lic.apply_type_matches m e.ve_typ in
      let core' = match e.ve_core with
      | CallByPosLic (posop, OperLic ops) -> (
         let ops' = OperLic (List.map (do_exp m) ops) in
         match posop.it with
         | PREDEF_CALL (pop,sas) ->
            (* 12/07 ICI version provisoise : 
               les macros predef n'existe plus ! (ce sont des calls classiques)
            *)
            assert (sas = []);
            CallByPosLic (posop, ops')
         | CALL nk ->
            let ne = LicPrg.find_node inprg nk.it in
            let nk' = if node_is_poly ne then (
               Verbose.exe ~flag:dbg (fun () ->
                  Printf.fprintf stderr "#DBG: CALL poly node %s\n"
                  (Lxm.details posop.src));
               let intypes = types_of_operands ops' in
               let (inpars, _) = Lic.profile_of_node_exp ne in
               let tmatches =  UnifyType.is_matched inpars intypes in
               {it=solve_poly tmatches nk.it ne; src=nk.src}
            ) else nk in
            let posop' = Lxm.flagit (CALL nk') posop.src in
            CallByPosLic (posop', ops')
         | x ->
            (* dans tout les autre cas, raf ? *)
            CallByPosLic (posop, ops')
      )
      | CallByNameLic (namop, idops) ->
         let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
         CallByNameLic (namop, idops')
      in
      { e with ve_core = core'; ve_typ = typ' }
   (* TRAITEMENT DES PARAMS STATIQUES *)
   and do_static_arg  
      (m: Lic.type_matches)
      (a: Lic.static_arg)
   : Lic.static_arg =
      match a with
      | ConstStaticArgLic (id, cst) -> a
      | TypeStaticArgLic (id, ty) -> a
      | NodeStaticArgLic (id, nk) -> (
         match nk with
         | (("Lustre",_),[]) -> a
         | _ ->
            let ne = LicPrg.find_node inprg nk in
            let nk' = solve_poly m nk ne in
            NodeStaticArgLic (id, nk')
      )
   (** Gros du boulot :
      soit un noeud poly, soit un profil attendu,
      fabrique s'il n'existe pas déjà, un noeud non poly adéquat ...
   *)
   and solve_poly 
      (tmatches: Lic.type_matches)
      (nk: Lic.node_key)
      (ne: Lic.node_exp)
   : Lic.node_key = 
      Verbose.printf ~flag:dbg
         "#DBG: L2lRmPoly.solve_poly nk='%s'\n#  prof=%s'\n# matches='%s'\n"
            (Lic.string_of_node_key nk)
            (Lic.string_of_type_profile (Lic.profile_of_node_exp ne))
            (Lic.string_of_type_matches tmatches)
      ;
      let do_var vi =
        let nt = Lic.subst_matches tmatches vi.var_type_eff in
        assert(not (Lic.type_is_poly nt));
        { vi with var_type_eff = nt }
      in
      (* nouvelle clé unique = ancienne + tmatches *)
      let (nid, sargs) = nk in
      let sargs' = sargs@(static_args_of_matches tmatches) in
      let nk' = (nid, sargs') in
      let def' = match ne.def_eff with
         | ExternLic
         | AbstractLic _ -> assert false 
         | MetaOpLic (bid, sas) -> MetaOpLic (bid, List.map (do_static_arg tmatches) sas)
         | BodyLic nb -> BodyLic(do_body tmatches nb)
      in 
      let ne' = {
         node_key_eff = nk';
         inlist_eff = List.map do_var ne.inlist_eff;
         outlist_eff = List.map do_var ne.outlist_eff;
         loclist_eff = (match ne.loclist_eff with
            | None -> None
            | Some vl -> Some (List.map do_var vl)
         );
         def_eff = def';
         has_mem_eff = ne.has_mem_eff;
         is_safe_eff = ne.is_safe_eff;
      } in
      res := LicPrg.add_node nk' ne' !res;
      nk'
   in
   (*LET's GO *)
   LicPrg.iter_nodes do_node inprg;
   !res