path: root/otherlibs/labltk/browser/searchid.ml

(* $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