%{
(* parservhc.mly, Objective Caml version 3.08.1 *)
(* syntaxe avec verification des conditions de contexte,
   methode de la table des symboles *)

open Print
open Aintv
open Parse_exceptions

type 'a chose = Rien | Chose of 'a
type typage_determine = Entier | Booleen
type typage = Determine of typage_determine | Indetermine of boite_typage and boite_typage = typage chose ref
let entier = ref (Chose (Determine Entier))
and booleen = ref (Chose (Determine Booleen))
and indetermine () = ref Rien

type appel = {a_f : string; a_type_vars : boite_typage list ; a_type_retour : boite_typage; a_pos : int}
type contexte = Variable of (string * boite_typage * int) | Appel of appel

type expr2 = {expr : expr; e_ctxt : contexte list; e_type : boite_typage}
type liste_args = {exprlist : expr2 list; l_ctxt : contexte list}
type elem_aff = {fundef : function_declaration; pos : int; f_type_vars : boite_typage list; f_type_retour : boite_typage; appels : appel list}
type affs = {elem_affs : elem_aff list; aretes : (string * string) list}

let rec reduire_typage t = match !t with
  | Rien -> t,Rien
  | Chose (Determine t1) -> t,Chose t1
  | Chose (Indetermine t1) -> reduire_typage t1

let verifier_typage t0 t = let (b0,u0),(b,u) = reduire_typage t0, reduire_typage t in 
 match u0,u with
   | Rien, Rien when b0 == b -> ()
   | Rien, Rien -> ( b := Chose (Indetermine b0)) (* tres important de mettre b a gauche et non pas b0 *)
   | Chose t1, Rien -> (b := Chose (Determine t1) )
   | Rien, Chose t1 -> (  b0 := Chose (Determine t1) )
   | Chose t1, Chose t2 when t2 <> t1 -> raise Type_mismatch
   | _ -> ()

let rec type_param p = function
  | [] -> Rien
  | ((FPVAL v), t) :: _ when v = p -> Chose t
  | ((FPNECDYN v), t) :: _ when v = p -> Chose t
  | ((FPNECSTAT v), t) :: _ when v = p -> Chose t
  | _ :: q -> type_param p q

let filtrer_contexte_local vars liste =
let rec aux accu = function
| [] -> accu
| (Appel a) :: q -> aux (a :: accu) q
| (Variable (v, t, pos)) :: q ->
( match type_param v vars with
   | Chose t2 -> (verifier_typage t t2; aux accu q)
   | Rien -> raise (Undefined_variable (v, pos))
)
in aux [] liste

let rec verifier_contexte_global foncts = function
| [] -> ()
| (Variable (s, _, i)) :: _ -> raise (Variable_in_body (s,i))
| (Appel {a_f = f; a_type_vars = l; a_type_retour = t; a_pos = pos}) :: q ->
begin
 let rec mem2 = function
 | [] -> raise (Undefined_function (f, pos))
 | g::_ when f = fst g.fundef ->
     begin
       let l0 = List.map reduire_typage g.f_type_vars and b0,t0 = reduire_typage g.f_type_retour in
       let rec aux = function
         | [],[] -> ()
         | (a,_)::q, b::r -> (verifier_typage a b; aux (q,r))
         | _ -> raise (Function_call_mismatch(f, pos))
       in aux (l0, l);
       verifier_typage b0 t;

       if t0 = Rien then b0 := Rien else ();
       let rec aux2 = function
         | [] -> ()
         | (b, Rien) :: q -> (b := Rien; aux2 q)
         | _ :: q -> aux2 q
       in aux2 l0
     end
 | _::r -> mem2 r
 in mem2 foncts; verifier_contexte_global foncts q
end

let afficher_contexte _ = () (* List.iter (function
| Variable v -> print_string ("Variable " ^ v ^ "\n")
| Appel (f, n) -> print_string ("Appel " ^ f ^ ", "  ^ string_of_int n ^ " arg\n")
) *)

let rec retirer_doublons = function
  |  [] -> []
  | a::q -> let rec aux = function
      | [] -> []
      | b::r when b == a || b = a -> aux r
      | b::r -> b::(aux r)
    in aux q

let ordre_typage foncts aretes = (* try *)
  let n = (List.length foncts) in
  let noms = if n = 0 then [| |] else Array.create n (List.hd foncts) in
  let l_numeros = ref [] in
  let rec remplir_numeros i = function
    | [] -> ()
    | nom :: q -> (l_numeros := (nom, i) :: !l_numeros; noms.(i) <- nom ; remplir_numeros (i + 1) q)
  in remplir_numeros 0 foncts;
  let numeros x = List.assoc x !l_numeros in (* egalite logique *)
  let matrice = Array.create_matrix n n false in
  let cocher_arete (f,g) = matrice.(numeros f).(numeros g) <- true
  in List.iter cocher_arete aretes (* retirer_doublons aretes *);
  for x = 0 to n-1
  do
   for x1 = 0 to n-1
   do
    if matrice.(x1).(x)
    then for x2 = 0 to n-1
    do
     if matrice.(x).(x2)
     then matrice.(x1).(x2) <- true
    done
   done
  done;
  let visites = Array.create n false and composantes = ref [] in
  for x = 0 to n - 1
  do
   if not visites.(x) then
   let comp = ref [x] in begin
    for y = x + 1 to n - 1
    do
     if matrice.(x).(y) && matrice.(y).(x) then
       begin
        visites.(y) <- true;
        comp := y :: !comp
       end
    done;
    composantes := !comp :: !composantes;
   end
  done;
  let ordre comp1 comp2 = if comp1 = comp2 then 0 else if matrice.(List.hd comp1).(List.hd comp2) then 1 else -1 
  in let compo_triees = List.sort ordre !composantes in
  List.map (List.map (fun i -> noms.(i))) compo_triees (*
  let rec final accu = function
    | [] -> accu 
    | ([]::r) -> final accu r 
    | ((a::q)::r) -> final ((noms.(a))::accu) (q::r) 
  in  final [] compo_triees *)

(* with e -> (print_string "Exception dans ordre_typage" ; raise e) *)
(*
let completer_ordre foncts =
  let rechercher_fonction f = 
    let rec aux = function
      | [] -> failwith "completer_ordre cas impossible"
      | g::_ when fst g.fundef = f -> g
      | _::q -> aux q
    in aux foncts
  in List.map rechercher_fonction 
*)
let rec iter2 f g = function
  | [] -> ()
  | [a] -> ignore (f a)
  | a::q -> (ignore (f a) ; ignore (g ()) ; iter2 f g q)

let afficher_nom_type = 
  let types_indet = ref [] and compte_types_indet = ref 0 in
  let type_indet ty = try List.assq ty !types_indet with _ -> (incr compte_types_indet; types_indet := (ty, !compte_types_indet) :: !types_indet ; !compte_types_indet)
  in fun ty ->
    let b,u = reduire_typage ty in
    match u with
      | Rien -> print_string ("Indet" ^ string_of_int (type_indet b))
      | Chose Entier -> print_string "Entier"
      | Chose Booleen -> print_string "Booleen"

let afficher_typages = List.iter (fun f -> (print_string (fst f.fundef) ; print_string " ( " ; iter2 afficher_nom_type (fun () -> print_string ",") f.f_type_vars ; print_string " ) = "; afficher_nom_type f.f_type_retour ; print_newline ()))

let retyper_fonctions foncts aretes = (* print_string "Retypage."; *)
  let f2 = List.map (fun f -> fst f.fundef) foncts in
  let ordre2 = ordre_typage f2 aretes in
(*  let ordre = completer_ordre foncts ordre2 in *)
  let rec aux_compo compo =
  print_string "\nTypage de la composante connexe : ";
  let rec aux_foncts = function
    | [] -> ()
    | f2::q ->
        begin
          print_string f2; flush stdout;
          let rec fonction g = function
            | [] -> failwith "retyper_fonctions : cas impossible"
            | h::_ when fst h.fundef = g -> h
            | _::r -> fonction g r
          in let f = fonction f2 foncts  in
          let rec aux_appels = function
            | [] -> ()
            | ({a_f = gn; a_pos = pos} as a) :: r when not (List.mem gn compo) ->
                begin

                  let g = fonction gn foncts in
       let l0 = List.map reduire_typage g.f_type_vars and b0,t0 = reduire_typage g.f_type_retour and l = a.a_type_vars and t = a.a_type_retour in
       let duplique = List.map ( function b,Chose t -> b,ref (Chose(Determine t)) | b,Rien -> b, indetermine () ) l0 in
       let b1 = match t0 with
         | Rien -> (try (List.assq b0 duplique) with _ -> indetermine ())
         | Chose t -> ref (Chose (Determine t))
       in
       let l1 = List.map (function b,t -> List.assq b duplique, t) l0 in
       let rec aux = function
         | [],[] -> ()
         | (a,_)::q, b::r -> (verifier_typage a b; aux (q,r))
         | _ -> raise (Function_call_mismatch(f2, pos))
       in aux (l1, l);

       verifier_typage b1 t;

       if t0 = Rien then b0 := Rien else ();
       let rec aux2 = function
         | [] -> ()
         | (b, Rien) :: q -> (b := Rien; aux2 q)
         | _ :: q -> aux2 q
       in aux2 l0

                end

            | ({a_f = gn; a_pos = pos} as a) :: r -> let g = fonction gn foncts in
              begin 
                let rec aux_types = function
                  | [],[] -> ()
                  | t1::r1, t2::r2 -> (verifier_typage t1 t2 ; aux_types (r1,r2))
                  | _ -> raise (Function_call_mismatch (gn, pos))
                in
                (* print_string " Appel "; print_string a.a_f; print_string "("; iter2 afficher_nom_type (fun _ -> print_string " , ") a.a_type_vars ; print_string " ) = ";afficher_nom_type (a.a_type_retour); flush stdout; *) aux_types (g.f_type_vars, a.a_type_vars); verifier_typage g.f_type_retour a.a_type_retour; aux_appels r
              end 
          in (*print_int (List.length f.appels);*) aux_appels f.appels; aux_foncts q
        end
  in aux_foncts compo
  in List.iter aux_compo ordre2

%}

