(*********************************************************************************) |
(* 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 *)
(* *)
(*********************************************************************************) |
(* $Id: tdl_gui.ml,v 1.5 2004/04/08 15:12:05 zoggy Exp $ *)
(** Classes to add edition of todo list in lablgtk2 applications, using the Tdl library. *) |
open Tdl
open Gobject.Data
open GTree
let _ = Tdl_gui_rc.read ()
let _ = Tdl_gui_rc.write ()
let software = "TDL"
let software_author = "Maxence Guesdon"
let software_author_mail = "Maxence.Guesdon@inria.fr"
let software_copyright =
"Copyright 2004,2005,2006 Institut National de Recherche en \n"^
"Informatique et en Automatique. All rights reserved.\n"^
"This software is distributed under the terms of the\n"^
"GNU Library General Public License version 2.\n"^
"(see file LICENSE in the distribution)"
let software_about =
software^" version "^Cam_installation.software_version^"\n\n"^
software_author^"\n"^
software_author_mail^"\n\n"^
software_copyright
type data = [
`Item of Tdl.item
| `Group of Tdl.group
]
let to_utf8 ?coding s =
match coding with
Some charset ->
Glib.Convert.convert
~to_codeset: "UTF-8" ~from_codeset: charset s
| None ->
try Glib.Convert.locale_to_utf8 s
with _ ->
try
Glib.Convert.convert
~to_codeset: "UTF-8" ~from_codeset: Tdl_gui_rc.encoding#get s
with
_ -> s
let from_utf8 ?coding s =
match coding with
Some charset ->
Glib.Convert.convert
~from_codeset: "UTF-8" ~to_codeset: charset s
| None ->
try Glib.Convert.locale_from_utf8 s
with _ ->
Glib.Convert.convert
~from_codeset: "UTF-8" ~to_codeset: Tdl_gui_rc.encoding#get s
let string_of_state = function
Done -> "Done"
| Suspended -> "Suspended"
| Priority_low -> "Low priority"
| Priority_normal -> "Normal priority"
| Priority_high -> "High priority"
let string_of_date ?(hour=false) d =
Printf.sprintf
"%04d-%02d-%02d%s"
d.year
d.month
d.day
(
if hour then
Printf.sprintf " %02d:%02d"
d.hour
d.minute
else
""
)
let print_data = function
`Item item ->
prerr_endline "item";
prerr_endline item.item_title
| `Group g ->
prerr_endline "group";
prerr_endline g.group_title
let pix_size = 16
let create_pix =
let f file =
GdkPixbuf.from_file_at_size file ~width: pix_size ~height: pix_size
in
fun cp ->
try f cp#get
with e -> prerr_endline (Printexc.to_string e); f cp#get_default
let safe_load to_utf8 file =
try Tdl.group_of_file file
with e ->
let err =
match e with
Xml.File_not_found s -> Printf.sprintf "File not found: %s" s
| Xml.Error e ->
Printf.sprintf "File %s: %s" file (Xml.error e)
| Failure s | Sys_error s -> s
| e -> raise e
in
GToolbox.message_box "Error" (to_utf8 err);
Tdl.group ()
let string_of_opt = function
None -> ""
| Some s -> s
let opt_of_string = function
"" -> None
| s -> Some s
let params_for_item ~from_utf8 ~to_utf8 item =
let title = Configwin.string
~f: (fun s -> item.item_title <- from_utf8 s)
"Title: " (to_utf8 item.item_title)
in
let desc = Configwin.text
~f:(fun s -> item.item_desc <- opt_of_string (from_utf8 s))
"Details: " (to_utf8 (string_of_opt item.item_desc))
in
[title;desc]
let buffer = ref (None : data option)
class file_view
?(from_utf8=from_utf8)
?(to_utf8=to_utf8) filename =
let shown_states =
ref [Suspended;Priority_high;Priority_normal;Priority_low]
in
let hide_state s =
shown_states := List.filter ((<>) s) !shown_states
in
let show_state s =
if not (List.mem s !shown_states) then
shown_states := s :: !shown_states
in
let pix_group = create_pix Tdl_gui_rc.pix_group in
let pix_item = create_pix Tdl_gui_rc.pix_item in
let pix_low = create_pix Tdl_gui_rc.pix_low in
let pix_high = create_pix Tdl_gui_rc.pix_high in
let pix_done = create_pix Tdl_gui_rc.pix_done in
let pix_susp = create_pix Tdl_gui_rc.pix_susp in
let pix_of_state = function
Done -> pix_done
| Suspended -> pix_susp
| Priority_low -> pix_low
| Priority_normal -> pix_item
| Priority_high -> pix_high
in
let main_group = ref (safe_load to_utf8 filename) in
let f_children = function
`Item _ -> []
| `Group g ->
(List.fold_left
(fun acc i ->
if List.mem i.item_state !shown_states then
(`Item i) :: acc
else
acc
)
[]
(List.rev (Tdl.sort_items_by_state g.group_items))
) @
(List.map (fun g -> `Group g) g.group_groups)
in
let f_expand _ = true in
let f_roots () = f_children (`Group !main_group) in
let f_contents data =
let (pix,strings) =
match data with
`Group g -> (pix_group, [g.group_title;""])
| `Item i ->
(pix_of_state i.item_state,
[ i.item_title ;
(match i.item_enddate with
None -> ""
| Some d -> string_of_date d
)
]
)
in
`Pixmap (Some pix) ::
(List.map (fun s -> `String (to_utf8 s)) strings)
in
let tree =
object(self)
inherit [data] Gmytree.tree_edit
~f_expand ~f_roots ~f_children ~f_contents
[ `Pixmap None ;
`String "Title";
`String "End date"
]
val mutable modified = false
method modified = modified
val mutable on_modified_changed = fun () -> ()
method set_on_modified_changed f = on_modified_changed <- f
method set_modified b =
if modified <> b then
(
modified <- b;
on_modified_changed ()
)
method on_double_click data =
match selection, self#selected_row with
None, _
| _, None -> ()
| Some (`Group g), Some row ->
self#group_edit_title row g ()
| Some (`Item i), Some row ->
self#item_edit row i ()
method tree_add_item parent item =
self#insert ~append: true ?parent (`Item item)
method tree_add_group parent g =
self#insert ~append: true ?parent (`Group g)
(* Editing items *)
method item_edit iter item () =
match Configwin.simple_get "Edit item"
(params_for_item ~from_utf8 ~to_utf8 item)
with
Configwin.Return_cancel -> ()
| Configwin.Return_apply
| Configwin.Return_ok ->
self#set_modified true;
self#set_row iter (`Item item)
method item_set_state iter item new_state () =
item.item_state <- new_state;
(
match new_state with
Done ->
let date = Tdl.float_to_date (Unix.time ()) in
item.item_enddate <- Some date;
| _ -> ()
);
self#set_modified true;
self#set_row iter (`Item item)
method item_menu iter item =
let set_state_entries =
List.map
(fun st ->
`I (string_of_state st, self#item_set_state iter item st))
[ Done ; Suspended; Priority_low; Priority_normal; Priority_high]
in
[
`I ("Edit", self#item_edit iter item) ;
`M ("Set state", set_state_entries) ;
`S ;
`I ("Remove", self#group_remove_item iter item) ;
]
method on_selected f =
match selection, self#selected_row with
None, _
| _, None -> ()
| Some data, Some row -> f row data
method copy =
let f _ = function
`Group g -> buffer := Some (`Group (Tdl.copy_group g))
| `Item i -> buffer := Some (`Item (Tdl.copy_item i))
in
self#on_selected f
method delete confirm =
let f row = function
`Group g -> self#group_remove_group ~confirm row g ()
| `Item i -> self#group_remove_item row i ()
in
self#on_selected f
method cut = self#copy; self#delete false
method paste =
match selection, self#selected_row with
None, _
| _, None ->
begin
match !buffer with
None -> ()
| Some (`Group g) ->
(!main_group).group_groups <- (!main_group).group_groups @ [g];
self#set_modified true;
self#tree_add_group None g;
| Some (`Item i) ->
(!main_group).group_items <- (!main_group).group_items @ [i];
self#set_modified true;
self#tree_add_item None i
end
| Some (`Group g), Some row ->
begin
match !buffer with
None -> ()
| Some (`Group g2) ->
g.group_groups <- g.group_groups @ [g2];
self#set_modified true;
self#tree_add_group (Some row) g2;
| Some (`Item i) ->
g.group_items <- g.group_items @ [i];
self#set_modified true;
self#tree_add_item (Some row) i
end
| Some (`Item _), _ -> ()
(* Editing groups *)
method group_edit_title iter g () =
match GToolbox.input_string ~title: "Edit group title"
~text: (to_utf8 g.group_title) "Title"
with
None -> ()
| Some s ->
g.group_title <- from_utf8 s;
self#set_modified true;
self#set_row iter (`Group g)
method group_add_item parent g () =
let item = Tdl.item ~title: "" ~state: Priority_normal () in
match Configwin.simple_get "Add item"
(params_for_item ~from_utf8 ~to_utf8 item)
with
Configwin.Return_cancel -> ()
| Configwin.Return_apply
| Configwin.Return_ok ->
g.group_items <- g.group_items @ [item];
self#set_modified true;
self#tree_add_item parent item
method group_add_group parent g () =
match GToolbox.input_string ~title: "Add group"
~text: "" "Title"
with
None -> ()
| Some title ->
let title = from_utf8 title in
let group = Tdl.group ~title () in
g.group_groups <- g.group_groups @ [group];
self#set_modified true;
self#tree_add_group parent group
method group_remove_group ?(confirm=true) it g () =
if
(g.group_items = [] && g.group_groups = []) or
(not confirm) or
(GToolbox.question_box
~title: "Question"
~buttons: ["Ok" ; "Cancel"]
~default: 1
(to_utf8
(Printf.sprintf "Destroy group \"%s\" (not empty) ?"
g.group_title)
)
) = 1
then
(
Tdl.remove_group (self#father_group it) g;
self#set_modified true;
ignore(self#remove_row it);
)
method group_remove_item it i () =
Tdl.remove_item (self#father_group it) i;
self#set_modified true;
ignore(self#remove_row it)
method group_menu iter g =
[
`I ("Edit title", self#group_edit_title iter g) ;
`I ("Add item", self#group_add_item (Some iter) g) ;
`I ("Add group", self#group_add_group (Some iter) g) ;
`S ;
`I ("Remove", self#group_remove_group iter g) ;
]
method top_group_menu =
[
`I ("Add item", self#group_add_item None !main_group) ;
`I ("Add group", self#group_add_group None !main_group) ;
]
method father_group it =
match self#father_data it with
None ->
!main_group
| Some (`Group g) ->
g
| Some (`Item i) ->
!main_group
method common_menu =
let (to_hide,to_show) = List.partition
(fun s -> List.mem s !shown_states)
Tdl.states
in
let mk label f l =
match List.map
(fun s -> `I (string_of_state s, (fun () -> f s; self#update)))
l
with
[] -> []
| l -> [`M (label, l)]
in
(mk "Hide items with state..." hide_state to_hide) @
(mk "Show items with state..." show_state to_show)
method menu =
(
match selection with
None -> self#top_group_menu
| Some (`Group g) ->
begin
match self#selected_row with
None -> []
| Some it -> self#group_menu it g
end
| Some (`Item i) ->
begin
match self#selected_row with
None -> []
| Some it -> self#item_menu it i
end
) @ (`S :: self#common_menu)
method add_item =
match selection, self#selected_row with
None, _
| _, None -> self#group_add_item None !main_group ()
| Some (`Group g), Some iter ->
self#group_add_item (Some iter) g ()
| Some (`Item _), _ -> ()
method add_group =
match selection, self#selected_row with
None, _
| _, None -> self#group_add_group None !main_group ()
| Some (`Group g), Some iter ->
self#group_add_group (Some iter) g ()
| Some (`Item _), _ -> ()
method edit_selected =
match selection, self#selected_row with
None, _ | _, None -> ()
| Some (`Group g), Some iter -> self#group_edit_title iter g ()
| Some (`Item i), Some iter -> self#item_edit iter i ()
end
in
let vbox = GPack.vbox () in
object(self)
method box = vbox#coerce
method tree_view = tree#view
val mutable filename = filename
method filename = filename
method save =
try
Tdl.print_file ~encoding: Tdl_gui_rc.encoding#get
filename !main_group;
tree#set_modified false
with Failure s | Sys_error s ->
GToolbox.message_box "Error" s
method reload =
main_group := safe_load to_utf8 filename;
tree#set_modified false;
tree#update
method modified = tree#modified
method set_on_modified_changed = tree#set_on_modified_changed
method copy = tree#copy
method cut = tree#cut
method paste = tree#paste
method delete = tree#delete true
method add_item = tree#add_item
method add_group = tree#add_group
method edit_selected = tree#edit_selected
initializer
vbox#pack ~expand: true ~fill: true tree#box#coerce ;
end
let glade_file = Filename.concat Cam_installation.glade_dir "tdl.glade"
class file_window file =
let v = new file_view file in
object (self)
inherit Tdl_gui_base.main ~file: glade_file ()
method on_about () =
GToolbox.message_box ("About "^software^" ...") software_about
method on_quit () =
if (not v#modified) or
(GToolbox.question_box ~title:"Quit"
"Changes not saved. Quit anyway ?"
~buttons:["Yes";"No"] = 1)
then
main#destroy ()
initializer
vbox#pack ~expand: true ~fill: true v#box;
vbox#reorder_child v#box ~pos: 1;
main#set_title (Printf.sprintf "%s: %s" software (Glib.Convert.filename_to_utf8 file));
let handlers =
[
("on_quit_activate", `Simple self#on_quit);
("on_save_activate", `Simple (fun () -> v#save));
(* ("on_reload_activate", `Simple (fun () -> v#reload));*)
("on_about_activate", `Simple self#on_about);
("on_copy_activate", `Simple (fun () -> v#copy)) ;
("on_cut_activate", `Simple (fun () -> v#cut)) ;
("on_paste_activate", `Simple (fun () -> v#paste)) ;
("on_delete_activate", `Simple (fun () -> v#delete)) ;
("on_add_item_activate", `Simple (fun () -> v#add_item)) ;
("on_add_group_activate", `Simple (fun () -> v#add_group)) ;
]
in
(* Finalize GUI *)
Glade.bind_handlers ~extra:handlers ~warn:true self#xml;
end
(*
class editor_view () =
let cols = new GTree.column_list in
let ctitle = cols#add string in
let cstate = cols#add string in
let cenddate = cols#add string in
let (cdata: item_or_group GTree.column) = cols#add caml in
let (store : GTree.tree_store) = GTree.tree_store cols in
let view = GTree.view ~model: store () in
object (self)
val mutable group = Tdl.group ()
method group = group
method set_group g =
group <- g;
store#clear ();
self#fill_store_with_group group
method view = view
(* Filling the tree *)
method add_item parent item =
let row = store#append ?parent () in
store#set ~row ~column: cdata (Item item);
store#set ~row ~column: ctitle item.item_title;
store#set ~row ~column: cstate
(string_of_state item.item_state);
store#set ~row ~column: cenddate
(match item.item_enddate with
None -> ""
| Some d -> string_of_date d
)
method add_group parent g =
let row = store#append ?parent () in
store#set ~row ~column: cdata (Group g);
store#set ~row ~column: ctitle g.group_title;
store#set ~row ~column: cstate "";
store#set ~row ~column: cenddate "";
List.iter (self#add_item (Some row)) g.group_items;
List.iter (self#add_group (Some row)) g.group_groups
method fill_store_with_group g =
List.iter (self#add_item None) g.group_items;
List.iter (self#add_group None) g.group_groups ;
view#expand_all ()
(* Editing items *)
method item_edit_title iter item () =
match GToolbox.input_string ~title: "Edit item title"
~text: item.item_title "Title"
with
None -> ()
| Some s ->
item.item_title <- s;
store#set ~row: iter ~column: ctitle item.item_title
method item_set_state iter item new_state () =
item.item_state <- new_state;
(
match new_state with
Done ->
let date = Tdl.float_to_date (Unix.time ()) in
item.item_enddate <- Some date;
store#set ~row: iter ~column: cenddate (string_of_date date)
| _ -> ()
);
store#set ~row: iter ~column: cstate (string_of_state new_state)
method popup_item_menu iter item =
let set_state_entries =
List.map
(fun st ->
`I (string_of_state st, self#item_set_state iter item st))
[ Done ; Suspended; Priority_low; Priority_normal; Priority_high]
in
let entries =
[
`I ("Edit title", self#item_edit_title iter item) ;
`M ("Set state", set_state_entries) ;
`S ;
`I ("Remove", self#group_remove_item iter item) ;
]
in
GToolbox.popup_menu ~entries ~button: 3 ~time: (Int32.of_int 0)
(* Editing groups *)
method group_edit_title iter g () =
match GToolbox.input_string ~title: "Edit group title"
~text: g.group_title "Title"
with
None -> ()
| Some s ->
g.group_title <- s;
store#set ~row: iter ~column: ctitle g.group_title
method group_add_item parent g () =
match GToolbox.input_string ~title: "Add item"
~text: "" "Title"
with
None -> ()
| Some title ->
let item = Tdl.item ~title ~state: Priority_normal () in
g.group_items <- g.group_items @ [item];
self#add_item parent item
method group_add_group parent g () =
match GToolbox.input_string ~title: "Add group"
~text: "" "Title"
with
None -> ()
| Some title ->
let group = Tdl.group ~title () in
g.group_groups <- g.group_groups @ [group];
self#add_group parent group
method group_remove_group it g () =
if
(g.group_items = [] && g.group_groups = []) or
(GToolbox.question_box
~title: "Question"
~buttons: ["Ok" ; "Cancel"]
~default: 1
(Printf.sprintf "Destroy group \"%s\" (not empty) ?" g.group_title)
) = 1
then
(
Tdl.remove_group (self#father_group it) g;
ignore (store#remove it);
)
method group_remove_item it i () =
Tdl.remove_item (self#father_group it) i;
ignore (store#remove it)
method popup_group_menu iter g =
let entries =
[
`I ("Edit title", self#group_edit_title iter g) ;
`I ("Add item", self#group_add_item (Some iter) g) ;
`I ("Add group", self#group_add_group (Some iter) g) ;
`S ;
`I ("Remove", self#group_remove_group iter g) ;
]
in
GToolbox.popup_menu ~entries ~button: 3 ~time: (Int32.of_int 0)
method popup_top_group_menu =
let entries =
[
`I ("Add item", self#group_add_item None group) ;
`I ("Add group", self#group_add_group None group) ;
]
in
GToolbox.popup_menu ~entries ~button: 3 ~time: (Int32.of_int 0)
method father_group it =
match store#iter_parent it with
None -> group
| Some it ->
match store#get ~row: it ~column: cdata with
Item _ -> group
| Group g -> g
initializer
let col_title = GTree.view_column ~title:"Title" ()
~renderer:(GTree.cell_renderer_text[], ["text",ctitle]) in
ignore (view#append_column col_title);
let col_state = GTree.view_column ~title:"State" ()
~renderer:(GTree.cell_renderer_text[], ["text",cstate]) in
ignore (view#append_column col_state);
let col_enddate = GTree.view_column ~title:"End date" ()
~renderer:(GTree.cell_renderer_text[], ["text",cenddate]) in
ignore (view#append_column col_enddate);
self#fill_store_with_group group;
ignore
(view#event#connect#button_press
(fun button ->
match GdkEvent.Button.button button with
3 ->
(
match view#selection#get_selected_rows with
[] ->
self#popup_top_group_menu
| path :: _ ->
let it = store#get_iter path in
match store#get ~row: it ~column: cdata with
Item item ->
self#popup_item_menu it item
| Group g ->
self#popup_group_menu it g
);
true
| _ ->
false
)
);
end
class editor () =
let window = GWindow.window () in
let vbox = GPack.vbox ~packing: window#add () in
let menubar = GMenu.menu_bar ~packing: (vbox#pack ~expand: false) () in
let menu_item_file = GMenu.menu_item
~label: "File"
()
in
let _ = menubar#insert menu_item_file 0 in
let menu_file = GMenu.menu () in
let _ = menu_item_file#set_submenu menu_file in
let view = new editor_view () in
object (self)
val mutable file = (None : string option)
method set_file f =
file <- Some f;
window#set_title ("OCamlTDL : "^f)
method load_file f =
self#set_file f;
try
let group = Tdl.group_of_file f in
view#set_group group
with
| Sys_error s ->
prerr_endline s
| e ->
file <- None;
Printf.eprintf "Error on load: %s\n" (Printexc.to_string e);
flush stderr;
method save_as () =
match GToolbox.select_file ~title: "Save as ..." () with
None -> ()
| Some f ->
self#set_file f ;
self#save ()
method save () =
match file with
None -> self#save_as ()
| Some f -> Tdl.print_file f view#group
method window = window
initializer
let f_save_and_quit () =
self#save ();
window#destroy ()
in
let _ = GToolbox.build_menu menu_file
[ `I ("Save", self#save) ;
`I ("Save and quit", f_save_and_quit) ;
]
in
(*
let f_add_top_group () =
let g = Tdl.group () in
view#group.group_groups <- view#group.group_groups @ [g];
add_group model None g;
in
let _ = GToolbox.build_menu menu_edit
[ `I ("Add top group", f_add_top_group) ;
`I ("Add top item", group_add_item model None group) ;
]
in
*)
vbox#pack ~expand: true view#view#coerce;
view#view#misc#show ();
window#show ();
end
*)