Cleanup in the compiler hooks

ocamlwizard/refactor/findName.ml

@@ -188,6 +188,7 @@ let get_occurrences env idents lidents paths s =
     (find_all_occurrences env idents paths s)
 *)
 
+(*
 let reverse t =
   let r = Longident.LongidentTbl.create 1000 in
   Env.PathTbl.iter
@@ -196,6 +197,7 @@ let reverse t =
 	Longident.LongidentTbl.add r lid (sort, p, env))
     t;
   r
+*)
 
 let kind2kind = function
   | Env.Value -> value_ops
@@ -222,34 +224,38 @@ let kind2str = function
 
 let rec check_same = function
   | [x] -> x
-  | (kind, p, env) :: ((kind', p', env') :: _ as l) ->
+  | (kind, env) :: ((kind', env') :: _ as l) ->
     if kind <> kind' then
       failwith (kind2str kind ^ " <> " ^ kind2str kind');
-    if p != p' then failwith "different paths";
     if env != env' then failwith "different environments";
     check_same l
   | [] -> invalid_arg "check_same"
 
-let get_occurrences env idents lidents paths s =
-  let lid2path = reverse paths in
+let get_occurrences lid2loc lid2env s =
   (* We should check that keys are bound only once *)
   Longident.LongidentTbl.fold
     (fun lid loc acc ->
-      match Longident.LongidentTbl.find_all lid2path lid with
+      let envs = Env.LongidentTbl.find_all lid2env lid in
+      let envs = List.filter (function kind, _ -> kind <> Env.Annot) envs in
+      match envs with
 	| [] ->
-	  debugln "lident %s has no environment" (lid_to_str lid);
+	  Location.print Format.std_formatter loc;
+	  Printf.printf "Warning: lident %s has no environment\n" (lid_to_str lid);
+(*
+	  failwith ("lident" ^ lid_to_str lid ^ "has no environment");
+*)
 	  acc
 	| l ->
 	  debugln "testing %s" (lid_to_str lid);
-	  let kind, p, env = check_same l in
+	  let kind, env = check_same l in
 	  if kind = Env.Value || kind = Env.Type then
 	    (loc, (env, kind)) :: acc
 	  else
 	    acc)
-    lidents
+    lid2loc
     []
 
-let extract_longident (loc, s, (env, occ)) =
+let extract_longident (loc, text, (env, occ)) =
   let kind = match occ with
     | Env.Value -> value_ops
     | Env.Module -> module_ops
@@ -258,16 +264,16 @@ let extract_longident (loc, s, (env, occ)) =
   in
   let ast =
     try
-      kind.parse_lid s
+      kind.parse_lid text
     with _ ->
-      failwith ("error parsing the following ident: " ^ s)
+      failwith ("error parsing the following ident: " ^ text)
   in
     (loc, ast, (env, kind))
 
-let get_lids env file idents lidents paths ast =
+let get_lids env file lidents paths ast =
   List.map
     extract_longident
-    (source_locations file (get_occurrences env idents lidents paths ast))
+    (source_locations file (get_occurrences lidents paths ast))
 
 let ident_of_subtree = function
   | `pattern {pat_desc = Tpat_var id}

ocamlwizard/refactor/findName.mli

@@ -27,7 +27,7 @@ val get_occurrences :
 val get_lids :
   Env.t ->
   string ->
-  Location.string_table -> Location.t Longident.LongidentTbl.t -> Env.path2env ->
+  Location.t Longident.LongidentTbl.t -> Env.lid2env ->
   [ `signature of Typedtree.signature | `structure of Typedtree.structure ]->
   (Location.t * Longident.t * (Env.t * Resolve.specifics)) list
 

ocamlwizard/refactor/rename.ml

@@ -231,7 +231,7 @@ let backup file =
       Edit.cp file backup
 
 (* Rename an ident in a structure file, with given ast. *)
-let rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) =
+let rename_in_file env renamed_kind id name' file (s, idents, lid2loc, paths) =
 
   (* Collect constraints requiring simultaneous renaming *)
   let constraints, includes = collect_signature_inclusions (`structure s) in
@@ -250,7 +250,7 @@ let rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) =
   check_renamed_implicit_references renamed_kind ids name' implicit_refs;
 
   (* Collect all lids *)
-  let lids = get_lids env file idents lidents paths (`structure s) in
+  let lids = get_lids env file lid2loc paths (`structure s) in
 
   (* Check that our new name will not capture other occurrences *)
   check_lids renamed_kind ids name' lids;

parsing/longident.ml

@@ -50,7 +50,9 @@ module LongidentTbl = Hashtbl.Make
     let hash = Hashtbl.hash
    end)
 
