Skip to content
Browse files

Fixed exceptions ; rename in .mli files

  • Loading branch information...
1 parent c7f2a60 commit b381187f9dbe9c1474e0db1e61d5377dda0e4273 @tturpin tturpin committed Jul 8, 2011
View
12 ocamlwizard/TODO
@@ -1,16 +1,14 @@
-- Rename: rename type variables, argument labels, polymorphic variants, methods
-- Rename: rename in signatures
- Rename: replace in multiple files
+
- Rename: return a list of files that emacs should revert
- Rename: check that we always lookup in the right environment
-
-- Binannot: only record locs and envs if annot is set
-- Rename: rename everything an not just values
+- Rename: rename type variables, argument labels, polymorphic variants, methods
+- Rename: propagate more constraints (constrs, fields, exceptions)
- Rename: collect all occurrences in a or-pattern
- Rename: retrieve a definition from an occurrence
- Rename: warn about potential future captures
-- Rename: tell emacs to revert all relevant buffers
-- Use a best qualification for labels
+- Binannot: only record locs and envs if annot is set
+- Completion: Use a best qualification for labels
- Errors: do not output anything, and stop everything in the emacs mode
- Match_cases completion: indent the cases correctly
- Match_cases completion: allow an optional |
View
6 ocamlwizard/common/util.ml
@@ -296,3 +296,9 @@ let initial_env () =
else Env.open_pers_signature "Pervasives" Env.initial
with Not_found ->
Misc.fatal_error "cannot open pervasives.cmi"
+
+exception OwzFailure of string
+
+let fail_owz s = raise (OwzFailure s)
+
+let fail_owz s = Printf.ksprintf fail_owz s
View
7 ocamlwizard/common/util.mli
@@ -50,3 +50,10 @@ val source_locations :
string -> (Location.t * 'a) list -> (Location.t * string * 'a) list
val initial_env : unit -> Env.t
+
+(** Indicates that the query cannot be processed, for some legitimate
+ reason. The message will be printed on stdout (prefixed with
+ "Error:" before exiting with signal 1). *)
+exception OwzFailure of string
+
+val fail_owz : ('a, unit, string, 'b) format4 -> 'a
View
18 ocamlwizard/main/ocamlwizard.ml
@@ -57,6 +57,21 @@ let mk_info rg =
c_printer = !printer;
}
+let catch_owz f =
+ try f ()
+ with
+ | OwzFailure s ->
+ print_string s;
+ exit 1
+ | Failure s ->
+ Printf.printf "Error: %s\n" s;
+ Printexc.print_backtrace stdout;
+ exit 2
+ | e ->
+ Printf.printf "Error: %s\n" (Printexc.to_string e);
+ Printexc.print_backtrace stdout;
+ exit 2
+
(** Main for external completion calls *)
let main () =
Arg.parse options anonymous usage;
@@ -76,7 +91,8 @@ let main () =
| Refactor r ->
(match r with
- | Rename (loc, name', file) -> Rename.rename loc name' file
+ | Rename (loc, name', file) ->
+ catch_owz (function () -> Rename.rename loc name' file ; exit 0)
| Depend | Qualif -> failwith "not yet")
| Locate -> failwith "not yet"
View
3 ocamlwizard/refactor/findName.ml
@@ -280,6 +280,9 @@ let locate_renamed_id s loc =
(function id, _, _ -> id) (function _, _, _, loc -> loc) fs tfs
| Type_abstract, Ttype_abstract -> raise Not_found
| _ -> assert false)
+ | `structure_item {str_desc = Tstr_exception (id, _)}
+ | `signature_item {sig_desc = Tsig_exception (id, _)} ->
+ Constructor, id
| _ -> raise Not_found)
with Not_found -> None)
loc s
View
167 ocamlwizard/refactor/rename.ml
@@ -175,30 +175,41 @@ let rename_lids renamed_kind id name' lids =
[]
(List.rev lids)
-let read_cmt file =
- if Filename.check_suffix file ".cmt" then
- let c = open_in file in
- let data = input_value c in
+let classify_source f =
+ let open Filename in
+ if
+ check_suffix f ".ml" then `ml
+ else if
+ check_suffix f ".mli" then `mli
+ else
+ invalid_arg "not an OCaml source file"
+
+let typedtree_file source_kind f =
+ Filename.chop_extension f ^
+ match source_kind with
+ | `ml -> ".cmt"
+ | `mli -> ".cmti"
+
+let read_typedtree _ file =
+ let c = open_in file in
+ let data = input_value c in
close_in c;
- match data.(0) with
- | Saved_implementation str ->
- (try
- match data.(1), data.(2), data.(3) with
- | Saved_ident_locations (Some loc),
- Saved_longident_locations (Some lloc),
- Saved_path_environments (Some env) ->
- str, loc, lloc, env
-(*
- | Saved_ident_locations None ->
- failwith "ident location table is empty"
-*)
- | _ -> raise Not_found
- with
- _ -> failwith
- "ident location or path environment table not found in cmt")
- | _ -> failwith "error reading cmt file"
- else
- invalid_arg "read_cmt"
+ let tree =
+ match data.(0) with
+ | Saved_implementation str -> `structure str
+ | Saved_signature sg -> `signature sg
+ | _ -> failwith "error reading cmt(i) file"
+ in
+ try
+ match data.(1), data.(2), data.(3) with
+ | Saved_ident_locations (Some loc),
+ Saved_longident_locations (Some lloc),
+ Saved_path_environments (Some env) ->
+ tree, loc, lloc, env
+ | _ -> raise Not_found
+ with
+ _ -> failwith
+ "ident location or path environment table not found in cmt(i)"
let sort_replaces =
List.sort
@@ -231,10 +242,11 @@ 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, lid2loc, paths) =
+let rename_in_file
+ env renamed_kind id name' file (typedtree, idents, lid2loc, paths) =
(* Collect constraints requiring simultaneous renaming *)
- let constraints, includes = collect_signature_inclusions (`structure s) in
+ let constraints, includes = collect_signature_inclusions typedtree in
(* Deduce the minimal set of ids to rename *)
let ids, implicit_refs =
@@ -250,7 +262,7 @@ let rename_in_file env renamed_kind id name' file (s, idents, lid2loc, paths) =
check_renamed_implicit_references renamed_kind ids name' implicit_refs;
(* Collect all lids *)
- let lids = get_lids env file lid2loc paths (`structure s) in
+ let lids = get_lids env file lid2loc paths typedtree in
(* Check that our new name will not capture other occurrences *)
check_lids renamed_kind ids name' lids;
@@ -262,74 +274,57 @@ let rename_in_file env renamed_kind id name' file (s, idents, lid2loc, paths) =
(* Renaming entry point: user interface... *)
let rename loc name' file =
- try
- backup file;
+ backup file;
- (* Setup the environment *)
- let dirs = Common_config.search_dirs file in
- Config.load_path := "" :: List.rev_append dirs (Clflags.std_include_dir ());
- let env = initial_env () in (* Make sure that Pervasives is loaded *)
- debugln "load_path:"; List.iter (debugln " %s") !Config.load_path;
+ (* Setup the environment *)
+ let dirs = Common_config.search_dirs file in
+ Config.load_path := "" :: List.rev_append dirs (Clflags.std_include_dir ());
+ 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 *)
- if Common_config.has_auto_save file then
- failwith "buffer must be saved before renaming";
- let cmt_file = Filename.chop_suffix file ".ml" ^ ".cmt" in
- if not (Sys.file_exists cmt_file) then
- failwith ("no cmt file for " ^ file);
- if Unix.( (stat file).st_mtime > (stat cmt_file).st_mtime ) then
- failwith "cmt file is older than source file";
+ (* Check that everything is up-to-date *)
+ if Common_config.has_auto_save file then
+ failwith "buffer must be saved before renaming";
+ let source_kind = classify_source file in
+ let typedtree_file = typedtree_file source_kind file in
+ if not (Sys.file_exists typedtree_file) then
+ failwith ("no cmt(i) file for " ^ file);
+ if Unix.((stat file).st_mtime > (stat typedtree_file).st_mtime) then
+ failwith "cmt(i) file is older than source file";
- (* Read the typedtree *)
- let s, idents, lidents, paths = read_cmt cmt_file in
+ (* Read the typedtree *)
+ let s, idents, lidents, paths = read_typedtree source_kind typedtree_file in
- (* Get the "initial" id to rename and its sort *)
- let renamed_kind, id = locate_renamed_id (`structure s) loc in
+ (* Get the "initial" id to rename and its sort *)
+ let renamed_kind, id = locate_renamed_id s loc in
+ let name = Ident.name id in
- let name = Ident.name id in
-(*
- if Ident.name id <> name then failwith "name does not match location";
-*)
-
- try
-
- let name' = fix_case renamed_kind name' in
+ let name' = fix_case renamed_kind name' in
- let def_replaces, occ_replaces =
- rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) in
-
- (* We need to sort them again (they may interleave). *)
- let replaces = sort_replaces (def_replaces @ occ_replaces) in
+ try
+ let def_replaces, occ_replaces =
+ rename_in_file env renamed_kind id name' file (s, idents, lidents, paths)
+ in
- (* Replace lids in the source file *)
- Edit.edit replaces file;
+ (* We need to sort them again (they may interleave). *)
+ let replaces = sort_replaces (def_replaces @ occ_replaces) in
- Printf.printf "Renamed %d definition(s) and %d reference(s)"
- (List.length def_replaces) (List.length occ_replaces);
- exit 0
+ (* Replace lids in the source file *)
+ Edit.edit replaces file;
- with
- | Masked_by (renamed, id) ->
- let loc = find_id_def idents id in
- Location.print Format.std_formatter loc;
- if renamed then
- Printf.printf
- "This existing definition of %s would capture an occurrence of %s"
- name' name
- else
- Printf.printf
- "This definition of %s that you are trying to rename would \
- capture an occurrence of an existing definition of %s"
- name name';
- exit 1
- | e -> raise e
+ Printf.printf "Renamed %d definition(s) and %d reference(s)"
+ (List.length def_replaces) (List.length occ_replaces)
with
- | Failure s ->
- Printf.printf "Error: %s\n" s;
- Printexc.print_backtrace stdout;
- exit 2
- | e ->
- Printf.printf "Error: %s\n" (Printexc.to_string e);
- Printexc.print_backtrace stdout;
- exit 2
+ Masked_by (renamed, id) ->
+ let loc = find_id_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 \
+ capture an occurrence of an existing definition of %s"
+ name name'
View
43 ocamlwizard/refactor/resolve.ml
@@ -57,14 +57,7 @@ let lookup kind lid e =
in
wrap_lookup lid_to_str (kind2str kind) lookup lid e
-(*
-let find_in_tdecl kind tdecl =
- match kind, tdecl.type_kind with
- | Constructor, Type_variant cs ->
- (try find_map (function c, _ -> ic) cs)
-*)
-let find_in_tdecl kind tdecl = None
-
+(* Get the ident of a signature item, if it has one, and matches the kind. *)
let sig_item sort item =
match sort, item with
| Value, Sig_value (i, _)
@@ -75,10 +68,6 @@ let sig_item sort item =
| Cltype, Sig_class_type (i, _, _)
| Constructor, Sig_exception (i, _)
-> Some i
- | Constructor, Sig_type (_, _, tdecl)
- | Label, Sig_type (_, _, tdecl)
- -> find_in_tdecl sort tdecl
- (* To be completed with constructors and fields *)
| _ -> None
(* Get the ident of a summary item, if it has one, and matches the kind. *)
@@ -109,18 +98,6 @@ let parse_lid kind =
| Cltype -> parse Parser.clty_longident
| Annot -> assert false
-(*
-let sig_item_ops = function
- | Sig_value _ -> value_ops
- | Sig_module _ -> module_ops
- | Sig_type _ -> type_ops
- | Sig_exception _
- | Sig_modtype _
- | Sig_class _
- | Sig_class_type _ ->
- assert false
-*)
-
exception Abstract_modtype
(* Return the signature of a given (extended) module type path *)
@@ -156,14 +133,14 @@ let resolve_module_lid env lid =
let is_one_of id = List.exists (Ident.same id)
-exception Name of Ident.t
-exception Ident of Ident.t
+exception FoundName of Ident.t
+exception FoundIdent of Ident.t
let first_of_in_id ids name id =
if is_one_of id ids then
- raise (Ident id)
+ raise (FoundIdent id)
else if Ident.name id = name then
- raise (Name id)
+ raise (FoundName id)
(* The type itself is excluded *)
let first_of_in_type_decl kind ids name tdecl =
@@ -249,8 +226,8 @@ let find_in_signature kind name sg =
try
first_of_in_sig kind [] name sg
with
- | Name id -> id
- | Ident _ -> assert false
+ | FoundName id -> id
+ | FoundIdent _ -> assert false
(* True if p.name means id *)
let member_resolves_to kind env path name ids =
@@ -278,10 +255,10 @@ let check_in ~renamed first_of arg =
ignore (first_of arg);
assert false
with
- (Ident _ | Name _) as e ->
+ (FoundIdent _ | FoundName _) as e ->
match renamed, e with
- | (true, Ident _ | false, Name _) -> ()
- | (true, Name id | false, Ident id) -> raise (Masked_by (renamed, id))
+ | (true, FoundIdent _ | false, FoundName _) -> ()
+ | (true, FoundName id | false, FoundIdent id) -> raise (Masked_by (renamed, id))
| _ -> assert false
let check kind id name env summary =
View
13 ocamlwizard/refactor/resolve.mli
@@ -18,16 +18,13 @@
(** Different sort of names, and their bindings. *)
val kind2str : Env.path_sort -> string
-(*
-val lookup : Env.path_sort -> Longident.t -> Env.t -> Path.t
-val sig_item : Env.path_sort -> Types.signature_item -> Ident.t option
-summary_item
-*)
+
val parse_lid : Env.path_sort -> string -> Longident.t
-(*
-(** Return the specific operations associated with a signature item. *)
-val sig_item_ops : Types.signature_item -> specifics
+(* not used outside Resolve
+val lookup : Env.path_sort -> Longident.t -> Env.t -> Path.t
+val sig_item : Env.path_sort -> Types.signature_item -> Ident.t option
+val summary_item : ...
*)
(* Turns Not_found into a Failure with the unbound name *)
View
2 ocamlwizard/test/Makefile
@@ -12,7 +12,7 @@ R_CASES=renameSimple.ml renameSigNewCaptured.ml renameSigOldCaptured.ml \
renameModtype.ml renameModtypeInSig.ml \
renameModule.ml renameModuleInSig.ml renameModuleInFunctor.ml \
renameModuleInFunctorType.ml \
- renameConstructor.ml renameField.ml
+ renameConstructor.ml renameException.ml renameField.ml
R_TESTS=$(subst .ml,_rres.ml, $(R_CASES))
RES=match_cases_res.ml expansion_res.ml path_res.ml errors_res.ml \
View
7 ocamlwizard/test/expected/renameException_rres.ml
@@ -0,0 +1,7 @@
+exception Y
+
+let _ = match Y with Y -> ()
+
+let _ = try () with Y -> ()
+Renamed 1 definition(s) and 3 reference(s)
+
View
7 ocamlwizard/test/renameException_rres.ml
@@ -0,0 +1,7 @@
+exception Y
+
+let _ = match Y with Y -> ()
+
+let _ = try () with Y -> ()
+Renamed 1 definition(s) and 3 reference(s)
+

0 comments on commit b381187

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