type row_content = [
`File_type of string
| `File of string
]
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_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
object(self)
val mutable selection = (None : string option)
val mutable collapsed = [Cam_files.ft_unknown]
method on_select _ = ()
method on_unselect _ = ()
method expand ft = not (List.mem ft collapsed)
method menu_ctx _ =
match selection with
None ->
let view_names = Cam_view.available_views ~kind: `Dir () in
List.map
(fun s -> `I (Printf.sprintf "%s view" s, fun () -> ignore (Cam_view.open_ressource dir s [| |])))
view_names
| Some f -> Cam_files.edition_commands_menu_entries f
method init_col_display ~col_display ~complete ~renderer _ = ()
method on_collapse ft = collapsed <- ft :: collapsed
method on_expand ft = collapsed <- List.filter ((<>) ft) collapsed
method selection = selection
method box = vbox
method select f =
selection <- Some f ;
self#on_select f
method unselect f =
selection <- None ;
self#on_unselect f
method col_display = col_display
method col_data = col_data
method view = view
method get_file_types =
let t = Hashtbl.create 13 in
let f file =
let ft = Cam_files.file_type_of_file file in
try
let l = Hashtbl.find t ft in
Hashtbl.replace t ft (file::l)
with Not_found ->
Hashtbl.add t ft [file]
in
Ffind.find Ffind.Ignore [dir] [Ffind.Maxdepth 1] f;
let gather ft acc =
try
let l = Hashtbl.find t ft in
(ft, (List.sort compare l)) :: acc
with
Not_found -> acc
in
List.fold_right gather (Cam_files.file_types ()) []
method insert_ft ft files =
match files with
[] -> ()
| _ ->
let row_ft = store#append () in
store#set row_ft col_data (`File_type ft);
store#set row_ft col_display (Glib.Convert.locale_to_utf8 ft);
let f file =
let row = store#append ~parent: row_ft () in
store#set row col_data (`File file);
store#set row col_display
(Glib.Convert.locale_to_utf8 (Filename.basename file));
in
List.iter f files;
let rr = store#get_row_reference (store#get_path row_ft) in
if self#expand ft then
view#expand_row rr#path
method update =
(
match selection with
None -> ()
| Some f ->
selection <- None ;
self#unselect f
);
store#clear ();
List.iter (fun (ft, files) -> self#insert_ft ft files) self#get_file_types
initializer
view#selection#set_mode `SINGLE;
ignore
(view#connect#row_expanded
(fun it _ ->
match store#get ~row: it ~column: col_data with
`File_type ft -> self#on_expand ft
| _ -> ()
)
);
ignore
(view#connect#row_collapsed
(fun it _ ->
match store#get ~row: it ~column: col_data with
`File_type ft -> self#on_collapse ft
| _ -> ()
)
);
ignore
(view#selection#connect#changed
(fun () ->
(
match selection with
None -> ()
| Some file -> self#unselect file
);
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
match store#get ~row: it ~column: col_data with
`File_type _ -> ()
| `File file -> self#select file
)
);
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 = 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 = "filetypes"
end
let _ = Cam_view.register_factory (new factory)