Browse files

Replaced typedtree functors by functions, added reverse.

  • Loading branch information...
1 parent 9645e19 commit 6917724f9682b1b36722bec295375a8bcd2552cf Tiphaine Turpin committed Jul 6, 2011
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
6 ocamlwizard/Makefile.in
@@ -597,8 +597,10 @@ clean:
cd $(PATH_OWZ) ; $(rmcmd)
cd $(PATH_COMPLETION) ; $(rmcmd)
rm $(GENERATED)
- rm -f $(BIN).* $(BIN_GUI).* $(BIN_SCAN).* $(BIN_ANNOT).*
- make -C standard_library clean
+ rm -f $(BIN).byte $(BIN).opt $(BIN_GUI).* $(BIN_SCAN).* $(BIN_ANNOT).*
+ rm -f */*.backup_* */*/*.backup_*
+
+# make -C standard_library clean
clean_all:clean
cd labo/auto-test ; make clean
View
442 ocamlwizard/common/typedtreeOps.ml
@@ -27,20 +27,6 @@ type 'a funs = {
signature : signature -> 'a
}
-(*
-module type Process = sig
- type u
- val structure : structure -> u
- val signature : signature -> u
-end
-*)
-
-module type FindArgument = sig
- type t
- module IteratorArgument :
- functor (Action : sig val found : t -> unit end) -> IteratorArgument
-end
-
module MakeIterator
(Arg : IteratorArgument) = struct
@@ -57,253 +43,201 @@ module MakeIterator
end
-module Find (T : FindArgument) = struct
-
- open T
-
- module First = struct
- exception Found of t
- include
- MakeIterator
- (IteratorArgument
- (struct let found x = raise (Found x) end))
- let process s =
- try
- process s;
- raise Not_found
- with
- Found x ->
- x
- end
-
- module All = struct
- let l = ref []
-
- include
- MakeIterator
- (IteratorArgument
- (struct let found x = l := x :: !l end))
- let process s =
- l := []; (* Not proud of this *)
- process s;
- List.rev !l
- end
-
- let find = First.process
- let find_all = All.process
-
-end
-
-let find_pattern (type a) cond =
- let module M = Find (struct
- type t = a
- module IteratorArgument(Action : sig val found : t -> unit end) = struct
- include DefaultIteratorArgument
- let enter_pattern p =
- match cond p with
- | Some p -> Action.found p
- | None -> ()
- end
- end) in
- M.find
-
-let find_expression (type a) cond =
- let module M = Find (struct
- type t = a
- module IteratorArgument(Action : sig val found : t -> unit end) = struct
- include DefaultIteratorArgument
- let enter_expression p =
- match cond p with
- | Some p -> Action.found p
- | None -> ()
- end
- end) in
- M.find
-
-(*
-
-module type FindArgument = sig
- type t
- val pattern : pattern -> t option
- val expression : expression -> t option
-(*
- val structure : structure -> t option
- val value_description : value_description -> t option
- val type_declaration : type_declaration -> t option
- val exception_declaration :
- exception_declaration -> t option
- val package_type : package_type -> t option
- val signature : signature -> t option
- val signature_item : signature_item -> t option
- val modtype_declaration : modtype_declaration -> t option
- val module_type : module_type -> t option
- val module_expr : module_expr -> t option
- val with_constraint : with_constraint -> t option
- val class_expr : class_expr -> t option
- val class_signature : class_signature -> t option
- val class_description : class_description -> t option
- val class_type_declaration :
- class_type_declaration -> t option
- val class_infos : 'a class_infos -> t option
- val class_type : class_type -> t option
- val class_type_field : class_type_field -> t option
- val core_type : core_type -> t option
- val core_field_type : core_field_type -> t option
- val class_structure : class_structure -> t option
- val class_field : class_field -> t option
- val structure_item : structure_item -> t option
- val bindings : rec_flag -> t option
- val binding : pattern -> expression -> t option
-*)
- end
-
-module DefaultFindArgument (T : sig type t end) = struct
- include T
- let pattern _ = None
- let expression _ = None
-end
-
-module FindGeneric
- (T : FindArgument)
- (Action : sig
- type result
- val found : T.t -> unit
- val find : ('a -> unit) -> 'a -> result
- end)
- = struct
-
- open T
-
- include
- Typedtree.MakeIterator (struct
-
- (* Should eventually be removed *)
- include Typedtree.DefaultIteratorArgument
-
- let enter node p =
- match node p with
- | Some x -> Action.found x
- | None -> ()
-
- let enter_pattern = enter pattern
- let enter_expression = enter expression
+type node = [
+ `structure of structure
+| `value_description of value_description
+| `type_declaration of type_declaration
+| `exception_declaration of exception_declaration
+| `pattern of pattern
+| `expression of expression
+| `package_type of package_type
+| `signature of signature
+| `signature_item of signature_item
+| `modtype_declaration of modtype_declaration
+| `module_type of module_type
+| `module_expr of module_expr
+| `with_constraint of with_constraint
+| `class_expr of class_expr
+| `class_signature of class_signature
+| `class_description of class_description
+| `class_type_declaration of class_type_declaration
+| `class_infos of unit class_infos
+| `class_type of class_type
+| `class_type_field of class_type_field
+| `core_type of core_type
+| `core_field_type of core_field_type
+| `class_structure of class_structure
+| `class_field of class_field
+| `structure_item of structure_item
+| `binding of pattern * expression
+| `bindings of Asttypes.rec_flag
+]
+
+let node_kind = function
+ | `structure _ -> "structure"
+ | `value_description _ -> "value_description"
+ | `type_declaration _ -> "type_declaration"
+ | `exception_declaration _ -> "exception_declaration"
+ | `pattern _ -> "pattern"
+ | `expression _ -> "expression"
+ | `package_type _ -> "package_type"
+ | `signature _ -> "signature"
+ | `signature_item _ -> "signature_item"
+ | `modtype_declaration _ -> "modtype_declaration"
+ | `module_type _ -> "module_type"
+ | `module_expr _ -> "module_expr"
+ | `with_constraint _ -> "with_constraint"
+ | `class_expr _ -> "class_expr"
+ | `class_signature _ -> "class_signature"
+ | `class_description _ -> "class_description"
+ | `class_type_declaration _ -> "class_type_declaration"
+ | `class_infos _ -> "class_infos"
+ | `class_type _ -> "class_type"
+ | `class_type_field _ -> "class_type_field"
+ | `core_type _ -> "core_type"
+ | `core_field_type _ -> "core_field_type"
+ | `class_structure _ -> "class_structure"
+ | `class_field _ -> "class_field"
+ | `structure_item _ -> "structure_item"
+ | `binding _ -> "binding"
+ | `bindings _ -> "bindings"
+
+let iterator ~enter ~leave =
+ let module Iterator = MakeIterator(struct
+
+ let enter_structure x = enter (`structure x)
+ let enter_value_description x = enter (`value_description x)
+ let enter_type_declaration x = enter (`type_declaration x)
+ let enter_exception_declaration x = enter (`exception_declaration x)
+ let enter_pattern x = enter (`pattern x)
+ let enter_expression x = enter (`expression x)
+ let enter_package_type x = enter (`package_type x)
+ let enter_signature x = enter (`signature x)
+ let enter_signature_item x = enter (`signature_item x)
+ let enter_modtype_declaration x = enter (`modtype_declaration x)
+ let enter_module_type x = enter (`module_type x)
+ let enter_module_expr x = enter (`module_expr x)
+ let enter_with_constraint x = enter (`with_constraint x)
+ let enter_class_expr x = enter (`class_expr x)
+ let enter_class_signature x = enter (`class_signature x)
+ let enter_class_description x = enter (`class_description x)
+ let enter_class_type_declaration x = enter (`class_type_declaration x)
+ let enter_class_infos x = enter (`class_infos { x with ci_expr = () })
+ let enter_class_type x = enter (`class_type x)
+ let enter_class_type_field x = enter (`class_type_field x)
+ let enter_core_type x = enter (`core_type x)
+ let enter_core_field_type x = enter (`core_field_type x)
+ let enter_class_structure x = enter (`class_structure x)
+ let enter_class_field x = enter (`class_field x)
+ let enter_structure_item x = enter (`structure_item x)
+ let enter_binding x y = enter (`binding (x, y))
+ let enter_bindings x = enter (`bindings x)
+
+ let leave_structure x = leave (`structure x)
+ let leave_value_description x = leave (`value_description x)
+ let leave_type_declaration x = leave (`type_declaration x)
+ let leave_exception_declaration x = leave (`exception_declaration x)
+ let leave_pattern x = leave (`pattern x)
+ let leave_expression x = leave (`expression x)
+ let leave_package_type x = leave (`package_type x)
+ let leave_signature x = leave (`signature x)
+ let leave_signature_item x = leave (`signature_item x)
+ let leave_modtype_declaration x = leave (`modtype_declaration x)
+ let leave_module_type x = leave (`module_type x)
+ let leave_module_expr x = leave (`module_expr x)
+ let leave_with_constraint x = leave (`with_constraint x)
+ let leave_class_expr x = leave (`class_expr x)
+ let leave_class_signature x = leave (`class_signature x)
+ let leave_class_description x = leave (`class_description x)
+ let leave_class_type_declaration x = leave (`class_type_declaration x)
+ let leave_class_infos x = leave (`class_infos { x with ci_expr = () })
+ let leave_class_type x = leave (`class_type x)
+ let leave_class_type_field x = leave (`class_type_field x)
+ let leave_core_type x = leave (`core_type x)
+ let leave_core_field_type x = leave (`core_field_type x)
+ let leave_class_structure x = leave (`class_structure x)
+ let leave_class_field x = leave (`class_field x)
+ let leave_structure_item x = leave (`structure_item x)
+ let leave_binding x y = leave (`binding (x, y))
+ let leave_bindings x = leave (`bindings x)
end)
-
- let structure = Action.find iter_structure
- let signature = Action.find iter_signature
-
- let process = function
- | `structure s -> structure s
- | `signature s -> signature s
-
- let process' = {
- structure = structure;
- signature = signature
- }
-
-
-end
-
-module Find(T : FindArgument) = struct
-
- module Generic = FindGeneric (T)
-
- module First =
- Generic
- (struct
-
- type result = T.t
- exception Found of T.t
-
- let found x = raise (Found x)
-
- let find iter s =
- try
- iter s;
- raise Not_found
- with
- Found x ->
- x
-
- end)
-
- module All =
- Generic
- (struct
-
- type result = T.t list
-
- let l = ref []
-
- let found x = l := x :: !l
-
- let find iter s =
- l := []; (* Not proud of this *)
- iter s;
- List.rev !l
-
- end)
-
- let find = First.process
- let find' = First.process'
- let find_all = All.process
- let find_all' = All.process'
-
-end
-
-let find_pattern (type a) cond =
- let module M = Find (struct
- include DefaultFindArgument (struct type t = a end)
- let pattern = cond
- end) in
- M.find
-
-let find_expression (type a) cond =
- let module M = Find (struct
- include DefaultFindArgument (struct type t = a end)
- let expression = cond
- end) in
- M.find
-
-*)
+ in
+ Iterator.process
+
+let find_all_map cond s =
+ let l = ref [] in
+ let enter x =
+ match cond x with
+ | Some x -> l := x :: !l
+ | None -> ()
+ and leave _ = () in
+ iterator ~enter ~leave s;
+ List.rev !l
+
+let find_map priority (type a) cond s =
+ let module M = struct exception Found of a end in
+ let visit x =
+ match cond x with
+ | Some x -> raise (M.Found x)
+ | None -> ()
+ in
+ let enter, leave = match priority with
+ | `innermost -> ignore, visit
+ | `outermost -> visit, ignore
+ in
+ try
+ iterator ~leave ~enter s;
+ raise Not_found
+ with
+ M.Found x -> x
let contains loc (b', e') =
let b, e = Util.get_c_num loc in
b <= b' && e' <= e
-(* This implementation is notably inefficient. *)
-let find_map_innermost (type a) s cond =
- let module M = Find (struct
- type t = a
- module IteratorArgument(Action : sig val found : t -> unit end) = struct
- include DefaultIteratorArgument
- let found x =
- match cond x with
- | Some x -> Action.found x
- | None -> ()
-
- let leave_pattern p = found (`pattern p)
- let leave_expression e = found (`expression e)
- let leave_structure_item i = found (`structure_item i)
- let leave_signature_item i = found (`signature_item i)
-
- end
- end) in
- M.find s
-
-let locate_innermost s loc =
- find_map_innermost s
+let locate priority loc =
+ find_map priority
(function t ->
if
- contains
- (match t with
- | `pattern p -> p.pat_loc
- | `expression e -> e.exp_loc
- | `structure_item i -> i.str_loc
- | `signature_item i -> i.sig_loc)
+ (match t with
+ | `pattern p -> contains p.pat_loc
+ | `expression e -> contains e.exp_loc
+ | `structure_item i -> contains i.str_loc
+ | `signature_item i -> contains i.sig_loc
+ | _ -> function _ -> false)
loc
- then
- Some t
- else
- None)
+ then Some t
+ else None)
+
+let find_pattern priority cond =
+ find_map priority (function `pattern p -> cond p | _ -> None)
+
+let find_expression priority cond =
+ find_map priority (function `expression e -> cond e | _ -> None)
+
+module NodeTbl = Hashtbl.Make
+ (struct
+ type t = node
+ let equal = ( == )
+ let hash = Hashtbl.hash
+ end)
+
+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 _ =
+ path :=
+ match !path with
+ | _ :: p -> p
+ | _ -> assert false
+ in
+ iterator ~enter ~leave s;
+ t
View
103 ocamlwizard/common/typedtreeOps.mli
@@ -33,63 +33,64 @@ type 'a funs = {
}
*)
-(** Generic interface with functors *)
+(** The common type for all typedtree nodes. *)
+type node = [
+ `structure of structure
+| `value_description of value_description
+| `type_declaration of type_declaration
+| `exception_declaration of exception_declaration
+| `pattern of pattern
+| `expression of expression
+| `package_type of package_type
+| `signature of signature
+| `signature_item of signature_item
+| `modtype_declaration of modtype_declaration
+| `module_type of module_type
+| `module_expr of module_expr
+| `with_constraint of with_constraint
+| `class_expr of class_expr
+| `class_signature of class_signature
+| `class_description of class_description
+| `class_type_declaration of class_type_declaration
+| `class_infos of unit class_infos
+| `class_type of class_type
+| `class_type_field of class_type_field
+| `core_type of core_type
+| `core_field_type of core_field_type
+| `class_structure of class_structure
+| `class_field of class_field
+| `structure_item of structure_item
+| `binding of pattern * expression
+| `bindings of Asttypes.rec_flag
+]
-module type FindArgument = sig
- type t
- module IteratorArgument :
- functor (Action : sig val found : t -> unit end) -> IteratorArgument
-end
+(** Return the constructor name, as a string. *)
+val node_kind : node -> string
-(*
-(** The functions to provide to Find. *)
-module type FindArgument = sig
- type t
- val pattern : pattern -> t option
- val expression : expression -> t option
-end
-
-(** Default functions that do nothing: include this and overwrite only
- what you need. *)
-module DefaultFindArgument :
- functor (T : sig type t end) -> FindArgument
- with type t = T.t
-*)
+(** Traverse a typedtree, calling the provided enter and leave
+ functions just before and just after each node, respectively. *)
+val iterator : enter:(node -> unit) -> leave:(node -> unit) -> unit sfun
-(** Find and find_all. *)
-module Find :
- functor (T : FindArgument) -> sig
- val find : T.t sfun
- val find_all : T.t list sfun
-(*
- val find' : T.t funs
- val find_all' : T.t list funs
-*)
- end
+(** Find the innermost node for which some condition holds. *)
+val find_map : [`outermost | `innermost] -> (node -> 'a option) -> 'a sfun
+
+(** Find all nodes satisfying some condition. *)
+val find_all_map : (node -> 'a option) -> 'a list sfun
+
+(** Return the innermost subtree whose locations contains a given
+ character number interval [a, b[. *)
+val locate : [`outermost | `innermost] -> int * int -> node sfun
(** Finding only one sort of nodes: *)
-val find_pattern : (Typedtree.pattern -> 'a option) -> 'a sfun
-val find_expression : (Typedtree.expression -> 'a option) -> 'a sfun
+val find_pattern :
+ [`outermost | `innermost] -> (Typedtree.pattern -> 'a option) -> 'a sfun
+val find_expression :
+ [`outermost | `innermost] -> (Typedtree.expression -> 'a option) -> 'a sfun
-(** Find the innermost subtree for which some condition holds. *)
-val find_map_innermost :
- [ `signature of signature | `structure of structure ] ->
- ([
- `pattern of pattern
- | `expression of expression
- | `structure_item of structure_item
- | `signature_item of signature_item
- ] -> 'a option) -> 'a
+module NodeTbl : Hashtbl.S with type key = node
-(** Return the innermost subtree whose locations contains a given
- character number interval [a, b[. *)
-val locate_innermost :
- [ `signature of signature | `structure of structure ] ->
- int * int -> [
- `pattern of pattern
- | `expression of expression
- | `structure_item of structure_item
- | `signature_item of signature_item
- ]
+type father_table = node NodeTbl.t
+
+val reverse : father_table sfun
View
6 ocamlwizard/completion/typing/expression_typing.ml
@@ -59,12 +59,12 @@ let locate_expression s loc =
else
None
in
- find_expression expression (`structure s)
+ find_expression `outermost expression (`structure s)
(* Maybe risky, because different sorts of nodes sometimes have the
same location. *)
let locate_expression s loc =
- match TypedtreeOps.locate_innermost (`structure s) (Util.get_c_num loc) with
+ match TypedtreeOps.locate `innermost (Util.get_c_num loc) (`structure s) with
| `expression e -> e
| _ -> raise Not_found
@@ -97,5 +97,5 @@ let locate_expansion_place s (b, e as loc) =
) else
None
in
- find_pattern pattern (`structure s)
+ find_pattern `outermost pattern (`structure s)
View
7 ocamlwizard/owz.sh
@@ -0,0 +1,7 @@
+#!/bin/bash
+OWZ=owz.opt
+PROJECT_DIR=`$OWZ -find-project-dir $* 2>/dev/null`
+echo ocamlwizard $* >$PROJECT_DIR/.ocamlwizard-stderr
+OCAMLLIB=/usr/local/lib/ocaml $OWZ -debug -backtrace $* \
+2>>$PROJECT_DIR/.ocamlwizard-stderr | tee $PROJECT_DIR/.ocamlwizard-stdout
+exit ${PIPESTATUS[0]}
View
191 ocamlwizard/refactor/findName.ml
@@ -32,86 +32,130 @@ type occurrence_kind = [
| `mty_ident
]
+(* Is that meaningful ? *)
+let rec path2loc idents = function
+ | Path.Pident s -> Location.StringTbl.find idents (Ident.name s)
+ | Path.Pdot (p, s, _) ->
+ let l = path2loc idents p
+ and l' = Location.StringTbl.find idents s in
+ {l with Location.loc_end = l'.Location.loc_end}
+ | Path.Papply (p, p') -> failwith "not implemented"
+
+let rec env_of_node father_table n =
+ let up () =
+ match NodeTbl.find_all father_table n with
+ | [father] -> env_of_node father_table father
+ | [] -> failwith "root"
+ | _ -> failwith "ambiguous"
+ in
+ match n with
+ | `core_type _
+ | `pattern _ -> up ()
+ | `structure_item { str_desc = Tstr_type _ } -> failwith "env"
+ | _ -> failwith ("env_of_node: unsupported case " ^ node_kind 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. *)
-module Occurrence =
- Find
- (struct
- type t = Location.t * (Env.t * occurrence_kind)
- module IteratorArgument(Action : sig val found : t -> unit end) = struct
- include DefaultIteratorArgument
-
- let found loc env occ = Action.found (loc, (env, occ))
-
- let enter_expression e =
- match e.exp_desc with
- | Texp_ident _ -> found e.exp_loc e.exp_env `exp_ident
- (* If the renamed ident is not a module or modtype,
- then we could filter according to the right_most
- ident. Otherwise, there is no way to know if we
- need renaming until we get the longident. *)
-
-(* needed for modules
- | Texp_open _ -> found e.exp_loc e.exp_env `exp_open
+let find_all_occurrences idents tree =
+ 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
+ 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)
+*)
+(*
+ | `core_type t ->
+ (match t.ctyp_desc with
+ | Ttyp_constr (p, _) -> found (loc p) (env n) `core_type_type
+ | _ -> None)
*)
- (* No instance variables for now *)
- | Texp_instvar (_self, var)
- | Texp_setinstvar (_self, var, _) -> ()
- | Texp_override (_self, modifs) -> ()
+ | `expression e ->
+ (match e.exp_desc with
+ | Texp_ident _ -> found e.exp_loc e.exp_env `exp_ident
+ (* If the renamed ident is not a module or modtype,
+ then we could filter according to the right_most
+ ident. Otherwise, there is no way to know if we
+ need renaming until we get the longident. *)
- | _ -> ()
+ (* needed for modules
+ | Texp_open _ -> found e.exp_loc e.exp_env `exp_open
+ *)
- let enter_module_expr m =
- match m.mod_desc with
- | Tmod_ident _ -> found m.mod_loc m.mod_env `mod_ident
+ (* No instance variables for now *)
+ | Texp_instvar (_self, var)
+ | Texp_setinstvar (_self, var, _) -> None
+ | Texp_override (_self, modifs) -> None
- | _ -> ()
-
-(* needed for modules
- let enter_module_type t =
- match t.mty_desc with
- | Tmty_ident p -> found t.mty_loc (assert false) `mty_ident
+ | _ -> None)
- | _ -> ()
+ | `module_expr m ->
+ (match m.mod_desc with
+ | Tmod_ident _ -> found m.mod_loc m.mod_env `mod_ident
- let enter_structure_item i =
- match i.str_desc with
- | Tstr_open _ -> found i.str_loc (assert false) `str_open
+ | _ -> None)
- | _ -> ()
+ | `module_type t ->
+ (match t.mty_desc with
+ (*
+ | Tmty_ident p -> found t.mty_loc (assert false) `mty_ident
+ *)
+(*
+ | Tmty_with (_, cs) ->
+ List.iter
+ (function p, c -> match c with
+ | Twith_type _ -> ()
+ | _ -> ())
+ cs
*)
+ | _ -> None)
-(* needed for modules
- let enter_module_type t =
- match t.mty_desc with
- | Tmty_with _ ->
-*)
-(*
- let enter_with_constraint = function
- | Twith_module _
- | Twith_modsubst _ ->
+ | `with_constraint _ -> None
+ (*
+ | Twith_module _
+ | Twith_modsubst _ ->
found (assert false) (assert false) (assert false)
+ *)
- | _ -> ()
+ (* needed for modules
+ | `structure_item i =
+ match i.str_desc with
+ | Tstr_open _ -> found i.str_loc (assert false) `str_open
- let enter_signature_item i =
- match i.sig_desc with
+ | _ -> ()
+ *)
+
+ (* needed for modules
+ | `module_type t =
+ match t.mty_desc with
+ | Tmty_with _ ->
+ *)
+ (*
+
+ | `signature_item i =
+ match i.sig_desc with
| Tsig_open _ -> found i.sig_loc (assert false) `sig_open
| _ -> ()
-*)
- end
+ *)
+ | _ -> None)
+ tree
- end)
-
-let get_occurrences s =
+let get_occurrences idents s =
List.sort
(fun (loc, _) (loc', _) ->
let open Lexing in
compare loc.loc_start.pos_cnum loc.loc_end.pos_cnum)
- (Occurrence.find_all (`structure s))
+ (find_all_occurrences idents s)
let extract_longident (loc, s, (env, occ)) =
let parse parser s =
@@ -135,35 +179,10 @@ let extract_longident (loc, s, (env, occ)) =
in
(loc, ast, (env, kind))
-let get_lids file ast =
+let get_lids file idents ast =
List.map
extract_longident
- (source_locations file (get_occurrences ast))
-
-
-(*
-let get_occurrences s =
- let l = ref [] in
- let module Rename =
- MakeIterator
- (struct
- include DefaultIteratorArgument
-
- let leave_pattern p =
- let enter_expression e =
- match e.exp_desc with
- | Texp_ident _ ->
- (* If the renamed ident is not a module or modtype,
- then we could filter according to the right_most
- ident. Otherwise, there is no way to know if we
- need renaming until we get the longident. *)
- l := (e.exp_loc, e) :: !l
- | _ -> ()
- end)
- in
- Rename.iter_structure s;
- !l
-*)
+ (source_locations file (get_occurrences idents ast))
let ident_of_subtree = function
| `pattern {pat_desc = Tpat_var id}
@@ -174,13 +193,17 @@ let ident_of_subtree = function
-> module_ops, id
| `structure_item {str_desc = Tstr_modtype (id, _)}
-> modtype_ops, id
+ | `structure_item {str_desc = Tstr_type types}
+ -> (match types with
+ | [id, _] -> type_ops, id
+ | _ -> failwith "multiple type definitions are not yes supported")
| _ -> raise Not_found
(* Should be almost complete for expressions, but this is not a safety
requirement anyway. *)
let locate_renamed_id s loc =
try
- let kind, id = ident_of_subtree (locate_innermost s loc) in kind, id
+ let kind, id = ident_of_subtree (locate `innermost loc s) in kind, id
with Not_found ->
invalid_arg "rename"
View
4 ocamlwizard/refactor/findName.mli
@@ -25,7 +25,9 @@ val get_occurrences :
*)
val get_lids :
- string -> Typedtree.structure ->
+ string ->
+ Location.string_table ->
+ [ `signature of Typedtree.signature | `structure of Typedtree.structure ]->
(Location.t * Longident.t * (Env.t * Resolve.specifics)) list
val locate_renamed_id :
View
4 ocamlwizard/refactor/rename.ml
@@ -229,7 +229,7 @@ let backup file =
let rename_in_file renamed_kind id name' file (s, idents) =
(* Collect constraints requiring simultaneous renaming *)
- let constraints, includes = collect_signature_inclusions s in
+ let constraints, includes = collect_signature_inclusions (`structure s) in
(* Deduce the minimal set of ids to rename *)
let ids, implicit_refs =
@@ -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 s in
+ let lids = get_lids file idents (`structure s) in
(* Check that our new name will not capture other occurrences *)
check_lids renamed_kind ids name' lids;
View
83 ocamlwizard/refactor/renamePropagation.ml
@@ -58,6 +58,7 @@ let rec constraint_modtype incs env t t' =
| `func (_, arg, res), `func (_, arg', res') ->
constraint_modtype incs env arg arg';
constraint_modtype incs env res res'
+ | _ -> assert false
with
Abstract_modtype -> ()
@@ -86,60 +87,56 @@ and constraint_signature incs env sg sg' =
let collect_signature_inclusions s =
let incs = ref ConstraintSet.empty
and includes = ref IncludeSet.empty in
- let module Rename =
- MakeIterator
- (struct
- include DefaultIteratorArgument
-
- let enter_module_expr m =
- match m.mod_desc with
+ let enter = function
+ | `module_expr m ->
+ (match m.mod_desc with
(* TODO : fix environments here *)
- | Tmod_constraint (m, t, cs, co) ->
- constraint_modtype incs m.mod_env m.mod_type t
+ | Tmod_constraint (m, t, cs, co) ->
+ constraint_modtype incs m.mod_env m.mod_type t
(* what about cs and co ? *)
- | Tmod_apply (f, m, co) ->
- let (_, t, _) = modtype_functor f.mod_env f.mod_type in
- constraint_modtype incs f.mod_env m.mod_type t
+ | Tmod_apply (f, m, co) ->
+ let (_, t, _) = modtype_functor f.mod_env f.mod_type in
+ constraint_modtype incs f.mod_env m.mod_type t
(* what about co ? *)
- | Tmod_unpack _ -> assert false (* TODO *)
+ | Tmod_unpack _ -> assert false (* TODO *)
- | Tmod_ident _
- | Tmod_structure _
- | Tmod_functor _ -> ()
+ | Tmod_ident _
+ | Tmod_structure _
+ | Tmod_functor _ -> ())
- (* To handle include, we need the correspondency between
- renamed idents which is currently lost. *)
- let enter_structure_item s = match s.str_desc with
- | Tstr_include (m, ids) ->
+ (* To handle include, we need the correspondency between
+ renamed idents which is currently lost. *)
+ | `structure_item s ->
+ (match s.str_desc with
+ | Tstr_include (m, ids) ->
(* We may have
- module G(X : sig module type T module X : T end) =
- struct include X end *)
-
- (try
- let sign = modtype_signature m.mod_env m.mod_type in
- includes := IncludeSet.add (sign, ids) !includes
- with Abstract_modtype -> ())
-
- | Tstr_eval _
- | Tstr_value _
- | Tstr_primitive _
- | Tstr_type _
- | Tstr_exception _
- | Tstr_exn_rebind _
- | Tstr_module _
- | Tstr_recmodule _
- | Tstr_modtype _
- | Tstr_open _
- | Tstr_class _
- | Tstr_class_type _ -> ()
-
- end)
+ module G(X : sig module type T module X : T end) =
+ struct include X end *)
+
+ (try
+ let sign = modtype_signature m.mod_env m.mod_type in
+ includes := IncludeSet.add (sign, ids) !includes
+ with Abstract_modtype -> ())
+
+ | Tstr_eval _
+ | Tstr_value _
+ | Tstr_primitive _
+ | Tstr_type _
+ | Tstr_exception _
+ | Tstr_exn_rebind _
+ | Tstr_module _
+ | Tstr_recmodule _
+ | Tstr_modtype _
+ | Tstr_open _
+ | Tstr_class _
+ | Tstr_class_type _ -> ())
+ | _ -> ()
in
- Rename.iter_structure s;
+ TypedtreeOps.iterator ~enter ~leave:ignore s;
!incs, !includes
(* An equivalence relation is represented by a mapping from elements
View
2 ocamlwizard/refactor/renamePropagation.mli
@@ -30,7 +30,7 @@ module IncludeSet : Set.S
(** Collect the set of signature inclusion constraints and include
statements for a structure. *)
val collect_signature_inclusions :
- Typedtree.structure -> ConstraintSet.t * IncludeSet.t
+ (ConstraintSet.t * IncludeSet.t) TypedtreeOps.sfun
(** Return the minimal set of idents which may be renamed and contains
a given id, as well as the "implicit" bindings of signature
View
44 ocamlwizard/refactor/resolve.ml
@@ -24,6 +24,7 @@ type sort = [
| `Module
| `Modtype
| `Value
+ | `Type
]
type specifics = {
@@ -46,6 +47,13 @@ let value_ops = {
summary_item = function Env_value (_, i, _) -> Some i | _ -> None
}
+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
+}
+
let module_ops = {
sort = `Module;
lookup = keep_first "module" Env.lookup_module;
@@ -63,7 +71,7 @@ let modtype_ops = {
let sig_item_ops = function
| Sig_value _ -> value_ops
| Sig_module _ -> module_ops
- | Sig_type _
+ | Sig_type _ -> type_ops
| Sig_exception _
| Sig_modtype _
| Sig_class _
@@ -204,37 +212,3 @@ and check_in_sig kind id name sg =
check_in (first_of_in_sig kind id name) sg
with
Not_found -> invalid_arg "ckeck_in_sig"
-
-(*
-let check kind id name env summary =
- try
- ignore (first_of kind id name env summary);
- assert false
- with
- | Ident _ -> ()
- | Name id -> raise (Masked_by id)
-
-let check_in_sig kind id name sg =
- try
- ignore (first_of_in_sig kind id name sg);
- assert false
- with
- | Ident _ -> ()
- | Name id -> raise (Masked_by id)
-
-let check_other kind id name env summary =
- try
- ignore (first_of kind id name env summary);
- assert false
- with
- | Name _ -> ()
- | Ident id -> raise (Masked_by id)
-
-let check_other_in_sig kind id name sg =
- try
- ignore (first_of_in_sig kind id name sg);
- assert false
- with
- | Name _ -> ()
- | Ident id -> raise (Masked_by id)
-*)
View
5 ocamlwizard/refactor/resolve.mli
@@ -17,8 +17,8 @@
(** Different sort of names, and their bindings. *)
-type sort = [ `Modtype | `Module | `Value ]
-(* TODO: 'Type... *)
+type sort = [ `Modtype | `Module | `Value | `Type ]
+(* TODO: everything else... *)
type specifics = {
sort : sort;
@@ -28,6 +28,7 @@ type specifics = {
}
val value_ops : specifics
+val type_ops : specifics
val module_ops : specifics
val modtype_ops : specifics
View
31 ocamlwizard/test/Makefile
@@ -7,7 +7,8 @@ R_CASES=renameSimple.ml renameSigNewCaptured.ml renameSigOldCaptured.ml \
renameIncludeNewCaptured.ml renameIncludeOldCaptured.ml \
renameOpenNewCaptured.ml renameOpenOldCaptured.ml \
renameMultiple.ml renameProp.ml renamePropFunctor.ml \
- renamePropFunctorNoApp.ml renameModtype.ml
+ renamePropFunctorNoApp.ml
+# renameModtype.ml
R_TESTS=$(subst .ml,_rres.ml, $(R_CASES))
RES=match_cases_res.ml expansion_res.ml path_res.ml errors_res.ml \
@@ -51,12 +52,12 @@ match_cases_res.ml: $(M_TESTS)
cat $^ >$@
%_mres.ml: %.ml %_mcomp.ml
- tail -n 1 $< >$@ ; echo "=>" >>$@ ; \
+ tail -n 1 $< >$@ ; /bin/echo "=>" >>$@ ; \
head -c `grep -o -b \\\\$$ $< | cut -d : -f 1` $< | tail -n 1 >>$@ ; \
- cat $(subst .ml,_mcomp.ml, $<) >>$@ ; echo -e EOF\\n >>$@
+ cat $(subst .ml,_mcomp.ml, $<) >>$@ ; /bin/echo -e EOF\\n >>$@
%_mcomp.ml: %.ml %_no_dollar.ml $(OWZ)
- $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
+ - $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
-pos `grep -o -b \\\\$$ $< | cut -d : -f 1` -printer ocaml-pp >$@
@@ -74,13 +75,13 @@ expansion_res.ml: $(PE_TESTS)
cat $^ >$@
%_peres.ml: %.ml %_pecomp.ml
- tail -n 1 $< >$@ ; echo "=>" >>$@ ; \
+ tail -n 1 $< >$@ ; /bin/echo "=>" >>$@ ; \
head -c `grep -o -b \\\\$$ $< | cut -d : -f 1` $< | tail -n 1 >>$@ ; \
- cat $(subst .ml,_pecomp.ml, $<) >>$@ ; echo -e EOF\\n >>$@
+ cat $(subst .ml,_pecomp.ml, $<) >>$@ ; /bin/echo -e EOF\\n >>$@
# We use tail to perform +1 and +2 :-(
%_pecomp.ml: %.ml %_no_dollar.ml $(OWZ)
- $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
+ - $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
-pos `tail -c +3 $< | grep -o -b '\->' | tail -n 1 | cut -d : -f 1` \
-expand `grep -o -b \\\\$$ $< | cut -d : -f 1`-\
`tail -c +2 $< | grep -o -b € | cut -d : -f 1` \
@@ -100,27 +101,27 @@ path_res.ml: $(PC_TESTS)
cat $^ >$@
%_pcres.ml: %.ml %_pccomp.ml
- tail -n 1 $< >$@ ; echo "=>" >>$@ ; \
+ tail -n 1 $< >$@ ; /bin/echo "=>" >>$@ ; \
head -c `grep -o -b \\\\$$ $< | cut -d : -f 1` $< | tail -n 1 >>$@ ; \
- cat $(subst .ml,_pccomp.ml, $<) >>$@ ; echo -e EOF\\n >>$@
+ cat $(subst .ml,_pccomp.ml, $<) >>$@ ; /bin/echo -e EOF\\n >>$@
# We use tail to perform +1 and +2 :-(
%_pccomp.ml: %.ml %_no_dollar.ml $(OWZ)
- $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
+ - $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
-pos `grep -o -b \\\\$$ $< | cut -d : -f 1` -printer ocaml-pp >$@
# Completing with errors
########################
errors_res.ml: errors.ml errors_comp.ml
- cat $< >$@ ; echo "=>" >>$@ ; \
+ cat $< >$@ ; /bin/echo "=>" >>$@ ; \
head -c `grep -o -b \\\\$$ $< | cut -d : -f 1` $< | tail -n 1 >>$@ ; \
- cat $(subst .ml,_comp.ml, $<) >>$@ ; echo -e EOF\\n >>$@
+ cat $(subst .ml,_comp.ml, $<) >>$@ ; /bin/echo -e EOF\\n >>$@
# We use tail to perform +1 and +2 :-(
errors_comp.ml: errors.ml errors_no_dollar.ml $(OWZ)
- $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
+ - $(OCAMLWIZARD) completion $(subst .ml,_no_dollar.ml, $<) \
-pos `grep -o -b \\\\$$ $< | cut -d : -f 1` -printer ocaml-pp >$@
@@ -130,10 +131,10 @@ errors_comp.ml: errors.ml errors_no_dollar.ml $(OWZ)
%_rres.ml: %.ml %_no_dollar.ml %_no_dollar.cmt $(OWZ)
mv $(subst .ml,_no_dollar.ml, $<) $@
mv $(subst .ml,_no_dollar.cmt, $<) $(subst .ml,.cmt, $@)
- $(OCAMLWIZARD) refactor -rename \
+ - $(OCAMLWIZARD) refactor -rename \
`grep -o -b \\\\$$ $< | cut -d : -f 1`-\
`tail -c +2 $< | grep -o -b € | cut -d : -f 1` \
- x y $@
+ y $@
# cat ../../.ocamlwizard-stderr >> $@

0 comments on commit 6917724

Please sign in to comment.