Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
595 lines (555 sloc) 20 KB
(*************************************************************************)
(* *)
(* OCaml LablTk library *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique and Kyoto University. All rights reserved. *)
(* This file is distributed under the terms of the GNU Library *)
(* General Public License, with the special exception on linking *)
(* described in file ../../../LICENSE. *)
(* *)
(*************************************************************************)
(* $Id: searchid.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
open Asttypes
open StdLabels
open Location
open Longident
open Path
open Types
open Typedtree
open Env
open Btype
open Ctype
module Stat = struct
(** search statistics *)
let type_included = ref 0
let type_exact = ref 0
let symbol = ref 0
let reset () =
type_included := 0;
type_exact := 0;
symbol := 0;
()
type t = {
type_included : int;
type_exact : int;
symbol : int;
time : float
}
let format ppf t =
Format.fprintf ppf "%d type checks (inclusion: %d, exact: %d), %d symbol checks (%0.2f secs)"
(t.type_included + t.type_exact)
t.type_included
t.type_exact
t.symbol
t.time
let get f v =
reset ();
let start = Unix.gettimeofday () in
let res = try `Ok (f v) with e -> `Error e in
let end_ = Unix.gettimeofday () in
res, { type_included = !type_included;
type_exact = !type_exact;
symbol = !symbol;
time = end_ -. start
}
end
(* only initial here, but replaced by Pervasives later *)
let start_env = ref initial
let module_list = ref []
type pkind =
Pvalue
| Ptype
| Plabel
| Pconstructor
| Pmodule
| Pmodtype
| Pclass
| Pcltype
let string_of_kind = function
Pvalue -> "v"
| Ptype -> "t"
| Plabel -> "l"
| Pconstructor -> "cn"
| Pmodule -> "m"
| Pmodtype -> "s"
| Pclass -> "c"
| Pcltype -> "ct"
let rec longident_of_path = function
Pident id -> Lident (Ident.name id)
| Pdot (path, s, _) -> Ldot (longident_of_path path, s)
| Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2)
let rec remove_prefix lid ~prefix =
let rec remove_hd lid ~name =
match lid with
Ldot (Lident s1, s2) when s1 = name -> Lident s2
| Ldot (l, s) -> Ldot (remove_hd ~name l, s)
| _ -> raise Not_found
in
match prefix with
[] -> lid
| name :: prefix ->
try remove_prefix ~prefix (remove_hd ~name lid)
with Not_found -> lid
let rec permutations l = match l with
[] | [_] -> [l]
| [a;b] -> [l; [b;a]]
| _ ->
let _, perms =
List.fold_left l ~init:(l,[]) ~f:
begin fun (l, perms) a ->
let l = List.tl l in
l @ [a],
List.map (permutations l) ~f:(fun l -> a :: l) @ perms
end
in perms
let rec choose n ~card:l =
let len = List.length l in
if n = len then [l] else
if n = 1 then List.map l ~f:(fun x -> [x]) else
if n = 0 then [[]] else
if n > len then [] else
match l with [] -> []
| a :: l ->
List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l)
@ choose n ~card:l
let rec arr p ~card:n =
if p = 0 then 1 else n * arr (p-1) ~card:(n-1)
let rec all_args ty =
let ty = repr ty in
match ty.desc with
Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty)
| _ -> ([], ty)
let rec equal ~prefix t1 t2 =
match (repr t1).desc, (repr t2).desc with
Tvar _, Tvar _ -> true
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let fields1 = filter_row_fields false row1.row_fields
and fields2 = filter_row_fields false row1.row_fields
in
let r1, r2, pairs = merge_row_fields fields1 fields2 in
row1.row_closed = row2.row_closed && r1 = [] && r2 = [] &&
List.for_all pairs ~f:
begin fun (_,f1,f2) ->
match row_field_repr f1, row_field_repr f2 with
Rpresent None, Rpresent None -> true
| Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix
| Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
c1 = c2 && List.length tl1 = List.length tl2 &&
List.for_all2 tl1 tl2 ~f:(equal ~prefix)
| _ -> false
end
| Tarrow _, Tarrow _ ->
let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
equal t1 t2 ~prefix &&
List.length l1 = List.length l2 &&
List.exists (permutations l1) ~f:
begin fun l1 ->
List.for_all2 l1 l2 ~f:
begin fun (p1,t1) (p2,t2) ->
(p1 = "" || p1 = p2) && equal t1 t2 ~prefix
end
end
| Ttuple l1, Ttuple l2 ->
List.length l1 = List.length l2 &&
List.for_all2 l1 l2 ~f:(equal ~prefix)
| Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
&& List.length l1 = List.length l2
&& List.for_all2 l1 l2 ~f:(equal ~prefix)
| _ -> false
let is_opt s = s <> "" && s.[0] = '?'
let get_options = List.filter ~f:is_opt
let rec included ~prefix t1 t2 =
match (repr t1).desc, (repr t2).desc with
Tvar _, _ -> true
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let fields1 = filter_row_fields false row1.row_fields
and fields2 = filter_row_fields false row2.row_fields
in
let r1, r2, pairs = merge_row_fields fields1 fields2 in
r1 = [] &&
List.for_all pairs ~f:
begin fun (_,f1,f2) ->
match row_field_repr f1, row_field_repr f2 with
Rpresent None, Rpresent None -> true
| Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix
| Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
c1 = c2 && List.length tl1 = List.length tl2 &&
List.for_all2 tl1 tl2 ~f:(included ~prefix)
| _ -> false
end
| Tarrow _, Tarrow _ ->
let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
included t1 t2 ~prefix &&
let len1 = List.length l1 and len2 = List.length l2 in
let l2 = if arr len1 ~card:len2 < 100 then l2 else
let ll1 = get_options (fst (List.split l1)) in
List.filter l2
~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1)
in
len1 <= len2 &&
List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
begin fun l2 ->
List.for_all2 l1 l2 ~f:
begin fun (p1,t1) (p2,t2) ->
(p1 = "" || p1 = p2) && included t1 t2 ~prefix
end
end
| Ttuple l1, Ttuple l2 ->
let len1 = List.length l1 in
len1 <= List.length l2 &&
List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
begin fun l2 ->
List.for_all2 l1 l2 ~f:(included ~prefix)
end
| _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix
| Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
&& List.length l1 = List.length l2
&& List.for_all2 l1 l2 ~f:(included ~prefix)
| _ -> false
let mklid = function
[] -> raise (Invalid_argument "Searchid.mklid")
| x :: l ->
List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x))
let mkpath = function
[] -> raise (Invalid_argument "Searchid.mklid")
| x :: l ->
List.fold_left l ~init:(Pident (Ident.create x))
~f:(fun acc x -> Pdot (acc, x, 0))
let get_fields ~prefix ~sign self =
let env = open_signature (mkpath prefix) sign initial in
match (expand_head env self).desc with
Tobject (ty_obj, _) ->
let l,_ = flatten_fields ty_obj in l
| _ -> []
let rec search_type_in_signature t ~sign ~prefix ~mode =
let matches = match mode with
`Included -> incr Stat.type_included; included t ~prefix
| `Exact -> incr Stat.type_exact; equal t ~prefix
and lid_of_id id = mklid (prefix @ [Ident.name id]) in
List2.flat_map sign ~f:
begin fun item -> match item with
Sig_value (id, vd) ->
if matches vd.val_type then [lid_of_id id, Pvalue] else []
| Sig_type (id, td, _) ->
if
matches (newconstr (Pident id) td.type_params) ||
begin match td.type_manifest with
None -> false
| Some t -> matches t
end ||
begin match td.type_kind with
Type_abstract -> false
| Type_variant l ->
List.exists l ~f:
begin fun (_, l, r) ->
List.exists l ~f:matches ||
match r with None -> false | Some x -> matches x
end
| Type_record(l, rep) ->
List.exists l ~f:(fun (_, _, t) -> matches t)
end
then [lid_of_id id, Ptype] else []
| Sig_exception (id, l) ->
if List.exists l.exn_args ~f:matches
then [lid_of_id id, Pconstructor]
else []
| Sig_module (id, Mty_signature sign, _) ->
search_type_in_signature t ~sign ~mode
~prefix:(prefix @ [Ident.name id])
| Sig_module _ -> []
| Sig_modtype _ -> []
| Sig_class (id, cl, _) ->
let self = self_type cl.cty_type in
if matches self
|| (match cl.cty_new with None -> false | Some ty -> matches ty)
(* || List.exists (get_fields ~prefix ~sign self)
~f:(fun (_,_,ty_field) -> matches ty_field) *)
then [lid_of_id id, Pclass] else []
| Sig_class_type (id, cl, _) ->
let self = self_type cl.clty_type in
if matches self
(* || List.exists (get_fields ~prefix ~sign self)
~f:(fun (_,_,ty_field) -> matches ty_field) *)
then [lid_of_id id, Pclass] else []
end
let search_all_types t ~mode =
let tl = match mode, t.desc with
`Exact, _ -> [t]
| `Included, Tarrow _ -> [t]
| `Included, _ ->
[t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))]
in List2.flat_map !module_list ~f:
begin fun modname ->
let mlid = Lident modname in
try match lookup_module mlid initial with
_, Mty_signature sign ->
List2.flat_map tl
~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode)
| _ -> []
with Not_found | Env.Error _ -> []
end
exception Error of int * int
let search_string_type text ~mode =
try
let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in
let sign =
try (Typemod.transl_signature !start_env sexp).sig_type with _ ->
(* CR jfuruse: No open of nested modules?
A.B.t cannot be found by "t".
*)
let env = List.fold_left !module_list ~init:initial ~f:
begin fun acc m ->
try open_pers_signature m acc with Env.Error _ -> acc
end in
try (Typemod.transl_signature env sexp).sig_type
with Env.Error err -> []
| Typemod.Error (l,_) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
| Typetexp.Error (l,_) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
in match sign with
[ Sig_value (_, vd) ] ->
search_all_types vd.val_type ~mode
| _ -> []
with
Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
| Syntaxerr.Error(Syntaxerr.Other l) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
| Lexer.Error (_, l) ->
let start_c = l.loc_start.Lexing.pos_cnum in
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
let longident_of_string text =
let exploded = ref [] and l = ref 0 in
for i = 0 to String.length text - 2 do
if text.[i] ='.' then
(exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1)
done;
let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in
let rec mklid = function
[s] -> Lident s
| s :: l -> Ldot (mklid l, s)
| [] -> assert false in
sym, fun l -> mklid (sym :: !exploded @ l)
let explode s =
let l = ref [] in
for i = String.length s - 1 downto 0 do
l := s.[i] :: !l
done; !l
let rec check_match ~pattern s =
match pattern, s with
[], [] -> true
| '*'::l, l' -> check_match ~pattern:l l'
|| check_match ~pattern:('?'::'*'::l) l'
| '?'::l, _::l' -> check_match ~pattern:l l'
| x::l, y::l' when x == y -> check_match ~pattern:l l'
| _ -> false
let check_match ~pattern s =
incr Stat.symbol;
check_match ~pattern s
let search_pattern_symbol text =
if text = "" then [] else
let pattern = explode text in
let check i = check_match ~pattern (explode (Ident.name i)) in
let l = List.map !module_list ~f:
begin fun modname -> Lident modname,
try match lookup_module (Lident modname) initial with
_, Mty_signature sign ->
List2.flat_map sign ~f:
begin function
Sig_value (i, _) when check i -> [i, Pvalue]
| Sig_type (i, _, _) when check i -> [i, Ptype]
| Sig_exception (i, _) when check i -> [i, Pconstructor]
| Sig_module (i, _, _) when check i -> [i, Pmodule]
| Sig_modtype (i, _) when check i -> [i, Pmodtype]
| Sig_class (i, cl, _) when check i
|| List.exists
(get_fields ~prefix:[modname] ~sign (self_type cl.cty_type))
~f:(fun (name,_,_) -> check_match ~pattern (explode name))
-> [i, Pclass]
| Sig_class_type (i, cl, _) when check i
|| List.exists
(get_fields ~prefix:[modname] ~sign (self_type cl.clty_type))
~f:(fun (name,_,_) -> check_match ~pattern (explode name))
-> [i, Pcltype]
| _ -> []
end
| _ -> []
with
| Env.Error _ ->
Format.eprintf "Warning: lookup_module %s failed. Check the library.@." modname;
[]
| Not_found ->
Format.eprintf "Error: module %s was not found. Check modules.txt.@." modname;
assert false
end
in
List2.flat_map l ~f:
begin fun (m, l) ->
List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p)
end
(*
let is_pattern s =
try for i = 0 to String.length s -1 do
if s.[i] = '?' || s.[i] = '*' then raise Exit
done; false
with Exit -> true
*)
let search_string_symbol text =
if text = "" then [] else
let lid = snd (longident_of_string text) [] in
let try_lookup f k =
try let _ = f lid Env.initial in [lid, k]
with Not_found | Env.Error _ -> []
in
try_lookup lookup_constructor Pconstructor @
try_lookup lookup_module Pmodule @
try_lookup lookup_modtype Pmodtype @
try_lookup lookup_value Pvalue @
try_lookup lookup_type Ptype @
try_lookup lookup_label Plabel @
try_lookup lookup_class Pclass
open Parsetree
let rec bound_variables pat =
match pat.ppat_desc with
Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
| Ppat_var s -> [s.txt]
| Ppat_alias (pat,s) -> s.txt :: bound_variables pat
| Ppat_tuple l -> List2.flat_map l ~f:bound_variables
| Ppat_construct (_,None,_) -> []
| Ppat_construct (_,Some pat,_) -> bound_variables pat
| Ppat_variant (_,None) -> []
| Ppat_variant (_,Some pat) -> bound_variables pat
| Ppat_record (l, _) ->
List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat)
| Ppat_array l ->
List2.flat_map l ~f:bound_variables
| Ppat_or (pat1,pat2) ->
bound_variables pat1 @ bound_variables pat2
| Ppat_constraint (pat,_) -> bound_variables pat
| Ppat_lazy pat -> bound_variables pat
let search_structure str ~name ~kind ~prefix =
let loc = ref 0 in
let rec search_module str ~prefix =
match prefix with [] -> str
| modu::prefix ->
let str =
List.fold_left ~init:[] str ~f:
begin fun acc item ->
match item.pstr_desc with
Pstr_module (s, mexp) when s.txt = modu ->
loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum;
begin match mexp.pmod_desc with
Pmod_structure str -> str
| _ -> []
end
| _ -> acc
end
in search_module str ~prefix
in
List.iter (search_module str ~prefix) ~f:
begin fun item ->
if match item.pstr_desc with
Pstr_value (_, l) when kind = Pvalue ->
List.iter l ~f:
begin fun (pat,_) ->
if List.mem name (bound_variables pat)
then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum
end;
false
| Pstr_primitive (s, _) when kind = Pvalue -> name = s.txt
| Pstr_type l when kind = Ptype ->
List.iter l ~f:
begin fun (s, td) ->
if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
end;
false
| Pstr_exception (s, _) when kind = Pconstructor -> name = s.txt
| Pstr_module (s, _) when kind = Pmodule -> name = s.txt
| Pstr_modtype (s, _) when kind = Pmodtype -> name = s.txt
| Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| Pstr_class_type l when kind = Pcltype || kind = Ptype ->
List.iter l ~f:
begin fun c ->
if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| _ -> false
then loc := item.pstr_loc.loc_start.Lexing.pos_cnum
end;
!loc
let search_signature sign ~name ~kind ~prefix =
ignore (name = "");
ignore (prefix = [""]);
let loc = ref 0 in
let rec search_module_type sign ~prefix =
match prefix with [] -> sign
| modu::prefix ->
let sign =
List.fold_left ~init:[] sign ~f:
begin fun acc item ->
match item.psig_desc with
Psig_module (s, mtyp) when s.txt = modu ->
loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum;
begin match mtyp.pmty_desc with
Pmty_signature sign -> sign
| _ -> []
end
| _ -> acc
end
in search_module_type sign ~prefix
in
List.iter (search_module_type sign ~prefix) ~f:
begin fun item ->
if match item.psig_desc with
Psig_value (s, _) when kind = Pvalue -> name = s.txt
| Psig_type l when kind = Ptype ->
List.iter l ~f:
begin fun (s, td) ->
if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
end;
false
| Psig_exception (s, _) when kind = Pconstructor -> name = s.txt
| Psig_module (s, _) when kind = Pmodule -> name = s.txt
| Psig_modtype (s, _) when kind = Pmodtype -> name = s.txt
| Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| Psig_class_type l when kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| _ -> false
then loc := item.psig_loc.loc_start.Lexing.pos_cnum
end;
!loc
Something went wrong with that request. Please try again.