%token T_LET T_EQ T_IN T_AND T_LESS T_ADD T_SUB T_MUL T_DIV T_NOT T_IF T_THEN T_ELSE T_FI T_TRUE T_FALSE T_VALUE T_LAZYDYN T_LAZYSTAT
%token <string> INT
%token <string * int> IDENT
%token LPAR RPAR COMMA SEMICOLON DOUBLESEMICOLON
%start program
%type <Aintv.prog> program
%type <Aintv.prog> program_0
%type <expr2> expr 
%type <expr2> expr_1
%type <expr2> expr_2
%type <expr2> expr_3
%type <expr2> expr_4
%type <expr2> expr_5
%type <expr2> atome
%type <liste_args> liste_args
%type <affs> affectations
%type <elem_aff> elem_aff
%type <(fpar * boite_typage) list> liste_vars
%type <fpar * (string * int)> var

%%

/* Regles de grammaire et actions semantiques */
program:
        | program_0 DOUBLESEMICOLON { $1 }
;

program_0:
	| expr { [] , (verifier_contexte_global [] $1.e_ctxt; $1.expr) }
	| T_LET affectations T_IN expr { 
            let (expr, vars1)= $4.expr, $4.e_ctxt  and foncts = $2.elem_affs and aretes = $2.aretes in let vars = vars1 in  
retyper_fonctions foncts aretes;verifier_contexte_global foncts vars; print_newline ();
  print_string "Types des fonctions : \n"; afficher_typages foncts; (List.map (fun e -> e.fundef) foncts, expr)}
