(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
(*                                                                     *)
(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

open Parsetree

let silent v = String.length v > 0 && v.[0] = '_';;

let add_vars tbl (vll1, vll2) =
  let add_var (v, _loc, used) = Hashtbl.add tbl v used in
  List.iter add_var vll1;
  List.iter add_var vll2;
;;

let rm_vars tbl (vll1, vll2) =
  let rm_var (v, _, _) = Hashtbl.remove tbl v in
  List.iter rm_var vll1;
  List.iter rm_var vll2;
;;

let w_lax x = Warnings.Unused_var x;;
let w_strict x = Warnings.Unused_var_strict x;;
let w_either x = if Warnings.is_active (w_lax x) then w_lax x else w_strict x;;

let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
  let check_rm_var kind (v, loc, used) =
    if not !used && not (silent v)
    then Location.print_warning loc ppf (kind v);
    Hashtbl.remove tbl v;
  in
  List.iter (check_rm_var w_strict) vlul_pat;
  List.iter (check_rm_var w_either) vlul_as;
;;

let check_rm_let ppf tbl vlulpl =
  let check_rm_one flag (v, loc, used) =
    Hashtbl.remove tbl v;
    flag && (silent v || not !used)
  in
  let warn_var w_kind (v, loc, used) =
    if not (silent v) && not !used
    then Location.print_warning loc ppf (w_kind v)
  in
  let check_rm_pat (def, def_as) =
    let def_unused = List.fold_left check_rm_one true def in
    let all_unused = List.fold_left check_rm_one def_unused def_as in
    List.iter (warn_var (if all_unused then w_either else w_strict)) def;
    List.iter (warn_var w_either) def_as;
  in
  List.iter check_rm_pat vlulpl;
;;

let rec get_vars ((vacc, asacc) as acc) p =
  match p.ppat_desc with
  | Ppat_any -> acc
  | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
  | Ppat_alias (pp, v) ->
      get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
  | Ppat_constant _ -> acc
  | Ppat_tuple pl -> List.fold_left get_vars acc pl
  | Ppat_construct (_, po, _) -> get_vars_option acc po
  | Ppat_variant (_, po) -> get_vars_option acc po
  | Ppat_record ipl ->
      List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
  | Ppat_array pl -> List.fold_left get_vars acc pl
  | Ppat_or (p1, _p2) -> get_vars acc p1
  | Ppat_constraint (pp, _) -> get_vars acc pp
  | Ppat_type _ -> acc

and get_vars_option acc po =
  match po with
  | Some p -> get_vars acc p
  | None -> acc
;;

let get_pel_vars pel =
  List.map (fun (p, _) -> get_vars ([], []) p) pel
;;

let rec structure ppf tbl l =
  List.iter (structure_item ppf tbl) l

and structure_item ppf tbl s =
  match s.pstr_desc with
  | Pstr_eval e -> expression ppf tbl e;
  | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
  | Pstr_primitive _ -> ()
  | Pstr_type _ -> ()
  | Pstr_exception _ -> ()
  | Pstr_exn_rebind _ -> ()
  | Pstr_module (_, me) -> module_expr ppf tbl me;
  | Pstr_recmodule stml ->
      List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
  | Pstr_modtype _ -> ()
  | Pstr_open _ -> ()
  | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
  | Pstr_class_type _ -> ()
  | Pstr_include _ -> ()

and expression ppf tbl e =
  match e.pexp_desc with
  | Pexp_ident (Longident.Lident id) ->
      begin try (Hashtbl.find tbl id) := true;
      with Not_found -> ()
      end;
  | Pexp_ident _ -> ()
  | Pexp_constant _ -> ()
  | Pexp_let (recflag, pel, e) ->
      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
  | Pexp_function (_, eo, pel) ->
      expression_option ppf tbl eo;
      match_pel ppf tbl pel;
  | Pexp_apply (e, lel) ->
      expression ppf tbl e;
      List.iter (fun (_, e) -> expression ppf tbl e) lel;
  | Pexp_match (e, pel) ->
      expression ppf tbl e;
      match_pel ppf tbl pel;
  | Pexp_try (e, pel) ->
      expression ppf tbl e;
      match_pel ppf tbl pel;
  | Pexp_tuple el -> List.iter (expression ppf tbl) el;
  | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
  | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
  | Pexp_record (iel, eo) ->
      List.iter (fun (_, e) -> expression ppf tbl e) iel;
      expression_option ppf tbl eo;
  | Pexp_field (e, _) -> expression ppf tbl e;
  | Pexp_setfield (e1, _, e2) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
  | Pexp_array el -> List.iter (expression ppf tbl) el;
  | Pexp_ifthenelse (e1, e2, eo) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
      expression_option ppf tbl eo;
  | Pexp_sequence (e1, e2) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
  | Pexp_while (e1, e2) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
  | Pexp_for (id, e1, e2, _, e3) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
      let defined = ([ (id, e.pexp_loc, ref false) ], []) in
      add_vars tbl defined;
      expression ppf tbl e3;
      check_rm_vars ppf tbl defined;
  | Pexp_constraint (e, _, _) -> expression ppf tbl e;
  | Pexp_when (e1, e2) ->
      expression ppf tbl e1;
      expression ppf tbl e2;
  | Pexp_send (e, _) -> expression ppf tbl e;
  | Pexp_new _ -> ()
  | Pexp_setinstvar (_, e) -> expression ppf tbl e;
  | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
  | Pexp_letmodule (_, me, e) ->
      module_expr ppf tbl me;
      expression ppf tbl e;
  | Pexp_assert e -> expression ppf tbl e;
  | Pexp_assertfalse -> ()
  | Pexp_lazy e -> expression ppf tbl e;
  | Pexp_poly (e, _) -> expression ppf tbl e;
  | Pexp_object cs -> class_structure ppf tbl cs;

and expression_option ppf tbl eo =
  match eo with
  | Some e -> expression ppf tbl e;
  | None -> ()

and let_pel ppf tbl recflag pel body =
  match recflag with
  | Asttypes.Recursive ->
      let defined = get_pel_vars pel in
      List.iter (add_vars tbl) defined;
      List.iter (fun (_, e) -> expression ppf tbl e) pel;
      begin match body with
      | None ->
          List.iter (rm_vars tbl) defined;
      | Some f ->
          f ppf tbl;
          check_rm_let ppf tbl defined;
      end;
  | _ ->
      List.iter (fun (_, e) -> expression ppf tbl e) pel;
      begin match body with
      | None -> ()
      | Some f ->
          let defined = get_pel_vars pel in
          List.iter (add_vars tbl) defined;
          f ppf tbl;
          check_rm_let ppf tbl defined;
      end;

and match_pel ppf tbl pel =
  List.iter (match_pe ppf tbl) pel

and match_pe ppf tbl (p, e) =
 let defined = get_vars ([], []) p in
  add_vars tbl defined;
  expression ppf tbl e;
  check_rm_vars ppf tbl defined;

and module_expr ppf tbl me =
  match me.pmod_desc with
  | Pmod_ident _ -> ()
  | Pmod_structure s -> structure ppf tbl s
  | Pmod_functor (_, _, me) -> module_expr ppf tbl me
  | Pmod_apply (me1, me2) ->
      module_expr ppf tbl me1;
      module_expr ppf tbl me2;
  | Pmod_constraint (me, _) -> module_expr ppf tbl me

and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr

and class_expr ppf tbl ce =
  match ce.pcl_desc with
  | Pcl_constr _ -> ()
  | Pcl_structure cs -> class_structure ppf tbl cs
  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce
  | Pcl_apply (ce, _) -> class_expr ppf tbl ce
  | Pcl_let (recflag, pel, ce) ->
      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
  | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;

and class_structure ppf tbl (p, cfl) =
  let defined = get_vars ([], []) p in
  add_vars tbl defined;
  List.iter (class_field ppf tbl) cfl;
  check_rm_vars ppf tbl defined;

and class_field ppf tbl cf =
  match cf with
  | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
  | Pcf_val (_, _, e, _) -> expression ppf tbl e;
  | Pcf_virt _ -> ()
  | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
  | Pcf_cstr _ -> ()
  | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
  | Pcf_init e -> expression ppf tbl e;
;;

let warn ppf ast =
  if Warnings.is_active (w_lax "") || Warnings.is_active (w_strict "")
  then begin
    let tbl = Hashtbl.create 97 in
    structure ppf tbl ast;
  end;
  ast
;;