1 files changed, 497 insertions, 0 deletions
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
new file mode 100644
index 000000000..a43085752
--- /dev/null
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -0,0 +1,497 @@
+(* $Id$ *)
+
+open Location
+open Longident
+open Path
+open Types
+open Typedtree
+open Env
+open Btype
+open Ctype
+
+(* 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 acc:(l,[]) fun:
+    begin fun acc:(l, perms) a ->
+      let l = List.tl l in
+      l @ [a],
+      List.map (permutations l) fun:(fun l -> a :: l) @ perms
+    end
+  in perms
+
+let rec choose n in:l =
+  let len = List.length l in
+  if n = len then [l] else
+  if n = 1 then List.map l fun:(fun x -> [x]) else
+  if n = 0 then [[]] else
+  if n > len then [] else
+  match l with [] -> [] 
+  | a :: l ->
+    List.map (choose (n-1) in:l) fun:(fun l -> a :: l)
+    @ choose n in:l
+
+let rec arr p in:n =
+  if p = 0 then 1 else n * arr (p-1) in:(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 pred:
+      	   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 pred:(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) pred:
+      begin fun l1 ->
+      	List.for_all2 l1 l2 pred:
+	begin fun (p1,t1) (p2,t2) ->
+	  (p1 = "" or p1 = p2) & equal t1 t2 :prefix
+	end
+      end
+  | Ttuple l1, Ttuple l2 ->
+      List.length l1 = List.length l2 &
+      List.for_all2 l1 l2 pred:(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 pred:(equal :prefix)
+  | _ -> false
+
+let is_opt s = s <> "" & s.[0] = '?'
+let get_options = List.filter pred: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 row1.row_fields
+      in
+      let r1, r2, pairs = merge_row_fields fields1 fields2 in
+      r1 = [] &
+      List.for_all pairs pred:
+      	   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 pred:(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 in:len2 < 100 then l2 else
+      	  let ll1 = get_options (fst (List.split l1)) in
+      	  List.filter l2
+          pred:(fun (l,_) -> not (is_opt l) or List.mem elt:l ll1)
+      in
+      len1 <= len2 &
+      List.exists (List2.flat_map fun:permutations (choose len1 in:l2)) pred:
+      begin fun l2 ->
+	List.for_all2 l1 l2 pred:
+      	begin fun (p1,t1) (p2,t2) ->
+	  (p1 = "" or 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 fun:permutations (choose len1 in:l2)) pred:
+      begin fun l2 ->
+      	List.for_all2 l1 l2 pred:(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 pred:(included :prefix)
+  | _ -> false
+
+let mklid = function
+    [] -> raise (Invalid_argument "Searchid.mklid")
+  | x :: l ->
+      List.fold_left l acc:(Lident x) fun:(fun :acc x -> Ldot (acc, x))
+
+let mkpath = function
+    [] -> raise (Invalid_argument "Searchid.mklid")
+  | x :: l ->
+      List.fold_left l acc:(Pident (Ident.create x))
+      fun:(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 in:sign :prefix :mode =
+  let matches = match mode with
+        `included -> included t :prefix
+      | `exact -> equal t :prefix
+  and lid_of_id id = mklid (prefix @ [Ident.name id]) in
+  List2.flat_map sign fun:
+  begin fun item -> match item with
+      	Tsig_value (id, vd) ->
+	  if matches vd.val_type then [lid_of_id id, Pvalue] else []
+      | Tsig_type (id, td) ->
+      	  if
+      	  begin match td.type_manifest with
+            None -> false
+	  | Some t -> matches t
+      	  end or
+          begin match td.type_kind with
+	    Type_abstract -> false
+	  | Type_variant l ->
+      	    List.exists l pred:(fun (_, l) -> List.exists l pred:matches)
+	  | Type_record l ->
+	    List.exists l pred:(fun (_, _, t) -> matches t)
+	  end
+	  then [lid_of_id id, Ptype] else []
+      | Tsig_exception (id, l) ->
+      	  if List.exists l pred:matches
+      	  then [lid_of_id id, Pconstructor]
+	  else []
+      | Tsig_module (id, Tmty_signature sign) ->
+      	  search_type_in_signature t in:sign :mode
+      	    prefix:(prefix @ [Ident.name id])
+      | Tsig_module _ -> []
+      | Tsig_modtype _ -> []
+      | Tsig_class (id, cl) ->
+	  let self = self_type cl.cty_type in
+      	  if matches self
+          or (match cl.cty_new with None -> false | Some ty -> matches ty)
+	  (* or List.exists (get_fields :prefix :sign self)
+	      pred:(fun (_,_,ty_field) -> matches ty_field) *)
+	  then [lid_of_id id, Pclass] else []
+      |	Tsig_cltype (id, cl) ->
+	  let self = self_type cl.clty_type in
+      	  if matches self
+	  (* or List.exists (get_fields :prefix :sign self)
+	      pred:(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())); newty(Tarrow("",newvar(),t))]
+  in List2.flat_map !module_list fun:
+    begin fun modname ->
+    let mlid = Lident modname in
+    try match lookup_module mlid initial with
+      _, Tmty_signature sign ->
+      	List2.flat_map tl
+      	  fun:(search_type_in_signature in: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 with _ ->
+      let env = List.fold_left !module_list acc:initial fun:
+      	begin fun :acc m ->
+      	  try open_pers_signature m acc with Env.Error _ -> acc
+        end in
+      try Typemod.transl_signature env sexp
+      with Env.Error err -> []
+      | Typemod.Error (l,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8))
+      | Typetexp.Error (l,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8))
+    in match sign with
+        [Tsig_value (_, vd)] ->
+	  search_all_types vd.val_type :mode
+      | _ -> []
+  with
+    Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) ->
+      raise (Error (l.loc_start - 8, l.loc_end - 8))
+  | Syntaxerr.Error(Syntaxerr.Other l) ->
+      raise (Error (l.loc_start - 8, l.loc_end - 8))
+  | Lexer.Error (_, s, e) ->  raise (Error (s - 8, e - 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) 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'
+                  or 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 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 fun:
+    begin fun modname -> Lident modname,
+    try match lookup_module (Lident modname) initial with
+      _, Tmty_signature sign ->
+      	List2.flat_map sign fun:
+	  begin function
+	    Tsig_value (i, _) when check i -> [i, Pvalue]
+	  | Tsig_type (i, _) when check i -> [i, Ptype]
+	  | Tsig_exception (i, _) when check i -> [i, Pconstructor]
+	  | Tsig_module (i, _) when check i -> [i, Pmodule]
+	  | Tsig_modtype (i, _) when check i -> [i, Pmodtype]
+	  | Tsig_class (i, cl) when check i
+	    or List.exists
+		(get_fields prefix:[modname] :sign (self_type cl.cty_type))
+	        pred:(fun (name,_,_) -> check_match :pattern (explode name))
+	    -> [i, Pclass]
+	  | Tsig_cltype (i, cl) when check i
+	    or List.exists
+		(get_fields prefix:[modname] :sign (self_type cl.clty_type))
+	        pred:(fun (name,_,_) -> check_match :pattern (explode name))
+	    -> [i, Pcltype]
+	  | _ -> []
+	  end
+    | _ -> []
+    with Env.Error _ -> []
+    end
+  in
+  List2.flat_map l fun:
+    begin fun (m, l) ->
+      List.map l fun:(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] = '?' or 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_var s -> [s]
+  | Ppat_alias (pat,s) -> s :: bound_variables pat
+  | Ppat_tuple l -> List2.flat_map l fun: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 fun:(fun (_,pat) -> bound_variables pat)
+  | Ppat_array l ->
+      List2.flat_map l fun:bound_variables
+  | Ppat_or (pat1,pat2) ->
+      bound_variables pat1 @ bound_variables pat2
+  | Ppat_constraint (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 acc:[] str fun:
+	    begin fun :acc item ->
+	      match item.pstr_desc with
+		Pstr_module (s, mexp) when s = modu ->
+		  loc := mexp.pmod_loc.loc_start;
+		  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) fun:
+    begin fun item ->
+      if match item.pstr_desc with
+      	Pstr_value (_, l) when kind = Pvalue ->
+	  List.iter l fun:
+	    begin fun (pat,_) ->
+	      if List.mem elt:name (bound_variables pat)
+	      then loc := pat.ppat_loc.loc_start
+	    end;
+	  false
+      |	Pstr_primitive (s, _) when kind = Pvalue -> name = s
+      |	Pstr_type l when kind = Ptype ->
+	  List.iter l fun:
+	    begin fun (s, td) ->
+	      if s = name then loc := td.ptype_loc.loc_start
+	    end;
+	  false
+      |	Pstr_exception (s, _) when kind = Pconstructor -> name = s
+      |	Pstr_module (s, _) when kind = Pmodule -> name = s
+      |	Pstr_modtype (s, _) when kind = Pmodtype -> name = s
+      |	Pstr_class l when kind = Pclass or kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	Pstr_class_type l when kind = Pcltype or kind = Ptype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	_ -> false
+      then loc := item.pstr_loc.loc_start
+    end;
+  !loc
+
+let search_signature sign :name :kind :prefix =
+  let loc = ref 0 in
+  let rec search_module_type  sign :prefix =
+    match prefix with [] -> sign
+    | modu::prefix ->
+	let sign =
+	  List.fold_left acc:[] sign fun:
+	    begin fun :acc item ->
+	      match item.psig_desc with
+		Psig_module (s, mtyp) when s = modu ->
+		  loc := mtyp.pmty_loc.loc_start;
+		  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) fun:
+    begin fun item ->
+      if match item.psig_desc with
+	Psig_value (s, _) when kind = Pvalue -> name = s
+      |	Psig_type l when kind = Ptype ->
+	  List.iter l fun:
+	    begin fun (s, td) ->
+	      if s = name then loc := td.ptype_loc.loc_start
+	    end;
+	  false
+      |	Psig_exception (s, _) when kind = Pconstructor -> name = s
+      |	Psig_module (s, _) when kind = Pmodule -> name = s
+      |	Psig_modtype (s, _) when kind = Pmodtype -> name = s
+      |	Psig_class l when kind = Pclass or kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	Psig_class_type l when kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	_ -> false
+      then loc := item.psig_loc.loc_start
+    end;
+  !loc