;

expr:
          expr_1 { $1 }
;

expr_1:
          expr_1 T_AND expr_2 { verifier_typage booleen $1.e_type; verifier_typage booleen $3.e_type; {expr = AND ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt; e_type = booleen} }
	  | expr_2 { $1 }
;

expr_2:
          expr_2 T_LESS expr_3 { verifier_typage entier $1.e_type; verifier_typage entier $3.e_type; {expr = LESS ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt; e_type = booleen} }
	  | expr_2 T_EQ expr_3 {verifier_typage $1.e_type $3.e_type ; {expr =EQUAL ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt; e_type = booleen} }
	  | expr_3 { $1 }
;

expr_3:
          expr_3 T_ADD expr_4 { verifier_typage entier $1.e_type; verifier_typage entier $3.e_type; {e_type = entier;expr = ADD ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt} }
	  | expr_3 T_SUB expr_4 { verifier_typage entier $1.e_type; verifier_typage entier $3.e_type; {e_type = entier;expr = SUB ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt} }
	  | expr_4 { $1 }
;

expr_4:	  
	  expr_4 T_MUL expr_5 {  verifier_typage entier $1.e_type; verifier_typage entier $3.e_type; {e_type = entier;expr = MULT ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt}}
	  | expr_4 T_DIV expr_5 {  verifier_typage entier $1.e_type; verifier_typage entier $3.e_type; {e_type = entier;expr = DIV ($1.expr, $3.expr); e_ctxt = $1.e_ctxt @ $3.e_ctxt} }
	  | expr_5 { $1 }