-let longident_table : Location.t LongidentTbl.t option ref = ref None
+type lid2loc = Location.t LongidentTbl.t
+
+let longident_table : lid2loc option ref = ref None
 
 let record_longident_locations () =
   longident_table := Some (LongidentTbl.create 1000)
@@ -60,8 +62,12 @@ let flush_longidents () =
     longident_table := None;
     idents
 
-let longident loc i =
-  (match !longident_table with
+let add_longident loc i =
+  match !longident_table with
     | Some t -> LongidentTbl.add t i loc
-    | None -> ());
-  i
+    | None -> ()
+
+let remove_longident i =
+  match !longident_table with
+    | Some t -> LongidentTbl.remove t i
+    | None -> ()

parsing/longident.mli

@@ -25,8 +25,11 @@ val parse: string -> t
 
 module LongidentTbl : Hashtbl.S with type key = t
 
+type lid2loc = Location.t LongidentTbl.t
+
 val record_longident_locations : unit -> unit
 
-val flush_longidents : unit -> Location.t LongidentTbl.t option
+val flush_longidents : unit -> lid2loc option
 
-val longident : Location.t -> t -> t
+val add_longident : Location.t -> t -> unit
+val remove_longident : t -> unit

parsing/parse.mli

@@ -21,9 +21,7 @@ val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
 
 val implementation' :
   Lexing.lexbuf ->
-  Parsetree.structure * Location.string_table option
-  * Location.t Longident.LongidentTbl.t option
+  Parsetree.structure * Location.string_table option * Longident.lid2loc option
 val interface' :
   Lexing.lexbuf ->
-  Parsetree.signature * Location.string_table option
-  * Location.t Longident.LongidentTbl.t option
+  Parsetree.signature * Location.string_table option * Longident.lid2loc option

parsing/parser.mly

@@ -48,19 +48,20 @@ let mkcf d =
 let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
 let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
 
-
-(*
-let ghlongident = longident Location.none
-let ghlident = lident Location.none
-*)
+let longident loc lid = add_longident loc lid ; lid
 
 let mkoperator name pos =
   { pexp_desc = Pexp_ident(longident (rhs_loc pos) (Lident name));
     pexp_loc = rhs_loc pos }
 
 let lident i = longident (symbol_rloc ()) (Lident i)
