(*********************************************************************************) |
(* Cameleon *)
(* *)
(* Copyright (C) 2005,2006 Institut National de Recherche en Informatique *)
(* et en Automatique. All rights reserved. *)
(* *)
(* This program is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU Library General Public License as *)
(* published by the Free Software Foundation; either version 2 of the *)
(* License, or any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Library General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Library General Public *)
(* License along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *)
(* 02111-1307 USA *)
(* *)
(* Contact: Maxence.Guesdon@inria.fr *)
(* *)
(*********************************************************************************) |
(** The modules view *) |
module M = Cam_messages
module O = Config_file
open Odoc_info.Module
open Odoc_info.Class
open Odoc_info.Type
open Odoc_info.Value
module N = Odoc_info.Name
open Odoc_info.Exception
let to_utf8 s =
try Glib.Convert.locale_to_utf8 s
with e ->
prerr_endline (Printf.sprintf "%s: %s" s (Printexc.to_string e));
""
let color_type = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "type"] "Brown" ""
let color_value = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "value"] "Black" ""
let color_exception = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "exception"] "Red" ""
let color_module = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "module"] "SlateBlue" ""
let color_module_type = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "module_type"] "DarkSlateBlue" ""
let color_class = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "class"] "DarkOliveGreen3" ""
let color_class_type = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "class_type"] "DarkOliveGreen4" ""
let color_comment = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "comment"] "Green" ""
let color_included_module = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "colors" ; "included_module"] "Grey" ""
let open_source_command = new O.string_cp ~group: Cam_rc.gui_ini
["modules_view" ; "open_source_command"] "chamo_open_file" ""
let f_open_file ?(char=0) file =
let com = Printf.sprintf "%s %s %d"
open_source_command#get
(Filename.quote file)
((Cam_misc.line_of_char file char)+1)
in
Cam_commands.eval_command com
let dump_files = Hashtbl.create 13
let get_modules_from_dir dir =
let dump_file = Filename.concat dir "dump.odoc" in
try
Hashtbl.find dump_files dump_file
with
Not_found ->
try
if not (Sys.file_exists dump_file) then
failwith ("no file "^dump_file)
else
let l = Odoc_info.load_modules dump_file in
Hashtbl.replace dump_files dump_file l;
l
with
Failure s ->
prerr_endline s;
prerr_endline ("no module information in "^dir);
[]
type row_content =
ME of module_element
| CE of class_element
let location_of_module_element = function
| Element_module m -> Some m.m_loc
| Element_module_type m -> Some m.mt_loc
| Element_class c -> Some c.cl_loc
| Element_class_type c -> Some c.clt_loc
| Element_value v -> Some v.val_loc
| Element_type t -> Some t.ty_loc
| Element_exception e -> Some e.ex_loc
| Element_module_comment _ -> None
| Element_included_module _ -> None
let location_of_class_element = function
| Class_attribute a -> Some a.att_value.val_loc
| Class_method m -> Some m.met_value.val_loc
| Class_comment _ -> None
let location_of_ele = function
ME e -> location_of_module_element e
| CE e -> location_of_class_element e
class box dir =
let vbox = GPack.vbox () in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true)
()
in
let cols = new GTree.column_list in
let col_display = cols#add Gobject.Data.string in
let col_type = cols#add Gobject.Data.string in
let (col_data: row_content GTree.column) = cols#add Gobject.Data.caml in
let store = GTree.tree_store cols in
let view = GTree.view
~headers_visible: false
~model: store ~packing: wscroll#add_with_viewport () in
let renderer = GTree.cell_renderer_text [] in
let col = GTree.view_column ()
~renderer:(renderer, ["text", col_display]) in
let () = ignore (view#append_column col) in
let () =
let col = GTree.view_column ()
~renderer:(renderer, ["text", col_type]) in
ignore (view#append_column col)
in
object(self)
val mutable selection = (None : row_content option)
method on_select _ = ()
method on_unselect _ = ()
(*
method expand _ = false
*)
method menu_ctx = function
None -> []
| Some ele ->
match location_of_ele ele with
None -> []
| Some loc ->
(match loc.Odoc_info.loc_impl with
None -> []
| Some (file,char) ->
[`I ("Implementation",
fun () -> f_open_file ~char file)]
) @
(match loc.Odoc_info.loc_inter with
None -> []
| Some (file,char) ->
[`I ("Interface",
fun () -> f_open_file ~char file)]
)
method color_of_element = function
| ME (Element_module _) -> color_module#get
| ME (Element_module_type _) -> color_module_type#get
| ME (Element_included_module _) -> color_included_module#get
| ME (Element_value _) -> color_value#get
| ME (Element_type _) -> color_type#get
| ME (Element_exception _) -> color_exception#get
| ME (Element_module_comment _) -> color_comment#get
| ME (Element_class _) -> color_class#get
| ME (Element_class_type _) -> color_class_type#get
| CE (Class_attribute _) -> color_value#get
| CE (Class_method _) -> color_value#get
| CE (Class_comment _) -> color_comment#get
method init_col_display :
col_display:GTree.view_column ->
complete:row_content GTree.column ->
renderer:GTree.cell_renderer_text -> GTree.tree_store -> unit =
fun ~col_display ~complete ~renderer _ ->
let f (store:GTree.model) (iter:Gtk.tree_iter) =
let props =
let ele = store#get ~row: iter ~column: complete in
[`FOREGROUND (self#color_of_element ele)]
in
renderer#set_properties props
in
ignore (col_display#set_cell_data_func renderer f)
method on_collapse _ = ()
method on_expand _ = ()
method selection = selection
method box = vbox
method select ele =
selection <- Some ele ;
self#on_select ele
method unselect ele =
selection <- None ;
self#on_unselect ele
method col_display = col_display
method col_data = col_data
method view = view
method display_string_of_ele = function
ME (Element_module m) ->
Printf.sprintf "module %s" (N.simple m.m_name)
| ME (Element_module_type m) ->
Printf.sprintf "module type %s" (N.simple m.mt_name)
| ME (Element_included_module m) ->
"<include>"
| ME (Element_class c) ->
Printf.sprintf "class %s" (N.simple c.cl_name)
| ME (Element_class_type c) ->
Printf.sprintf "class type %s" (N.simple c.clt_name)
| ME (Element_value v) ->
Printf.sprintf "val %s" (N.simple v.val_name)
| ME (Element_type t) ->
Printf.sprintf "type %s" (N.simple t.ty_name)
| ME (Element_exception e) ->
Printf.sprintf "exception %s" (N.simple e.ex_name)
| ME (Element_module_comment t) ->
Odoc_info.string_of_text t
| CE (Class_attribute a) ->
Printf.sprintf "val %s" (N.simple a.att_value.val_name)
| CE (Class_method m) ->
Printf.sprintf "method %s" (N.simple m.met_value.val_name)
| CE (Class_comment t) ->
Odoc_info.string_of_text t
method subs_of_ele = function
ME (Element_module m) ->
List.map (fun e -> ME e) (module_elements m)
| ME (Element_module_type m) ->
List.map (fun e -> ME e) (module_type_elements m)
| ME (Element_included_module _) ->
[]
| ME (Element_class c) ->
List.map (fun e -> CE e) (class_elements c)
| ME (Element_class_type c) ->
List.map (fun e -> CE e) (class_type_elements c)
| ME (Element_value _)
| ME (Element_type _)
| ME (Element_exception _)
| ME (Element_module_comment _)
| CE (Class_attribute _)
| CE (Class_method _)
| CE (Class_comment _) ->
[]
method string_type_of_ele = function
ME (Element_value v) ->
Some (Odoc_info.string_of_type_expr v.val_type)
| CE (Class_attribute a) ->
Some (Odoc_info.string_of_type_expr a.att_value.val_type)
| CE (Class_method m) ->
Some (Odoc_info.string_of_type_expr m.met_value.val_type)
| _ ->
None
method insert_ele ?parent ele =
let row = store#append ?parent () in
store#set row col_data ele;
store#set row col_display
(to_utf8 (self#display_string_of_ele ele));
begin
match self#string_type_of_ele ele with
None -> ()
| Some s ->
store#set row col_type (to_utf8 s);
end;
match self#subs_of_ele ele with
[] -> ()
| l -> List.iter (self#insert_ele ~parent: row) l
method update =
(
match selection with
None -> ()
| Some ele ->
selection <- None ;
self#unselect ele
);
store#clear ();
let modules = get_modules_from_dir dir in
List.iter (fun m -> self#insert_ele (ME (Element_module m))) modules
initializer
view#selection#set_mode `SINGLE;
ignore
(view#connect#row_expanded
(fun it _ ->
self#on_expand (store#get ~row: it ~column: col_data)
)
);
ignore
(view#connect#row_collapsed
(fun it _ ->
self#on_collapse (store#get ~row: it ~column: col_data)
)
);
ignore
(view#selection#connect#changed
(fun () ->
(
match selection with
None -> ()
| Some ele -> self#unselect ele
);
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
self#select (store#get ~row: it ~column: col_data)
)
);
(* connect the press on button 3 for contextual menu *)
let _ = view#event#connect#button_press ~callback:
(
fun ev ->
GdkEvent.Button.button ev = 3 &&
GdkEvent.get_type ev = `BUTTON_PRESS &&
(
match self#menu_ctx self#selection with
[] -> true
| l ->
GToolbox.popup_menu
~button: 3
~time: (Int32.of_int 0)
~entries: l;
true
)
)
in
self#init_col_display
~col_display: col ~complete: col_data ~renderer store;
self#update
end
class view
(name : Cam_view.view_name)
(dir : Cam_view.ressource_name)
(box : box)
(close_window_on_close : bool) =
object (self)
method changed = false
method close : bool = close_window_on_close
method name = name
method refresh = box#update
method ressource = dir
method ressource_kind : Cam_view.ressource_kind = `Dir
end
class factory : Cam_view.view_factory =
object (self)
method create res_name args =
let box = new box res_name in
let v = new view (self#name) res_name box true in
let w = Cam_view.create_view_window
~title: (Printf.sprintf "%s [%s]" res_name self#name)
v
in
let _ = w#vbox#pack ~expand: true box#box#coerce in
(v, w#window)
method create_no_window window res_name args =
let box = new box res_name in
let v = new view (self#name) res_name box false in
(v, box#box#coerce)
method known_ressource_kinds = [`Dir]
method name = "modules"
end
let _ = Cam_view.register_factory (new factory)
(*
class ele_list () =
let hook_kind = ref (fun _ -> assert false) in
let hook_name = ref (fun _ -> assert false) in
let hook_desc = ref (fun _ -> assert false) in
object(self)
inherit [element] Gpattern.plist `SINGLE
[
(Some M.kind, Gpattern.String (fun ele -> !hook_kind ele)) ;
(Some M.name, Gpattern.String (fun ele -> !hook_name ele)) ;
(Some M.description, Gpattern.String (fun ele -> !hook_desc ele))
]
true
method string_of_info_opt iopt =
match iopt with
None -> ""
| Some i -> Odoc_info.string_of_info i
method short_type t =
let s = Odoc_info.string_of_type_expr t in
let len = String.length s in
if len > 20 then
(String.sub s 0 17)^"..."
else
s
method string_kind_of_ele ele =
let ((s,_,_),_) = self#content ele in
s
method string_name_of_ele ele =
let ((_,s,_),_) = self#content ele in
s
method string_description_of_ele ele =
let ((_,_,s),_) = self#content ele in
s
method content : element -> (string*string*string) * GDraw.optcolor option =
fun ele ->
match ele with
ME me ->
(
match me with
| Element_value v ->
(
(
"val",
N.simple v.val_name,
self#string_of_info_opt v.val_info
),
Some (`NAME Cam_config.color_view_value#get)
)
| Element_exception e ->
(
("exception",
N.simple e.ex_name,
self#string_of_info_opt e.ex_info
),
Some (`NAME Cam_config.color_view_exception#get)
)
| Element_type t ->
(
("type",
N.simple t.ty_name,
self#string_of_info_opt t.ty_info
),
Some (`NAME Cam_config.color_view_type#get)
)
| _ -> assert false
)
| CE ce ->
match ce with
| Class_attribute a ->
(
("val",
N.simple a.att_value.val_name,
self#string_of_info_opt a.att_value.val_info
),
Some (`NAME Cam_config.color_view_value#get)
)
| Class_method m ->
(
("method",
N.simple m.met_value.val_name,
self#string_of_info_opt m.met_value.val_info
),
Some (`NAME Cam_config.color_view_value#get)
)
| _ -> assert false
method compare e1 e2 = compare e1 e2
method menu =
match self#selection with
[] -> []
| e :: q ->
let commands loc =
(match loc.Odoc_info.loc_impl with
None -> []
| Some (file, char) -> [`I (Cam_messages.implementation, f_edit file char) ]) @
(match loc.Odoc_info.loc_inter with
None -> []
| Some (file, char) -> [`I (Cam_messages.interface, f_edit file char) ])
in
match e with
ME (Element_value v) -> commands v.val_loc
| ME (Element_type t) -> commands t.ty_loc
| ME (Element_exception e) -> commands e.ex_loc
| CE (Class_attribute a) -> commands a.att_value.val_loc
| CE (Class_method m) -> commands m.met_value.val_loc
| _ -> []
initializer
hook_kind := self#string_kind_of_ele;
hook_name := self#string_name_of_ele;
hook_desc := self#string_description_of_ele
end
class view () =
let vbox = GPack.vbox () in
let wl_mes = GMisc.label ~text: "" ~packing: (vbox#pack ~expand: false) () in
let wpane = GPack.paned `HORIZONTAL ~packing: (vbox#pack ~expand: true) () in
let wscroll = GBin.scrolled_window
~hpolicy: `AUTOMATIC
~vpolicy: `AUTOMATIC
~packing: (wpane#add1) () in
let cols = new GTree.column_list in
let col_display = cols#add Gobject.Data.string in
let (col_data: Odoc_info.Module.module_element GTree.column) = cols#add Gobject.Data.caml in
let store = GTree.tree_store cols in
let store = GTree.tree_store cols in
let tv = GTree.view ~model: store ~packing:wscroll#add_with_viewport () in
let col = GTree.view_column ()
~renderer:(GTree.cell_renderer_text [], ["text", col_display]) in
let () = ignore (tv#append_column col) in
let _ = wscroll#misc#set_size_request ~width: 200 () in
let wb_refresh = GButton.button
~label: M.refresh
~packing:(vbox#pack ~expand: false) ()
in
let tooltips = GData.tooltips () in
let list_ele = new ele_list () in
let _ = wpane#add2 list_ele#box in
object (self)
val mutable current_dir = None
method string_dir =
match current_dir with
None -> ""
| Some d -> d
method coerce = vbox#coerce
method private clear_tree =
store#clear ();
list_ele#update_data []
(* A VOIR
method add_contextual_menu item loc =
let commands =
(match loc.Odoc_info.loc_impl with
None -> []
| Some (file, char) -> [`I (Cam_messages.implementation, f_edit file char) ]) @
(match loc.Odoc_info.loc_inter with
None -> []
| Some (file, char) -> [`I (Cam_messages.interface, f_edit file char) ])
in
match commands with
[] -> ()
| l ->
(* connect the press on button 3 for contextual menu *)
ignore(item#event#connect#button_press ~callback:
(
fun ev ->
GdkEvent.Button.button ev = 3 &&
GdkEvent.get_type ev = `BUTTON_PRESS &&
(
GToolbox.popup_menu
~button: 3
~time: Int32.zero
~entries: l;
true
)
)
)
method set_item_color item color =
let style = (List.hd item#children)#misc#style#copy in
style#set_fg
(List.map
(fun s -> (s, `NAME color))
[ `NORMAL;`ACTIVE;`PRELIGHT;`SELECTED;`INSENSITIVE ]
);
(List.hd item#children)#misc#set_style style
*)
method insert_module_ele parent ele =
match ele with
| Element_module m -> self#insert_module ~parent m
| Element_module_type mt -> self#insert_module_type parent mt
| Element_class c -> self#insert_class parent c
| Element_class_type ct -> self#insert_class_type parent ct
| _ -> ()
method separate_class_elements l =
let l1 = ref [] in
List.iter
(fun e ->
match e with
Class_attribute _
| Class_method _ -> l1 := (CE e) :: !l1
| _ -> ()
)
l;
List.rev !l1
method selected_rr =
match tv#selection#get_selected_rows with
| [] -> None
| path :: _ -> Some (store#get_row_reference path)
method on_selection_changed () =
match self#selected_rr with
None -> list_ele#update_data []
| Some rr ->
let row = rr#iter in
let l_eles =
match store#get ~row ~column: col_data with
Element_class c ->
self#separate_class_elements (class_elements c)
| Element_class_type ct ->
self#separate_class_elements (class_type_elements ct)
| Element_module m ->
snd (self#separate_module_elements (module_elements m))
| Element_module_type mt ->
snd (self#separate_module_elements (module_type_elements mt))
| _ -> []
in
list_ele#update_data l_eles
method insert_class parent (c : t_class) =
let row = store#append ~parent: parent#iter () in
store#set ~row ~column: col_display ("class "^(N.simple c.cl_name)) ;
store#set ~row ~column: col_data (Element_class c)
method insert_class_type parent (ct : t_class_type) =
let row = store#append ~parent: parent#iter () in
store#set ~row ~column: col_display ("class type "^(N.simple ct.clt_name));
store#set ~row ~column: col_data (Element_class_type ct)
method separate_module_elements l =
let l1 = ref [] in
let l2 = ref [] in
List.iter
(fun e ->
match e with
Element_value _
| Element_type _
| Element_exception _ -> l2 := (ME e) :: !l2
| Element_module _
| Element_module_type _
| Element_class _
| Element_class_type _ -> l1 := e :: !l1
| _ -> ()
)
l;
(List.rev !l1, List.rev !l2)
method insert_module ?(top=false) ?parent (m : t_module) =
let parent = match parent with None -> None | Some rr -> Some rr#iter in
let row = store#append ?parent () in
store#set ~row ~column: col_display ((if top then "" else "module ")^(N.simple m.m_name));
store#set ~row ~column: col_data (Element_module m);
let (l_subs, l_eles) = self#separate_module_elements (module_elements m) in
match l_subs with
[] -> ()
| _ -> List.iter (self#insert_module_ele (store#get_row_reference (store#get_path row))) l_subs
(* A VOIR: garder les noeud expandés
filled := true
);
add_expanded self#string_dir m.m_name
)
);
ignore(item#connect#collapse
(fun () -> remove_expanded self#string_dir m.m_name));
if is_expanded self#string_dir m.m_name then
item#expand ()
*)
method insert_module_type parent (mt : t_module_type) =
let row = store#append ~parent: parent#iter () in
store#set ~row ~column: col_display ("module type "^(N.simple mt.mt_name)) ;
store#set ~row ~column: col_data (Element_module_type mt);
let (l_subs, l_eles) = self#separate_module_elements (module_type_elements mt) in
match l_subs with
[] -> ()
| _ -> List.iter (self#insert_module_ele (store#get_row_reference (store#get_path row))) l_subs
method refresh ?(force=false) () =
self#clear_tree ;
match current_dir with
None -> ()
| Some dir ->
Hashtbl.remove dumps dir;
wl_mes#set_text "";
let dump_file = Filename.concat dir "dump.odoc" in
if force or not (Sys.file_exists dump_file) then
ignore(Sys.command ("cd "^dir^" ; make dump.odoc"));
try
let modules = Odoc_info.load_modules dump_file in
Hashtbl.add dumps dir modules;
List.iter (self#insert_module ~top: true) modules
with
Failure s ->
prerr_endline s;
wl_mes#set_text ("no module information in "^dir)
method display_dir (dir_opt : string option) =
if current_dir = dir_opt then
()
else
(
current_dir <- dir_opt;
wl_mes#set_text "";
self#clear_tree ;
match dir_opt with
None -> ()
| Some dir ->
try
let modules = Hashtbl.find dumps dir in
List.iter (self#insert_module ~top: true ) modules
with
Not_found ->
self#refresh ()
)
initializer
ignore(wb_refresh#connect#clicked (self#refresh ~force: true));
ignore(tv#selection#connect#changed self#on_selection_changed);
end
*)