Skip to content
Browse files

renaming in types -> regression tests fail !

  • Loading branch information...
1 parent 447b255 commit dab0d1d8628989c60d2496c24eee96251c171bb7 Tiphaine Turpin committed
View
50 ocamlwizard/common/typedtreeOps.ml
@@ -219,7 +219,37 @@ let find_expression priority cond =
module NodeTbl = Hashtbl.Make
(struct
type t = node
- let equal = ( == )
+ let equal x y =
+ match x, y with
+ | `structure x, `structure y -> x == y
+ | `value_description x, `value_description y -> x == y
+ | `type_declaration x, `type_declaration y -> x == y
+ | `exception_declaration x, `exception_declaration y -> x == y
+ | `pattern x, `pattern y -> x == y
+ | `expression x, `expression y -> x == y
+ | `package_type x, `package_type y -> x == y
+ | `signature x, `signature y -> x == y
+ | `signature_item x, `signature_item y -> x == y
+ | `modtype_declaration x, `modtype_declaration y -> x == y
+ | `module_type x, `module_type y -> x == y
+ | `module_expr x, `module_expr y -> x == y
+ | `with_constraint x, `with_constraint y -> x == y
+ | `class_expr x, `class_expr y -> x == y
+ | `class_signature x, `class_signature y -> x == y
+ | `class_description x, `class_description y -> x == y
+ | `class_type_declaration x, `class_type_declaration y -> x == y
+ | `class_infos x, `class_infos y -> x == y
+ | `class_type x, `class_type y -> x == y
+ | `class_type_field x, `class_type_field y -> x == y
+ | `core_type x, `core_type y -> x == y
+ | `core_field_type x, `core_field_type y -> x == y
+ | `class_structure x, `class_structure y -> x == y
+ | `class_field x, `class_field y -> x == y
+ | `structure_item x, `structure_item y -> x == y
+ | `binding x, `binding y -> x == y
+ | `bindings x, `bindings y -> x == y
+ | _ -> false
+
let hash = Hashtbl.hash
end)
@@ -228,12 +258,18 @@ type father_table = node NodeTbl.t
let reverse s =
let t = NodeTbl.create 1000
and path = ref [] in
- let enter n =
- (match !path with
- | f :: _ -> NodeTbl.add t n f
- | _ -> ());
- path := n :: !path
- and leave _ =
+ let enter = function
+ | `bindings _ -> ()
+ | n ->
+ (match !path with
+ | f :: _ ->
+ debugln "add %s -> %s" (node_kind n) (node_kind f);
+ NodeTbl.add t n f
+ | _ -> ());
+ path := n :: !path
+ and leave = function
+ | `bindings _ -> ()
+ | _ ->
path :=
match !path with
| _ :: p -> p
View
79 ocamlwizard/refactor/findName.ml
@@ -30,6 +30,8 @@ type occurrence_kind = [
| `sig_open
| `mty_with
| `mty_ident
+| `core_type_type
+| `pat_alias_type
]
(* Is that meaningful ? *)
@@ -41,43 +43,64 @@ let rec path2loc idents = function
{l with Location.loc_end = l'.Location.loc_end}
| Path.Papply (p, p') -> failwith "not implemented"
-let rec env_of_node father_table n =
+(* We need to be complete for all the supported sorts, otherwise we
+ have regression on value renaming, for example. *)
+let rec env_of_node root_env father_table n =
let up () =
+ debug "father of %s is " (node_kind n);
match NodeTbl.find_all father_table n with
- | [father] -> env_of_node father_table father
- | [] -> failwith "root"
- | _ -> failwith "ambiguous"
+ | [father] ->
+ debugln "%s" (node_kind father);
+ env_of_node root_env father_table father
+ | [] -> debugln "root" ; root_env
+ | _ -> failwith ("node " ^ node_kind n ^ " has multiple fathers")
in
match n with
| `core_type _
| `pattern _ -> up ()
- | `structure_item { str_desc = Tstr_type _ } -> failwith "env"
+ | `type_declaration _ -> up () (* faux a cause de la recursion ! *)
+ | `structure_item { str_desc = Tstr_type _ ; str_env = env } ->
+ debugln "found env in structure_item" ; env
+ | `expression { exp_desc = (*Texp_constraint*) _ ; exp_env = env } -> env
+ | `binding ({ pat_desc = Tpat_alias _}, _) -> up ()
+ | `bindings _ -> assert false
| _ -> failwith ("env_of_node: unsupported case " ^ node_kind n)
+let shift n loc =
+ let start = loc.Location.loc_start in
+ { loc with Location.loc_start =
+ { start with Lexing.pos_cnum = start.Lexing.pos_cnum + n }
+ }
+
(* This should only be complete w.r.t. values and module paths ! But
we cannot have safe renaming for modules until we are complete
w.r.t. paths of all sorts. *)
-let find_all_occurrences idents tree =
+let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
let father_table = reverse tree in
let found loc env occ = Some (loc, (env, occ))
- and loc = path2loc idents
- and env = env_of_node father_table in
+(*
+ and loc n =
+ let loc = path2loc idents n in
+ let b, e = get_c_num loc in
+ debugln "loc = [%d, %d[" b e;
+ loc
+*)
+ and env = env_of_node env father_table in
find_all_map
(function n ->
match n with
-(*
| `pattern p ->
(match p.pat_desc with
- | Tpat_alias (_, TPat_type p) ->
- found (path2loc p) (assert false) `pat_alias_type)
-*)
-(*
+ | Tpat_alias (_, TPat_type _) ->
+ found (shift 1 p.pat_loc) (env n) `pat_alias_type
+ | _ -> None)
+
| `core_type t ->
(match t.ctyp_desc with
- | Ttyp_constr (p, _) -> found (loc p) (env n) `core_type_type
+ | Ttyp_constr (p, _) ->
+ found t.ctyp_loc (env n) `core_type_type
| _ -> None)
-*)
| `expression e ->
(match e.exp_desc with
@@ -145,39 +168,33 @@ let find_all_occurrences idents tree =
| _ -> None)
tree
-let get_occurrences idents s =
+let get_occurrences env idents s =
List.sort
(fun (loc, _) (loc', _) ->
let open Lexing in
compare loc.loc_start.pos_cnum loc.loc_end.pos_cnum)
- (find_all_occurrences idents s)
+ (find_all_occurrences env idents s)
let extract_longident (loc, s, (env, occ)) =
- let parse parser s =
- let lexbuf = Lexing.from_string s in
- parser Lexer.token lexbuf
- in
- let parser, kind = match occ with
- | `exp_ident ->
- (function s ->
- try parse Parser.val_longident s
- with _ -> Longident.Lident (parse Parser.operator s)),
- value_ops
- | `mod_ident -> parse Parser.mod_longident, module_ops
+ let kind = match occ with
+ | `exp_ident -> value_ops
+ | `mod_ident -> module_ops
+ | `core_type_type -> type_ops
+ | `pat_alias_type -> type_ops
| _ -> failwith "not implemented"
in
let ast =
try
- parser s
+ kind.parse_lid s
with _ ->
failwith ("error parsing the following ident: " ^ s)
in
(loc, ast, (env, kind))
-let get_lids file idents ast =
+let get_lids env file idents ast =
List.map
extract_longident
- (source_locations file (get_occurrences idents ast))
+ (source_locations file (get_occurrences env idents ast))
let ident_of_subtree = function
| `pattern {pat_desc = Tpat_var id}
View
1 ocamlwizard/refactor/findName.mli
@@ -25,6 +25,7 @@ val get_occurrences :
*)
val get_lids :
+ Env.t ->
string ->
Location.string_table ->
[ `signature of Typedtree.signature | `structure of Typedtree.structure ]->
View
8 ocamlwizard/refactor/rename.ml
@@ -226,7 +226,7 @@ let backup file =
Edit.cp file backup
(* Rename an ident in a structure file, with given ast. *)
-let rename_in_file renamed_kind id name' file (s, idents) =
+let rename_in_file env renamed_kind id name' file (s, idents) =
(* Collect constraints requiring simultaneous renaming *)
let constraints, includes = collect_signature_inclusions (`structure s) in
@@ -245,7 +245,7 @@ let rename_in_file renamed_kind id name' file (s, idents) =
check_renamed_implicit_references renamed_kind ids name' implicit_refs;
(* Collect all lids *)
- let lids = get_lids file idents (`structure s) in
+ let lids = get_lids env file idents (`structure s) in
(* Check that our new name will not capture other occurrences *)
check_lids renamed_kind ids name' lids;
@@ -264,7 +264,7 @@ let rename loc name' file =
(* Setup the environment *)
let dirs = Common_config.search_dirs file in
Config.load_path := "" :: List.rev_append dirs (Clflags.std_include_dir ());
- ignore (initial_env ()); (* Make sure that Pervasives is loaded *)
+ let env = initial_env () in (* Make sure that Pervasives is loaded *)
debugln "load_path:"; List.iter (debugln " %s") !Config.load_path;
(* Check that everything is up-to-date *)
@@ -292,7 +292,7 @@ let rename loc name' file =
let name' = fix_case renamed_kind name' in
let def_replaces, occ_replaces =
- rename_in_file renamed_kind id name' file (s, idents) in
+ rename_in_file env renamed_kind id name' file (s, idents) in
(* We need to sort them again (they may interleave). *)
let replaces = sort_replaces (def_replaces @ occ_replaces) in
View
22 ocamlwizard/refactor/resolve.ml
@@ -31,7 +31,8 @@ type specifics = {
sort : sort;
lookup : Longident.t -> Env.t -> Path.t;
sig_item : Types.signature_item -> Ident.t option;
- summary_item : Env.summary -> Ident.t option
+ summary_item : Env.summary -> Ident.t option;
+ parse_lid : string -> Longident.t
}
let wrap_lookup to_string name lookup x e =
@@ -40,32 +41,43 @@ let wrap_lookup to_string name lookup x e =
let keep_first name f lid env = fst (wrap_lookup lid_to_str name f lid env)
+let parse parser s =
+ let lexbuf = Lexing.from_string s in
+ parser Lexer.token lexbuf
+
let value_ops = {
sort = `Value;
lookup = keep_first "value" Env.lookup_value;
sig_item = (function Sig_value (i, _) -> Some i | _ -> None);
- summary_item = function Env_value (_, i, _) -> Some i | _ -> None
+ summary_item = (function Env_value (_, i, _) -> Some i | _ -> None);
+ parse_lid =
+ function s ->
+ try parse Parser.val_longident s
+ with _ -> Longident.Lident (parse Parser.operator s)
}
let type_ops = {
sort = `Type;
lookup = keep_first "type" Env.lookup_type;
sig_item = (function Sig_type (i, _, _) -> Some i | _ -> None);
- summary_item = function Env_type (_, i, _) -> Some i | _ -> None
+ summary_item = (function Env_type (_, i, _) -> Some i | _ -> None);
+ parse_lid = parse Parser.type_longident
}
let module_ops = {
sort = `Module;
lookup = keep_first "module" Env.lookup_module;
sig_item = (function Sig_module (i, _, _) -> Some i | _ -> None);
- summary_item = function Env_module (_, i, _) -> Some i | _ -> None
+ summary_item = (function Env_module (_, i, _) -> Some i | _ -> None);
+ parse_lid = parse Parser.mod_longident (* extended ? *)
}
let modtype_ops = {
sort = `Modtype;
lookup = keep_first "module type" Env.lookup_modtype;
sig_item = (function Sig_modtype (i, _) -> Some i | _ -> None);
- summary_item = function Env_modtype (_, i, _) -> Some i | _ -> None
+ summary_item = (function Env_modtype (_, i, _) -> Some i | _ -> None);
+ parse_lid = parse Parser.mty_longident
}
let sig_item_ops = function
View
1 ocamlwizard/refactor/resolve.mli
@@ -25,6 +25,7 @@ type specifics = {
lookup : Longident.t -> Env.t -> Path.t;
sig_item : Types.signature_item -> Ident.t option;
summary_item : Env.summary -> Ident.t option;
+ parse_lid : string -> Longident.t
}
val value_ops : specifics
View
2 ocamlwizard/test/Makefile
@@ -7,7 +7,7 @@ R_CASES=renameSimple.ml renameSigNewCaptured.ml renameSigOldCaptured.ml \
renameIncludeNewCaptured.ml renameIncludeOldCaptured.ml \
renameOpenNewCaptured.ml renameOpenOldCaptured.ml \
renameMultiple.ml renameProp.ml renamePropFunctor.ml \
- renamePropFunctorNoApp.ml
+ renamePropFunctorNoApp.ml renameType.ml
# renameModtype.ml
R_TESTS=$(subst .ml,_rres.ml, $(R_CASES))

0 comments on commit dab0d1d

Please sign in to comment.
Something went wrong with that request. Please try again.