Permalink
Browse files

Propagation in several files ; occurrences and masking are broken

  • Loading branch information...
1 parent b5be736 commit 1d8d9d1b4ec1232d2536d931e52c27bc15aebdb4 Tiphaine Turpin committed Jul 13, 2011
@@ -243,11 +243,16 @@ let read_all_files f =
and cmti = f ^ ".cmti"
and cmi = f ^ ".cmi" in
(* we should check ml and mli first. *)
- let parse sort f =
- if Sys.file_exists f then Some (read_typedtree sort f) else None in
- parse (function `structure s -> s | _ -> assert false) cmt,
- parse (function `signature s -> s | _ -> assert false) cmti,
- read_cmi cmi
+ let cmi = read_cmi cmi in
+ let sort x = x in
+ let parse f l =
+ if Sys.file_exists f then
+ let ast = read_typedtree sort f in
+ (ast, cmi) :: l
+ else
+ l
+ in
+ parse cmt (parse cmti [])
let sort_replaces =
List.sort
@@ -263,15 +268,36 @@ let rec remove_duplicates = function
x :: remove_duplicates l
| l -> l
-let find_id_defs ids locs name s =
- let defs =
- List.map2
- (fun id loc ->
- loc.loc_start.pos_cnum, loc.loc_end.pos_cnum, name)
- ids
- locs
- in
- remove_duplicates (sort_replaces defs)
+let hashtbl_keys t =
+ Hashtbl.fold
+ (fun k _ l ->
+ match l with
+ | k' :: _ as l when k = k' -> l
+ | l -> k :: l)
+ t
+ []
+
+let sort_replaces replaces =
+ let t = Hashtbl.create 2 in
+ List.iter
+ (function loc, rep ->
+ Hashtbl.add t loc.loc_start.pos_fname
+ (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum, rep))
+ replaces;
+ List.map
+ (function f ->
+ f, remove_duplicates (sort_replaces (Hashtbl.find_all t f)))
+ (hashtbl_keys t)
+
+let find_id_defs ids name =
+ List.fold_right
+ (fun (loc, _) l ->
+ match loc with
+ | `cmi -> l
+ | `source loc -> (loc, name) :: l
+ | `none -> invalid_arg "find_id_defs")
+ ids
+ []
let fix_case kind =
match kind with
@@ -285,20 +311,18 @@ let backup file =
else
Edit.cp file backup
-(* Rename an ident in a structure file, with given ast. *)
-let rename_in_file
- env renamed_kind id name' file (typedtree, idents, lid2loc, paths) =
+(* Rename an ident in a list of source files. *)
+let rename_in_files
+ env renamed_kind id loc name' files =
- (* Collect constraints requiring simultaneous renaming *)
- let constraints, includes = collect_signature_inclusions typedtree in
-
- (* Deduce the minimal set of ids to rename *)
- let ids, locs, implicit_refs =
- propagate_renamings renamed_kind id constraints includes idents in
+ (* Collect constraints requiring simultaneous renaming and deduce
+ the minimal set of ids to rename *)
+ let ids, implicit_refs = propagate_all_files env loc renamed_kind id files in
(* Compute the replacements for the *definitions* of the rename ids *)
- let def_replaces = find_id_defs ids locs name' idents in
+ let def_replaces = find_id_defs ids name' in
+(*
(* Check that our new name will not capture useful signature members *)
check_other_implicit_references renamed_kind ids name' constraints includes;
@@ -313,8 +337,8 @@ let rename_in_file
(* Compute renamed lids, checking that they are not captured *)
let occ_replaces = rename_lids renamed_kind ids name' lids in
-
- def_replaces, occ_replaces
+*)
+ def_replaces(*, occ_replaces *)
(* Renaming entry point: user interface... *)
let rename loc name' file =
@@ -340,38 +364,40 @@ let rename loc name' file =
(* Read the typedtree *)
let s, idents, lidents, paths = read_typedtree (function s -> s) typedtree_file in
- (* Get the "initial" id to rename and its sort *)
+ (* Get the "initial" id to rename and its sort and location *)
let renamed_kind, id =
try Locate.longident idents loc s
with Not_found -> fail_owz "Cannot rename anything here"
in
+ let loc = Locate.ident_def idents id in
+
let name = Ident.name id in
let name' = fix_case renamed_kind name' in
- try
- let def_replaces, occ_replaces =
- rename_in_file env renamed_kind id name' file (s, idents, lidents, paths)
- in
+ let files = read_all_files file in
- (* We need to sort them again (they may interleave). *)
- let replaces = sort_replaces (def_replaces @ occ_replaces) in
+ try
+ let replaces = rename_in_files env renamed_kind id loc name' files in
+ let replaces = sort_replaces replaces in
(* Replace lids in the source file *)
- Edit.edit replaces file;
-
+ List.iter
+ (function file, replaces -> Edit.edit replaces (Filename.basename file))
+ replaces;
+(*
Printf.printf "Renamed %d definition(s) and %d reference(s)"
(List.length def_replaces) (List.length occ_replaces)
+*)
with
Masked_by (renamed, id) ->
- let loc = Locate.ident_def idents id in
- Location.print Format.std_formatter loc;
- if renamed then
- fail_owz
- "This existing definition of %s would capture an occurrence of %s"
- name' name
- else
- fail_owz
- "This definition of %s that you are trying to rename would \
+ Location.print Format.std_formatter loc;
+ if renamed then
+ fail_owz
+ "This existing definition of %s would capture an occurrence of %s"
+ name' name
+ else
+ fail_owz
+ "This definition of %s that you are trying to rename would \
capture an occurrence of an existing definition of %s"
- name name'
+ name name'
@@ -83,9 +83,11 @@ and constraint_signature incs env sg sg' =
| _ -> ())
sg'
-let constraint_with_cmi incs env (typedtree : TypedtreeOps.typedtree) cmi =
+let constraint_with_cmi env (typedtree : TypedtreeOps.typedtree) cmi =
let `structure {str_type = sg} | `signature {sig_type = sg} = typedtree in
- constraint_signature incs env sg cmi
+ let incs = ref ConstraintSet.empty in
+ constraint_signature incs env sg cmi;
+ !incs
(* Collect the set of signature inclusion constraints implied by a structure.
@@ -145,6 +147,13 @@ let collect_signature_inclusions s =
TypedtreeOps.iterator ~enter ~leave:ignore s;
!incs, !includes
+let string_table_union t t' =
+ let open Location.StringTbl in
+ let t = copy t in
+ iter
+ (fun x l -> add t x l)
+ t';
+ t
module Eq : sig
@@ -192,6 +201,7 @@ end = struct
eq'
let union eq eq' =
+ (* Copy is not enough *)
let eq = map (function x -> x) eq in
Hashtbl.iter
(fun x l -> List.iter (add eq x) !l)
@@ -204,53 +214,47 @@ end = struct
end
+let propagate_constraints bind_id_to_member kind name incs =
+ ConstraintSet.iter
+ (function sg, sg' ->
+ try
+ let id' = find_in_signature kind name sg' in
+ bind_id_to_member `certain sg id'
+ with
+ Not_found -> ())
+ incs
-(* Return the set of ids that would need to be renamed simultaneously
- with id, and the list of "implicit" references which cause this
- need (so that we can check them for masking). *)
-let propagate_renamings kind name incs includes =
- let eq = Hashtbl.create 10 in
- let implicit_refs = ref []
- and ambiguous = ref [] in
- let copy flag sg id' =
- try
- let id = find_in_signature kind name sg in
- implicit_refs := (flag, sg, id') :: !implicit_refs;
- Eq.add eq id id'
- with Not_found -> assert false
- in
- ConstraintSet.iter
- (function sg, sg' ->
- try
- let id' = find_in_signature kind name sg' in
- copy `certain sg id'
- with
- Not_found -> ())
- incs;
- IncludeSet.iter
- (function sg, ids ->
- match List.filter (function id -> Ident.name id = name) ids with
- | [] -> ()
- (* WARNING ! We should check if the name id define
- with the right kind in sg ! *)
- | [id] -> copy `maybe sg id
- | ids -> (* correct choice would require access to the resulting
- environment to check ids w.r.t. kind. *)
- List.iter (copy `maybe sg) ids;
- (* because we still need to check them for capture *)
- ambiguous := (find_in_signature kind name sg) :: !ambiguous)
- includes;
- eq, !ambiguous, !implicit_refs
-
-let propagate_one_file kind name file_kind s =
+let propagate_includes bind_id_to_member tag ambiguous kind name includes =
+ IncludeSet.iter
+ (function sg, ids ->
+ match List.filter (function id -> Ident.name id = name) ids with
+ | [] -> ()
+ (* WARNING ! We should check if the name id define
+ with the right kind in sg ! *)
+ | [id] -> bind_id_to_member `maybe sg id
+ | ids -> (* correct choice would require access to the resulting
+ environment to check ids w.r.t. kind. *)
+ List.iter (bind_id_to_member `maybe sg) ids;
+ (* because we still need to check them for capture *)
+ ambiguous := tag (find_in_signature kind name sg) :: !ambiguous)
+ includes
+
+let propagate_one_file eq implicit_refs ambiguous env kind name tag cmi_tag s cmi =
+ let bind_id_to_member tag tag' flag sg id' =
+ try
+ let id = find_in_signature kind name sg in
+ let id = tag id and id' = tag' id' in
+ implicit_refs := (flag, sg, id') :: !implicit_refs;
+ Eq.add eq id id'
+ with Not_found -> invalid_arg "bind_id_to_member"
+ in
let incs, includes = collect_signature_inclusions s in
- let eq, ambiguous, implicit_refs =
- propagate_renamings kind name incs includes in
- let tag id = file_kind, id in
- let eq = Eq.map tag eq
- and ambiguous = List.map tag ambiguous in
- eq, ambiguous, implicit_refs
+ let cmi_incs = constraint_with_cmi env s cmi in
+ propagate_constraints (bind_id_to_member tag tag) kind name incs;
+ propagate_includes (bind_id_to_member tag tag) tag ambiguous kind name includes;
+ propagate_constraints (bind_id_to_member tag cmi_tag) kind name cmi_incs
+(*
let propagate_renamings kind id incs includes idents =
let name = Ident.name id in
let eq, ambiguous, implicit_refs =
@@ -273,15 +277,32 @@ let propagate_renamings kind id incs includes idents =
"Cannot perform renaming because of an ambiguous include")
ambiguous;
ids, locs, implicit_refs
+*)
-let propagate_all_files file_kind kind id (ml, ml_ids) (mli, mli_ids) cmi =
+let propagate_all_files env loc kind id files =
+ let eq = Hashtbl.create 10 in
+ let implicit_refs = ref []
+ and ambiguous = ref [] in
let name = Ident.name id in
- let ml_eq, ml_ambiguous, ml_implicit_refs = propagate_one_file kind name `ml ml
- and mli_eq, mli_ambiguous, mli_implicit_refs = propagate_one_file kind name `mli mli in
- let eq = Eq.union ml_eq mli_eq
- and ambiguous = ml_ambiguous @ mli_ambiguous
- and implicit_refs = ml_implicit_refs @ mli_implicit_refs in
- let ids = Eq.find eq (file_kind, id) in
+ let idents =
+ List.fold_left
+ (fun idents ((_, ids, _, _), _) -> string_table_union idents ids)
+ (Location.StringTbl.create 10)
+ files in
+(*
+ let tag file_kind id = file_kind, id in
+*)
+ let tag id =
+ (try `source (Locate.ident_def idents id) with Not_found -> `none),
+ id
+ and cmi_tag id = `cmi, id in
+ List.iter
+ (function (source, _, _, _), cmi ->
+ let propagate = propagate_one_file eq implicit_refs ambiguous env kind name in
+ propagate tag cmi_tag source cmi.sig_type)
+ files;
+ let ids = Eq.find eq (`source loc, id) in
+(*
let locs = List.map
(function file_kind, id ->
let idents = match file_kind with `ml -> ml_ids | `mli -> mli_ids in
@@ -292,13 +313,22 @@ let propagate_all_files file_kind kind id (ml, ml_ids) (mli, mli_ids) cmi =
structure would be impacted")
ids
in
+*)
+ (* Check if propagation reached an unlocalised id *)
+ List.iter
+ (function loc, id ->
+ if loc = `none then
+ fail_owz "Cannot perform renaming because a member of a persistent \
+ structure would be impacted")
+ ids;
+ (* Check if ids intersect ambiguous *)
List.iter
(function id ->
if List.mem id ids then
failwith
"Cannot perform renaming because of an ambiguous include")
- ambiguous;
- ids, locs, implicit_refs
+ !ambiguous;
+ ids, (*locs,*) !implicit_refs
(* Check that the implicit ident references which are concerned by
renaming will not be masked (i.e., that the bound signature items
@@ -35,12 +35,24 @@ val collect_signature_inclusions :
(** Return the minimal set of idents which may be renamed and contains
a given id, as well as the "implicit" bindings of signature
elements to those idents. *)
-val propagate_renamings :
+(*
+ val propagate_renamings :
Env.path_sort -> Ident.t -> ConstraintSet.t -> IncludeSet.t ->
Location.string_table ->
Ident.t list * Location.t list
* ([ `certain | `maybe ] * Types.signature * Ident.t) list
- (* means id is bound to sg.(name id), unless we were wrong about the sort. *)
+(* means id is bound to sg.(name id), unless we were wrong about the sort. *)
+*)
+val propagate_all_files :
+ Env.t ->
+ Location.t ->
+ Env.path_sort ->
+ Ident.t ->
+ ((TypedtreeOps.typedtree * Location.string_table * Longident.lid2loc
+ * Env.lid2env)
+ * Typedtree.signature) list ->
+ (([> `cmi | `none | `source of Location.t ] as 'a) * Ident.t) list *
+ ([> `certain | `maybe ] * Types.signature * ('a * Ident.t)) list
val check_renamed_implicit_references :
Env.path_sort -> Ident.t list -> string ->
@@ -213,7 +213,7 @@ let field_resolves_to kind env path name ids =
*)
let lookup_in_signature kind name sg =
- if kind = Constructor || kind = Label then
+ if kind = Module || kind = Modtype then
List.find
(function item -> match sig_item kind item with
| Some id -> Ident.name id = name

0 comments on commit 1d8d9d1

Please sign in to comment.