ocaml/otherlibs/labltk/browser/viewer.ml

(*************************************************************************)
(*                                                                       *)
(*                Objective Caml 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.                                             *)
(*                                                                       *)
(*************************************************************************)

(* $Id$ *)

open Tk
open Jg_tk
open Mytypes
open Longident
open Types
open Typedtree
open Env
open Searchpos
open Searchid

let list_modules :path =
  List.fold_left path acc:[] fun:
  begin fun :acc dir ->
    let l = 
      List.filter (Useunix.get_files_in_directory dir)
        pred:(fun x -> Filename.check_suffix x suff:".cmi") in
    let l = List.map l fun:
    begin fun x ->
      String.capitalize (Filename.chop_suffix x suff:".cmi")
    end in
    List.fold_left l :acc
     fun:(fun :acc item -> if List.mem acc :item then acc else item :: acc)
  end

let reset_modules box =
  Listbox.delete box first:(`Num 0) last:`End;
  module_list := Sort.list order:(<) (list_modules path:!Config.load_path);
  Listbox.insert box index:`End texts:!module_list;
  Jg_box.recenter box index:(`Num 0)

let view_symbol :kind :env ?:path id =
  let name = match id with
      Lident x -> x
    | Ldot (_, x) -> x
    | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z"
  in
  match kind with
    Pvalue ->
      let path, vd = lookup_value id env in
      view_signature_item :path :env [Tsig_value (Ident.create name, vd)]
  | Ptype -> view_type_id id :env
  | Plabel -> let ld = lookup_label id env in
      begin match ld.lbl_res.desc with
        Tconstr (path, _, _) -> view_type_decl path :env
      | _ -> ()
      end
  | Pconstructor ->
      let cd = lookup_constructor id env in
      begin match cd.cstr_res.desc with
        Tconstr (cpath, _, _) ->
        if Path.same cpath Predef.path_exn then
          view_signature title:(string_of_longident id) :env ?:path
            [Tsig_exception (Ident.create name, cd.cstr_args)]
        else
          view_type_decl cpath :env
      | _ -> ()
      end
  | Pmodule -> view_module_id id :env
  | Pmodtype -> view_modtype_id id :env
  | Pclass -> view_class_id id :env
  | Pcltype -> view_cltype_id id :env

