(*********************************************************************************)
(* Cameleon *)
(* *)
(* Copyright (C) 2005 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: [email protected] *)
(* *)
(*********************************************************************************)
(** This module contains the gui functions of Configwin.*)
open Configwin_types
let set_help_tip wev = function
| None -> ()
| Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help
let modifiers_to_string m =
let rec iter m s =
match m with
[] -> s
| c :: m ->
iter m ((
match c with
`CONTROL -> ""
| `SHIFT -> ""
| `LOCK -> ""
| `MOD1 -> ""
| `MOD2 -> ""
| `MOD3 -> ""
| `MOD4 -> ""
| `MOD5 -> ""
| _ -> raise Not_found
) ^ s)
in
iter m ""
class type widget =
object
method box : GObj.widget
method apply : unit -> unit
end
let debug = false
let dbg s = if debug then Minilib.log s else ()
(*
(** This class builds a frame with a clist and two buttons :
one to add items and one to remove the selected items.
The class takes in parameter a function used to add items and
a string list ref which is used to store the content of the clist.
At last, a title for the frame is also in parameter, so that
each instance of the class creates a frame. *)
class ['a] list_selection_box
(listref : 'a list ref)
titles_opt
help_opt
f_edit_opt
f_strings
f_color
(eq : 'a -> 'a -> bool)
add_function title editable
=
let _ = dbg "list_selection_box" in
let wev = GBin.event_box () in
let wf = GBin.frame ~label: title ~packing: wev#add () in
let hbox = GPack.hbox ~packing: wf#add () in
(* the scroll window and the clist *)
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (hbox#pack ~expand: true) ()
in
let wlist = match titles_opt with
None ->
GList.clist ~selection_mode: `MULTIPLE
~titles_show: false
~packing: wscroll#add ()
| Some l ->
GList.clist ~selection_mode: `MULTIPLE
~titles: l
~titles_show: true
~packing: wscroll#add ()
in
let _ = set_help_tip wev help_opt in
(* the vbox for the buttons *)
let vbox_buttons = GPack.vbox () in
let _ =
if editable then
let _ = hbox#pack ~expand: false vbox_buttons#coerce in
()
else
()
in
let _ = dbg "list_selection_box: wb_add" in
let wb_add = GButton.button
~label: Configwin_messages.mAdd
~packing: (vbox_buttons#pack ~expand:false ~padding:2)
()
in
let wb_edit = GButton.button
~label: Configwin_messages.mEdit
()
in
let _ = match f_edit_opt with
None -> ()
| Some _ -> vbox_buttons#pack ~expand:false ~padding:2 wb_edit#coerce
in
let wb_up = GButton.button
~label: Configwin_messages.mUp
~packing: (vbox_buttons#pack ~expand:false ~padding:2)
()
in
let wb_remove = GButton.button
~label: Configwin_messages.mRemove
~packing: (vbox_buttons#pack ~expand:false ~padding:2)
()
in
let _ = dbg "list_selection_box: object(self)" in
object (self)
(** the list of selected rows *)
val mutable list_select = []
(** This method returns the frame created. *)
method box = wev
method update l =
(* set the new list in the provided listref *)
listref := l;
(* insert the elements in the clist *)
wlist#freeze ();
wlist#clear ();
List.iter
(fun ele ->
ignore (wlist#append (f_strings ele));
match f_color ele with
None -> ()
| Some c ->
try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1)
with _ -> ()
)
!listref;
(match titles_opt with
None -> wlist#columns_autosize ()
| Some _ -> GToolbox.autosize_clist wlist);
wlist#thaw ();
(* the list of selectd elements is now empty *)
list_select <- []
(** Move up the selected rows. *)
method up_selected =
let rec iter n selrows l =
match selrows with
[] -> (l, [])
| m :: qrows ->
match l with
[] -> ([],[])
| [_] -> (l,[])
| e1 :: e2 :: q when m = n + 1 ->
let newl, newrows = iter (n+1) qrows (e1 :: q) in
(e2 :: newl, n :: newrows)
| e1 :: q ->
let newl, newrows = iter (n+1) selrows q in
(e1 :: newl, newrows)
in
let sorted_select = List.sort compare list_select in
let new_list, new_rows = iter 0 sorted_select !listref in
self#update new_list;
List.iter (fun n -> wlist#select n 0) new_rows
(** Make the user edit the first selected row. *)
method edit_selected f_edit =
let sorted_select = List.sort compare list_select in
match sorted_select with
[] -> ()
| n :: _ ->
try
let ele = List.nth !listref n in
let ele2 = f_edit ele in
let rec iter m = function
[] -> []
| e :: q ->
if n = m then
ele2 :: q
else
e :: (iter (m+1) q)
in
self#update (iter 0 !listref);
wlist#select n 0
with
Not_found ->
()
initializer
(* create the functions called when the buttons are clicked *)
let f_add () =
(* get the files to add with the function provided *)
let l = add_function () in
(* remove from the list the ones which are already in
the listref, using the eq predicate *)
let l2 = List.fold_left
(fun acc -> fun ele ->
if List.exists (eq ele) acc then
acc
else
acc @ [ele])
!listref
l
in
self#update l2
in
let f_remove () =
(* remove the selected items from the listref and the clist *)
let rec iter n = function
[] -> []
| h :: q ->
if List.mem n list_select then
iter (n+1) q
else
h :: (iter (n+1) q)
in
let new_list = iter 0 !listref in
self#update new_list
in
let _ = dbg "list_selection_box: connecting wb_add" in
(* connect the functions to the buttons *)
ignore (wb_add#connect#clicked ~callback:f_add);
let _ = dbg "list_selection_box: connecting wb_remove" in
ignore (wb_remove#connect#clicked ~callback:f_remove);
let _ = dbg "list_selection_box: connecting wb_up" in
ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected));
(
match f_edit_opt with
None -> ()
| Some f ->
let _ = dbg "list_selection_box: connecting wb_edit" in
ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f))
);
(* connect the selection and deselection of items in the clist *)
let f_select ~row ~column ~event =
try
list_select <- row :: list_select
with
Failure _ ->
()
in
let f_unselect ~row ~column ~event =
try
let new_list_select = List.filter (fun n -> n <> row) list_select in
list_select <- new_list_select
with
Failure _ ->
()
in
(* connect the select and deselect events *)
let _ = dbg "list_selection_box: connecting select_row" in
ignore(wlist#connect#select_row ~callback:f_select);
let _ = dbg "list_selection_box: connecting unselect_row" in
ignore(wlist#connect#unselect_row ~callback:f_unselect);
(* initialize the clist with the listref *)
self#update !listref
end;;
*)
(** This class is used to build a box for a string parameter.*)
class string_param_box param =
let _ = dbg "string_param_box" in
let hbox = GPack.hbox () in
let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
let _wl = GMisc.label ~text: param.string_label ~packing: wev#add () in
let we = GEdit.entry
~editable: param.string_editable
~packing: (hbox#pack ~expand: param.string_expand ~padding: 2)
()
in
let _ = set_help_tip wev param.string_help in
let _ = we#set_text (param.string_to_string param.string_value) in
object (self)
(** This method returns the main box ready to be packed. *)
method box = hbox#coerce
(** This method applies the new value of the parameter. *)
method apply =
let new_value = param.string_of_string we#text in
if new_value <> param.string_value then
let _ = param.string_f_apply new_value in
param.string_value <- new_value
else
()
end ;;
(** This class is used to build a box for a combo parameter.*)
class combo_param_box param =
let _ = dbg "combo_param_box" in
let hbox = GPack.hbox () in
let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in
let _ = set_help_tip wev param.combo_help in
let get_value = if not param.combo_new_allowed then
let wc = GEdit.combo_box_text
~strings: param.combo_choices
?active:(let rec aux i = function
|[] -> None
|h::_ when h = param.combo_value -> Some i
|_::t -> aux (succ i) t
in aux 0 param.combo_choices)
~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
()
in
fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s
else
let (wc,_) = GEdit.combo_box_entry_text
~strings: param.combo_choices
~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
()
in
let _ = wc#entry#set_editable param.combo_editable in
let _ = wc#entry#set_text param.combo_value in
fun () -> wc#entry#text
in
object (self)
(** This method returns the main box ready to be packed. *)
method box = hbox#coerce
(** This method applies the new value of the parameter. *)
method apply =
let new_value = get_value () in
if new_value <> param.combo_value then
let _ = param.combo_f_apply new_value in
param.combo_value <- new_value
else
()
end ;;
(** Class used to pack a custom box. *)
class custom_param_box param =
let _ = dbg "custom_param_box" in
let top =
match param.custom_framed with
None -> param.custom_box#coerce
| Some l ->
let wf = GBin.frame ~label: l () in
wf#add param.custom_box#coerce;
wf#coerce
in
object (self)
method box = top
method apply = param.custom_f_apply ()
end
(** This class is used to build a box for a text parameter.*)
class text_param_box param =
let _ = dbg "text_param_box" in
let wf = GBin.frame ~label: param.string_label ~height: 100 () in
let wev = GBin.event_box ~packing: wf#add () in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: wev#add ()
in
let wview = GText.view
~editable: param.string_editable
~packing: wscroll#add
()
in
let _ = set_help_tip wev param.string_help in
let _ = dbg "text_param_box: buffer creation" in
let buffer = GText.buffer () in
let _ = wview#set_buffer buffer in
let _ = buffer#insert (param.string_to_string param.string_value) in
let _ = dbg "text_param_box: object(self)" in
object (self)
val wview = wview
(** This method returns the main box ready to be packed. *)
method box = wf#coerce
(** This method applies the new value of the parameter. *)
method apply =
let v = param.string_of_string (buffer#get_text ()) in
if v <> param.string_value then
(
dbg "apply new value!";
let _ = param.string_f_apply v in
param.string_value <- v
)
else
()
end ;;
(** This class is used to build a box for a boolean parameter.*)
class bool_param_box param =
let _ = dbg "bool_param_box" in
let wchk = GButton.check_button
~label: param.bool_label
()
in
let _ = set_help_tip wchk param.bool_help in
let _ = wchk#set_active param.bool_value in
let _ = wchk#misc#set_sensitive param.bool_editable in
object (self)
(** This method returns the check button ready to be packed. *)
method box = wchk#coerce
(** This method applies the new value of the parameter. *)
method apply =
let new_value = wchk#active in
if new_value <> param.bool_value then
let _ = param.bool_f_apply new_value in
param.bool_value <- new_value
else
()
end ;;
class modifiers_param_box param =
let hbox = GPack.hbox () in
let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in
let _wl = GMisc.label ~text: param.md_label ~packing: wev#add () in
let value = ref param.md_value in
let _ = List.map (fun modifier ->
let but = GButton.toggle_button
~label:(modifiers_to_string [modifier])
~active:(List.mem modifier param.md_value)
~packing:(hbox#pack ~expand:false) () in
ignore (but#connect#toggled
~callback:(fun _ -> if but#active then value := modifier::!value
else value := List.filter ((<>) modifier) !value)))
param.md_allow
in
let _ = set_help_tip wev param.md_help in
object (self)
(** This method returns the main box ready to be packed. *)
method box = hbox#coerce
(** This method applies the new value of the parameter. *)
method apply =
let new_value = !value in
if new_value <> param.md_value then
let _ = param.md_f_apply new_value in
param.md_value <- new_value
else
()
end ;;
(*
(** This class is used to build a box for a parameter whose values are a list.*)
class ['a] list_param_box (param : 'a list_param) =
let _ = dbg "list_param_box" in
let listref = ref param.list_value in
let frame_selection = new list_selection_box
listref
param.list_titles
param.list_help
param.list_f_edit
param.list_strings
param.list_color
param.list_eq
param.list_f_add param.list_label param.list_editable
tt
in
object (self)
(** This method returns the main box ready to be packed. *)
method box = frame_selection#box#coerce
(** This method applies the new value of the parameter. *)
method apply =
param.list_f_apply !listref ;
param.list_value <- !listref
end ;;
*)
(** This class creates a configuration box from a configuration structure *)
class configuration_box conf_struct =
let main_box = GPack.hbox () in
let columns = new GTree.column_list in
let icon_col = columns#add GtkStock.conv in
let label_col = columns#add Gobject.Data.string in
let box_col = columns#add Gobject.Data.caml in
let () = columns#lock () in
let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in
(* Tree view part *)
let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in
let tree = GTree.tree_store columns in
let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in
let selection = view#selection in
let _ = selection#set_mode `SINGLE in
let menu_box = GPack.vbox ~packing:pane#pack2 () in
let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in
let col = GTree.view_column ~renderer () in
let _ = view#append_column col in
let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in
let col = GTree.view_column ~renderer () in
let _ = view#append_column col in
let make_param (main_box : #GPack.box) = function
| String_param p ->
let box = new string_param_box p in
let _ = main_box#pack ~expand: false ~padding: 2 box#box in
box
| Combo_param p ->
let box = new combo_param_box p in
let _ = main_box#pack ~expand: false ~padding: 2 box#box in
box
| Text_param p ->
let box = new text_param_box p in
let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
box
| Bool_param p ->
let box = new bool_param_box p in
let _ = main_box#pack ~expand: false ~padding: 2 box#box in
box
| List_param f ->
let box = f () in
let _ = main_box#pack ~expand: true ~padding: 2 box#box in
box
| Custom_param p ->
let box = new custom_param_box p in
let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
box
| Modifiers_param p ->
let box = new modifiers_param_box p in
let _ = main_box#pack ~expand: false ~padding: 2 box#box in
box
in
let set_icon iter = function
| None -> ()
| Some icon -> tree#set ~row:iter ~column:icon_col icon
in
(* Populate the tree *)
let rec make_tree iter conf_struct =
(* box is not shown at first *)
let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in
let new_iter = match iter with
| None -> tree#append ()
| Some parent -> tree#append ~parent ()
in
match conf_struct with
| Section (label, icon, param_list) ->
let params = List.map (make_param box) param_list in
let widget =
object
method box = box#coerce
method apply () = List.iter (fun param -> param#apply) params
end
in
let () = tree#set ~row:new_iter ~column:label_col label in
let () = set_icon new_iter icon in
let () = tree#set ~row:new_iter ~column:box_col widget in
()
| Section_list (label, icon, struct_list) ->
let widget =
object
(* Section_list does not contain any effect widget, so we do not have to
apply anything. *)
method apply () = ()
method box = box#coerce
end
in
let () = tree#set ~row:new_iter ~column:label_col label in
let () = set_icon new_iter icon in
let () = tree#set ~row:new_iter ~column:box_col widget in
List.iter (make_tree (Some new_iter)) struct_list
in
let () = List.iter (make_tree None) conf_struct in
(* Dealing with signals *)
let current_prop : widget option ref = ref None in
let select_iter iter =
let () = match !current_prop with
| None -> ()
| Some box -> box#box#misc#hide ()
in
let box = tree#get ~row:iter ~column:box_col in
let () = box#box#misc#show () in
current_prop := Some box
in
let when_selected () =
let rows = selection#get_selected_rows in
match rows with
| [] -> ()
| row :: _ ->
let iter = tree#get_iter row in
select_iter iter
in
(* Focus on a box when selected *)
let _ = selection#connect#changed ~callback:when_selected in
let _ = match tree#get_iter_first with
| None -> ()
| Some iter -> select_iter iter
in
object
method box = main_box
method apply =
let foreach _ iter =
let widget = tree#get ~row:iter ~column:box_col in
widget#apply(); false
in
tree#foreach foreach
end
(** This function takes a configuration structure list and creates a window
to configure the various parameters. *)
let edit ?(with_apply=true)
?(apply=(fun () -> ()))
title ?parent ?width ?height
conf_struct =
let dialog = GWindow.dialog
~position:`CENTER
~modal: true ~title: title
~type_hint:`DIALOG
?parent ?height ?width
()
in
let config_box = new configuration_box conf_struct in
let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in
if with_apply then
dialog#add_button Configwin_messages.mApply `APPLY;
dialog#add_button Configwin_messages.mOk `OK;
dialog#add_button Configwin_messages.mCancel `CANCEL;
let destroy () =
dialog#destroy ();
in
let rec iter rep =
try
match dialog#run () with
| `APPLY -> config_box#apply; iter Return_apply
| `OK -> config_box#apply; destroy (); Return_ok
| _ -> destroy (); rep
with
Failure s ->
GToolbox.message_box ~title:"Error" s; iter rep
| e ->
GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep
in
iter Return_cancel
(*
let edit_string l s =
match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with
None -> s
| Some s2 -> s2
*)
(** Create a string param. *)
let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
String_param
{
string_label = label ;
string_help = help ;
string_value = v ;
string_editable = editable ;
string_f_apply = f ;
string_expand = expand ;
string_to_string = (fun x -> x) ;
string_of_string = (fun x -> x) ;
}
(** Create a bool param. *)
let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
Bool_param
{
bool_label = label ;
bool_help = help ;
bool_value = v ;
bool_editable = editable ;
bool_f_apply = f ;
}
(*
(** Create a list param. *)
let list ?(editable=true) ?help
?(f=(fun (_:'a list) -> ()))
?(eq=Pervasives.(=))
?(edit:('a -> 'a) option)
?(add=(fun () -> ([] : 'a list)))
?titles ?(color=(fun (_:'a) -> (None : string option)))
label (f_strings : 'a -> string list) v =
List_param
(fun () ->
new list_param_box
{
list_label = label ;
list_help = help ;
list_value = v ;
list_editable = editable ;
list_titles = titles;
list_eq = eq ;
list_strings = f_strings ;
list_color = color ;
list_f_edit = edit ;
list_f_add = add ;
list_f_apply = f ;
}
)
(** Create a strings param. *)
let strings ?(editable=true) ?help
?(f=(fun _ -> ()))
?(eq=Pervasives.(=))
?(add=(fun () -> [])) label v =
list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v
*)
(** Create a combo param. *)
let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
?(new_allowed=false)
?(blank_allowed=false) label choices v =
Combo_param
{
combo_label = label ;
combo_help = help ;
combo_value = v ;
combo_editable = editable ;
combo_choices = choices ;
combo_new_allowed = new_allowed ;
combo_blank_allowed = blank_allowed ;
combo_f_apply = f ;
combo_expand = expand ;
}
let modifiers
?(editable=true)
?(expand=true)
?help
?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5])
?(f=(fun _ -> ())) label v =
Modifiers_param
{
md_label = label ;
md_help = help ;
md_value = v ;
md_editable = editable ;
md_f_apply = f ;
md_expand = expand ;
md_allow = allow ;
}
(** Create a custom param.*)
let custom ?label box f expand =
Custom_param
{
custom_box = box ;
custom_f_apply = f ;
custom_expand = expand ;
custom_framed = label ;
}
(* Copying lablgtk question_box + forbidding hiding *)
let question_box ~title ~buttons ?(default=1) ?icon ?parent message =
let button_nb = ref 0 in
let window = GWindow.dialog ~position:`CENTER ~modal:true ?parent ~type_hint:`DIALOG ~title () in
let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in
let bbox = window#action_area in
begin match icon with
None -> ()
| Some i -> hbox#pack i#coerce ~padding:4
end;
ignore (GMisc.label ~text: message ~packing: hbox#add ());
(* the function called to create each button by iterating *)
let rec iter_buttons n = function
[] ->
()
| button_label :: q ->
let b = GButton.button ~label: button_label
~packing:(bbox#pack ~expand:true ~padding:4) ()
in
ignore (b#connect#clicked ~callback:
(fun () -> button_nb := n; window#destroy ()));
(* If it's the first button then give it the focus *)
if n = default then b#grab_default () else ();
iter_buttons (n+1) q
in
iter_buttons 1 buttons;
ignore (window#connect#destroy ~callback: GMain.Main.quit);
window#set_position `CENTER;
window#show ();
GMain.Main.main ();
!button_nb
let message_box ~title ?icon ?parent ?(ok="Ok") message =
ignore (question_box ?icon ?parent ~title message ~buttons:[ ok ])
¤ Dauer der Verarbeitung: 0.9 Sekunden
(vorverarbeitet)
¤
|
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.
|