-let ldot lid i = longident (symbol_rloc ()) (Ldot (lid, i))
-let lapply lid lid' = longident (symbol_rloc ()) (Lapply (lid, lid'))
+let ldot lid i =
+  remove_longident lid;
+  longident (symbol_rloc ()) (Ldot (lid, i))
+let lapply lid lid' =
+  remove_longident lid;
+  remove_longident lid';
+  longident (symbol_rloc ()) (Lapply (lid, lid'))
 
 (*
   Ghost expressions and patterns:

typing/env.ml

@@ -491,11 +491,11 @@ let lookup_simple proj1 proj2 lid env =
   | Lapply(l1, l2) ->
       raise Not_found
 
-module PathTbl = Hashtbl.Make
+module LongidentTbl = Hashtbl.Make
   (struct
-     type t = Path.t
-     let equal = ( == )
-     let hash = Hashtbl.hash
+    type t = Longident.t
+    let equal = ( == )
+    let hash = Hashtbl.hash
    end)
 
 type path_sort =
@@ -509,41 +509,39 @@ type path_sort =
   | Class
   | Cltype
 
-type path2env = (path_sort * Longident.t * t) PathTbl.t
+type lid2env = (path_sort * t) LongidentTbl.t
 
-let path_table = ref None
+let lid2env = ref None
 
 let record_path_environments () =
-  path_table := Some (PathTbl.create 1000)
+  lid2env := Some (LongidentTbl.create 1000)
 
 let flush_paths () =
-  let paths = !path_table in
-    path_table := None;
+  let paths = !lid2env in
+    lid2env := None;
     paths
 
-let record p sort lid env =
-  match !path_table with
-    | Some t -> PathTbl.add t p (sort, lid, env)
+let record sort lid env =
+  match !lid2env with
+    | Some t ->
+      if
+	(try
+	   let s, e = LongidentTbl.find t lid in
+	   s != sort || e != env
+	 with Not_found -> true)
+      then
+	LongidentTbl.add t lid (sort, env)
     | None -> ()
 
-(*
-let lookup_module lid env =
-  let path, _ as res = lookup_module lid env in
-    record path env;
-    res
-*)
-
 let recording sort lookup lid env =
-  let path, _ as res = lookup lid env in
-  record path sort lid env;
-  res
+  record sort lid env;
+  lookup lid env
 
 let lookup_module = recording Module lookup_module
 
 let lookup sort proj1 proj2 lid env =
-  let path, _ as res = lookup proj1 proj2 lid env in
-  record path sort lid env;
-  res
+  record sort lid env;
+  lookup proj1 proj2 lid env
 
 let lookup_value =
   lookup Value (fun env -> env.values) (fun sc -> sc.comp_values)

typing/env.mli

@@ -172,7 +172,8 @@ val report_error: formatter -> error -> unit
 val check_modtype_inclusion:
       (t -> module_type -> Path.t -> module_type -> unit) ref
 
-module PathTbl : Hashtbl.S with type key = Path.t
+(* Duplicated from Longident (linking problem with genannot) *)
+module LongidentTbl : Hashtbl.S with type key = Longident.t
 
 type path_sort =
   | Value
@@ -185,8 +186,8 @@ type path_sort =
   | Class
   | Cltype
 
-type path2env = (path_sort * Longident.t * t) PathTbl.t
+type lid2env = (path_sort * t) LongidentTbl.t
 
 val record_path_environments : unit -> unit
 
-val flush_paths : unit -> path2env option
+val flush_paths : unit -> lid2env option

typing/typedtree.ml

@@ -361,8 +361,8 @@ type saved_type =
 | Saved_pattern of pattern
 | Saved_class_expr of class_expr
 | Saved_ident_locations of Location.string_table option
-| Saved_longident_locations of Location.t Longident.LongidentTbl.t option
-| Saved_path_environments of Env.path2env option
+| Saved_longident_locations of Longident.lid2loc option
+| Saved_path_environments of Env.lid2env option
 
 let saved_types = ref []
 let get_saved_types () = !saved_types

typing/typedtree.mli

@@ -378,8 +378,8 @@ type saved_type =
 | Saved_pattern of pattern
 | Saved_class_expr of class_expr
 | Saved_ident_locations of Location.string_table option
-| Saved_longident_locations of Location.t Longident.LongidentTbl.t option
-| Saved_path_environments of Env.path2env option
+| Saved_longident_locations of Longident.lid2loc option
+| Saved_path_environments of Env.lid2env option
 
 val get_saved_types : unit -> saved_type list
 val set_saved_types : saved_type list -> unit

typing/typemod.mli

@@ -25,7 +25,7 @@ val type_structure:
 val type_implementation:
   string -> string -> string -> Env.t ->
   (Parsetree.structure * Location.string_table option
-   * Location.t Longident.LongidentTbl.t option) ->
+   * Longident.lid2loc option) ->
   Typedtree.structure * Typedtree.module_coercion
 val transl_signature:
         Env.t -> Parsetree.signature -> Typedtree.signature
@@ -36,7 +36,7 @@ val simplify_signature: signature -> signature
 
 val save_signature :
   (Typedtree.signature * Location.string_table option
-   *  Location.t Longident.LongidentTbl.t option * Env.path2env option) ->
+   * Longident.lid2loc option * Env.lid2env option) ->
   string -> unit
 
 val package_units: