(* File: pf_shadow.ml

   An ocaml filter wich warns on value shadowing
   (when a binding silently remplace an outer binding).

   Copyright (C) 2007-
     bluestorm <bluestorm.dylc@gmail.com>

    This program is free software: you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation, either
    version 2 of the License, or (at your option) any later version,
    with the special exception on linking described in the file
    LICENSE.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Library General Public License (file LICENSE) for more details.

   Compilation :
     ocamlfind ocamlc -syntax camlp4o -package camlp4.lib,camlp4.quotations -c pf_shadow.ml
   
   Use :
     camlp4o pf_shadow.cmo your_file.ml
*)

open Camlp4
open Sig

module Id = struct
  let name = "pf_shadow"
  let version = "0.1"
  let description = "Warns on binding shadowing"
end

module Make (Filters : AstFilters) = struct
  open Filters
  
  module Warn = struct
    (* Warnings : borrowed from OCamlInitSyntax.ml *)
    let print_warning loc txt = Format.eprintf "<W> %a: %s@." Ast.Loc.print loc txt
  end

  let check = object (self : 'self)
    inherit Ast.fold as super

    val bound_vars = []

    method bound_vars = bound_vars

    method set_bound_vars vars = {< bound_vars = vars >}

    method add_binding id loc =
      if List.mem_assoc id bound_vars then
        Warn.print_warning loc
          (Printf.sprintf "shadowing binding '%s' from %s" id
             (Ast.Loc.to_string (List.assoc id bound_vars)));
      self#set_bound_vars ((id, loc) :: bound_vars)

    method binding = function
    | <:binding< $a$ and $b$ >> ->
        let rewind obj = obj#set_bound_vars bound_vars in
        rewind ((rewind (self#binding a))#binding b)
    | other -> super#binding other 

    method patt = function
    | <:patt@loc< $lid:id$ >> -> self#add_binding id loc
    | <:patt< $a$ | $b$ >> ->
        let rewind obj = obj#set_bound_vars bound_vars in
        rewind ((rewind (self#patt a))#patt b)
    | other -> super#patt other

    method fold_recursive bindings =
      let rec fold obj exprs = function
      | <:binding< $p$ = $e$ >> -> (obj#patt p), (e :: exprs)
      | <:binding< $a$ and $b$ >> ->
          let obj', exprs' = fold obj exprs a in
          fold obj' exprs' b
      | other -> obj, exprs
      in
      let obj, exprs = fold self [] bindings in
      List.fold_left (fun obj e -> obj#expr e) obj (List.rev exprs)
    

    method expr = function
    | <:expr< let rec $bi$ in $e$ >> -> (self#fold_recursive bi)#expr e
    | other -> super#expr other

    method str_item = function
    | <:str_item< value rec $bi$ >> -> self#fold_recursive bi
    | other -> super#str_item other
  end

  let () = register_str_item_filter
    (fun str_item -> 
       let _ = check#str_item str_item in
       str_item)
end

let module M = Register.AstFilter(Id)(Make) in ()