;

expr_5:
	  atome { $1 }
;

atome:
	  LPAR expr RPAR { $2 }
	  | INT { {expr = CST $1; e_ctxt = []; e_type = entier} }
	  | T_SUB INT { { expr =  CST ("-" ^ $2); e_ctxt = []; e_type = entier} }
	  | T_TRUE { {expr = CST "true"; e_ctxt = []; e_type = booleen} }
	  | T_FALSE { {expr = CST "false"; e_ctxt = []; e_type = booleen} }
	  | IDENT { let p = indetermine ()  in {expr = VAR (fst $1); e_ctxt = [Variable (fst $1,p,snd $1)]; e_type = p } }
	  | IDENT LPAR RPAR {let p = indetermine () in { e_type = p; expr = CALL ((fst $1), []); e_ctxt = [Appel {a_f = fst $1 ; a_type_vars = [] ; a_type_retour = p ; a_pos = snd $1}]} }
	  | IDENT LPAR liste_args RPAR {let p = indetermine () in { e_type = p; expr = CALL ((fst $1), List.map (fun e -> e.expr) $3.exprlist); e_ctxt = Appel {a_f = fst $1; a_type_vars = List.map (fun e -> e.e_type) $3.exprlist ; a_type_retour = p ; a_pos = snd $1} :: $3.l_ctxt } }
          | T_NOT LPAR expr RPAR { verifier_typage booleen $3.e_type; { expr = NOT ($3.expr); e_ctxt = $3.e_ctxt ; e_type = booleen} }
	  | T_IF expr T_THEN expr T_ELSE expr T_FI 
{ verifier_typage booleen $2.e_type; verifier_typage $4.e_type $6.e_type; { expr = IF ($2.expr, ($4.expr, $6.expr)); e_ctxt = ($2.e_ctxt @ $4.e_ctxt) @ $6.e_ctxt ; e_type = $6.e_type } }
;

liste_args:
	   expr { {exprlist = [ $1 ]; l_ctxt = $1.e_ctxt }}
	  | expr COMMA liste_args { { exprlist = $1 :: $3.exprlist; l_ctxt = $1.e_ctxt @ $3.l_ctxt } }
;

affectations:
	   elem_aff { 
{
 elem_affs = [ $1 ];
 aretes =  List.map (function {a_f = g} -> (fst $1.fundef, g)) $1.appels ;
} 
           }
         
          | elem_aff SEMICOLON { 
{
 elem_affs = [ $1 ];
 aretes = List.map (function {a_f = g} -> (fst $1.fundef, g)) $1.appels ;
} 
           }

	  | elem_aff SEMICOLON affectations { 

              let rec mem2 = function
                | [] -> {
 elem_affs = $1 :: $3.elem_affs ;
 aretes =  (List.map (function {a_f = g} -> (fst $1.fundef, g)) $1.appels) @ $3.aretes ;
                } 
                | a :: _ when fst a.fundef = fst $1.fundef -> raise (Double_fundef (fst a.fundef, $1.pos))
                | _ :: q -> mem2 q
              in mem2 $3.elem_affs
           }

;

elem_aff:
	  IDENT LPAR RPAR T_EQ expr {
{
  fundef = (fst $1, ([], $5.expr));
  appels = filtrer_contexte_local [] $5.e_ctxt;
  pos = snd $1;
  f_type_vars = [];
  f_type_retour = $5.e_type
}
          }

	  | IDENT LPAR liste_vars RPAR T_EQ expr {

{
  fundef = (fst $1, (List.map fst $3, $6.expr));
  appels = filtrer_contexte_local $3 $6.e_ctxt;
  pos = snd $1;
  f_type_retour = $6.e_type;
  f_type_vars = List.map snd $3;
}
            }
;

liste_vars:
          var { [ fst $1 , indetermine ()] }
          | var COMMA liste_vars { let v,(n,pos) = $1 in match type_param n $3 with Chose _ -> raise (Double_argdef (n,pos)) | Rien -> (v, indetermine ()) :: $3 }
;

var:
          | IDENT {FPNECSTAT (* FPVAL *) (fst $1), $1 }
          | T_VALUE IDENT {FPVAL (fst $2), $2}
          | T_LAZYSTAT IDENT {FPNECSTAT (fst $2), $2}
          | T_LAZYDYN IDENT {FPNECDYN (fst $2), $2}

;

%%