let choose_symbol :title :env ?:signature ?:path l =
  if match path with
    None -> false
  | Some path -> is_shown_module path
  then () else
  let tl = Jg_toplevel.titled title in
  Jg_bind.escape_destroy tl;
  top_widgets := coe tl :: !top_widgets;
  let buttons = Frame.create tl in
  let all = Button.create buttons text:"Show all" padx:20
  and ok = Jg_button.create_destroyer tl parent:buttons
  and detach = Button.create buttons text:"Detach"
  and edit = Button.create buttons text:"Impl"
  and intf = Button.create buttons text:"Intf" in
  let l = Sort.list l order:
      (fun (li1, _) (li2,_) ->
        string_of_longident li1 < string_of_longident li2)
  in
  let nl = List.map l fun:
    begin fun (li, k) ->
      string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
    end in
  let fb = Frame.create tl in
  let box =
    new Jg_multibox.c fb cols:3 texts:nl maxheight:3 width:21 in
  box#init;
  box#bind_kbd events:[`KeyPressDetail"Escape"]
    action:(fun _ :index -> destroy tl; break ());
  if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box);
  Jg_multibox.add_completion box action:
    begin fun pos ->
      let li, k = List.nth l :pos in
      let path =
        match path, li with
          None, Ldot (lip, _) ->
            begin try
              Some (fst (lookup_module lip env))
            with Not_found -> None
            end
        | _ -> path
      in view_symbol li kind:k :env ?:path
    end;
  pack [buttons] side:`Bottom fill:`X;
  pack [fb] side:`Top fill:`Both expand:true;
  begin match signature with
    None -> pack [ok] fill:`X expand:true
  | Some signature ->
      Button.configure all command:
        begin fun () ->
          view_signature signature :title :env ?:path
        end;
      pack [ok; all] side:`Right fill:`X expand:true
  end;
  begin match path with None -> ()
  | Some path ->
      let frame = Frame.create tl in
      pack [frame] side:`Bottom fill:`X;
      add_shown_module path
        widgets:{ mw_frame = frame; mw_detach = detach;
                  mw_edit = edit; mw_intf = intf }
  end

let search_which = ref "itself"

let search_symbol () =
  if !module_list = [] then
  module_list := Sort.list order:(<) (list_modules path:!Config.load_path);
  let tl = Jg_toplevel.titled "Search symbol" in
  Jg_bind.escape_destroy tl;
  let ew = Entry.create tl width:30 in
  let choice = Frame.create tl
  and which = Textvariable.create on:tl () in
  let itself = Radiobutton.create choice text:"Itself"
        variable:which value:"itself"
  and extype = Radiobutton.create choice text:"Exact type"
        variable:which value:"exact"
  and iotype = Radiobutton.create choice text:"Included type"
        variable:which value:"iotype"
  and buttons = Frame.create tl in
  let search = Button.create buttons text:"Search" command:
    begin fun () ->
      search_which := Textvariable.get which;
      let text = Entry.get ew in
      try if text = "" then () else      
        let l =
          match !search_which with
            "itself" -> search_string_symbol text
          | "iotype" -> search_string_type text mode:`included
          | "exact" -> search_string_type text mode:`exact
          | _ -> assert false
        in
        if l <> [] then
        choose_symbol title:"Choose symbol" env:!start_env l
      with Searchid.Error (s,e) ->
        Entry.selection_clear ew;
        Entry.selection_range ew start:(`Num s) end:(`Num e);
        Entry.xview_index ew index:(`Num s)
    end
  and ok = Jg_button.create_destroyer tl parent:buttons text:"Cancel" in

  Focus.set ew;
  Jg_bind.return_invoke ew button:search;
  Textvariable.set which to:!search_which;
  pack [itself; extype; iotype] side:`Left anchor:`W;
  pack [search; ok] side:`Left fill:`X expand:true;
  pack [coe ew; coe choice; coe buttons]
       side:`Top fill:`X expand:true

let view_defined modlid :env =
  try match lookup_module modlid env with
    path, Tmty_signature sign ->
    let ident_of_decl = function
        Tsig_value (id, _) -> Lident (Ident.name id), Pvalue
      | Tsig_type (id, _) -> Lident (Ident.name id), Ptype
      | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor
      | Tsig_module (id, _) -> Lident (Ident.name id), Pmodule
      | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype
      | Tsig_class (id, _) -> Lident (Ident.name id), Pclass
      | Tsig_cltype (id, _) -> Lident (Ident.name id), Pcltype
    in
    let rec iter_sign sign idents =
      match sign with
        [] -> List.rev idents
      | decl :: rem ->
          let rem = match decl, rem with
            Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem
          | Tsig_cltype _, ty1 :: ty2 :: rem -> rem
          | _, rem -> rem
          in iter_sign rem (ident_of_decl decl :: idents)
    in
    let l = iter_sign sign [] in
    choose_symbol l title:(string_of_path path) signature:sign
       env:(open_signature path sign env) :path
  | _ -> ()
  with Not_found -> ()
  | Env.Error err ->
      let tl, tw, finish = Jg_message.formatted title:"Error!" () in
      Env.report_error Format.std_formatter err;
      finish ()

let close_all_views () =
    List.iter !top_widgets
      fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
    top_widgets := []


let shell_counter = ref 1
let default_shell = ref "ocaml"

let start_shell () =
  let tl = Jg_toplevel.titled "Start New Shell" in
  Wm.transient_set tl master:Widget.default_toplevel;
  let input = Frame.create tl
  and buttons = Frame.create tl in
  let ok = Button.create buttons text:"Ok"
  and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel"
  and labels = Frame.create input
  and entries = Frame.create input in
  let l1 = Label.create labels text:"Command:"
  and l2 = Label.create labels text:"Title:"
  and e1 =
    Jg_entry.create entries command:(fun _ -> Button.invoke ok)
  and e2 =
    Jg_entry.create entries command:(fun _ -> Button.invoke ok)
  and names = List.map fun:fst (Shell.get_all ()) in
  Entry.insert e1 index:`End text:!default_shell;
  while List.mem names item:("Shell #" ^ string_of_int !shell_counter) do
    incr shell_counter
  done;
  Entry.insert e2 index:`End text:("Shell #" ^ string_of_int !shell_counter);
  Button.configure ok command:(fun () ->
      if not (List.mem names item:(Entry.get e2)) then begin
        default_shell := Entry.get e1;
        Shell.f prog:!default_shell title:(Entry.get e2);
        destroy tl
      end);
  pack [l1;l2] side:`Top anchor:`W;
  pack [e1;e2] side:`Top fill:`X expand:true;
  pack [labels;entries] side:`Left fill:`X expand:true;
  pack [ok;cancel] side:`Left fill:`X expand:true;
  pack [input;buttons] side:`Top fill:`X expand:true

let f ?(:dir=Unix.getcwd()) ?:on () =
  let tl = match on with
    None ->
      let tl = Jg_toplevel.titled "Module viewer" in
      ignore (Jg_bind.escape_destroy tl); coe tl
  | Some top ->
      Wm.title_set top title:"OCamlBrowser";
      Wm.iconname_set top name:"OCamlBrowser";
      let tl = Frame.create top in
      pack [tl] expand:true fill:`Both;
      coe tl
  in
  let menus = Frame.create tl name:"menubar" in
  let filemenu = new Jg_menu.c "File" parent:menus
  and modmenu = new Jg_menu.c "Modules" parent:menus in
  let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in

  Jg_box.add_completion mbox nocase:true action:
    begin fun index ->
      view_defined (Lident (Listbox.get mbox :index)) env:!start_env
    end;
  Setpath.add_update_hook (fun () -> reset_modules mbox);

  let ew = Entry.create tl in
  let buttons = Frame.create tl in
  let search = Button.create buttons text:"Search" pady:1 command:
    begin fun () ->
      let s = Entry.get ew in
      let is_type = ref false and is_long = ref false in
      for i = 0 to String.length s - 2 do
        if s.[i] = '-' & s.[i+1] = '>' then is_type := true;
        if s.[i] = '.' then is_long := true
      done;
      let l =
        if !is_type then try
          search_string_type mode:`included s
        with Searchid.Error (start,stop) ->
          Entry.icursor ew index:(`Num start); []
        else if !is_long then
          search_string_symbol s
        else
          search_pattern_symbol s in
      match l with [] -> ()
      | [lid,kind] when !is_long -> view_symbol lid :kind env:!start_env
      | _ -> choose_symbol title:"Choose symbol" env:!start_env l
    end
  and close =
    Button.create buttons text:"Close all" pady:1 command:close_all_views
  in
  (* bindings *)
  Jg_bind.enter_focus ew;
  Jg_bind.return_invoke ew button:search;
  bind close events:[`Modified([`Double], `ButtonPressDetail 1)]
    action:(fun _ -> destroy tl);

  (* File menu *)
  filemenu#add_command "Open..."
    command:(fun () -> !editor_ref opendialog:true ());
  filemenu#add_command "Editor..." command:(fun () -> !editor_ref ());
  filemenu#add_command "Shell..." command:start_shell;
  filemenu#add_command "Quit" command:(fun () -> destroy tl);

  (* modules menu *)
  modmenu#add_command "Path editor..."
    command:(fun () -> Setpath.set :dir);
  modmenu#add_command "Reset cache"
    command:(fun () -> reset_modules mbox; Env.reset_cache ());
  modmenu#add_command "Search symbol..." command:search_symbol;

  pack [filemenu#button; modmenu#button] side:`Left ipadx:5 anchor:`W;
  pack [menus] side:`Top fill:`X;      
  pack [close; search] fill:`X side:`Right expand:true;
  pack [coe buttons; coe ew] fill:`X side:`Bottom;
  pack [msb] side:`Right fill:`Y;
  pack [mbox] side:`Left fill:`Both expand:true;
  pack [fmbox] fill:`Both expand:true side:`Top;
  reset_modules mbox