type command = string
type menu =
{ mutable mn_label : string ;
mutable mn_children : menu_item list;
mutable mn_doc : bool ;
}
and menu_item_info =
{ mutable mii_label : string ;
mutable mii_command : command ;
mutable mii_stock_image : string option ;
}
and menu_item =
Submenu of menu
| Command of menu_item_info
| Separator
let default_menus =
[
{ mn_label = Cam_messages.file ;
mn_doc = false ;
mn_children =
[
Command
{ mii_label = Cam_messages.log_window ;
mii_command = Cam_constant.com_log_window ;
mii_stock_image = None ;
} ;
Separator ;
Command
{ mii_label = Cam_messages.quit ;
mii_command = Cam_constant.com_quit ;
mii_stock_image = Some (GtkStock.convert_id `QUIT);
} ;
] ;
} ;
{ mn_label = Cam_messages.doc ;
mn_doc = true ;
mn_children = [] ;
} ;
{ mn_label = "Configure" ;
mn_doc = false ;
mn_children =
[
Command
{ mii_label = "Menus" ;
mii_command = Cam_constant.com_configure_menus ;
mii_stock_image = None ;
} ;
Command
{ mii_label = "Button bar" ;
mii_command = Cam_constant.com_configure_bbar ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.common_keyboard_shortcuts ;
mii_command = Cam_constant.com_configure_common_keyboard_shortcuts ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.file_types_rules ;
mii_command = Cam_constant.com_configure_ft_rules ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.file_types_handlers ;
mii_command = Cam_constant.com_configure_ft_handlers ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.plugins ;
mii_command = Cam_constant.com_configure_plugins ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.doc_sources ;
mii_command = Cam_constant.com_configure_doc_sources ;
mii_stock_image = None ;
} ;
Command
{ mii_label = Cam_messages.docbrowser_keyboard_shortcuts ;
mii_command = Cam_constant.com_configure_docbrowser_keyboard_shortcuts ;
mii_stock_image = None ;
} ;
] ;
} ;
{ mn_label = "?" ;
mn_doc = false ;
mn_children =
[
Command
{ mii_label = Cam_messages.about ;
mii_command = Cam_constant.com_about_box ;
mii_stock_image = None ;
} ;
]
} ;
]
open Xml
exception Bad_format of xml
let rec xml_of_menu m =
Element ("menu",
("label", m.mn_label):: (if m.mn_doc then ["doc","true"] else []),
List.map xml_of_menu_item m.mn_children
)
and xml_of_command c =
Element ("command",
["label", c.mii_label ; "command", c.mii_command] @
(match c.mii_stock_image with None -> [] | Some s -> ["stock", s]),
[])
and xml_of_separator = Element ("separator", [], [])
and xml_of_menu_item = function
Submenu m -> xml_of_menu m
| Command mii -> xml_of_command mii
| Separator -> xml_of_separator
let string_of_menu l =
Xml.to_string (xml_of_menu l)
let rec menu_item_list_of_xmls l =
List.rev
(List.fold_left
(fun acc xml ->
match menu_item_opt_of_xml xml with
None -> acc
| Some mi -> mi :: acc
)
[]
l
)
and menu_item_opt_of_xml xml =
match xml with
Element ("menu", atts, subs) ->
(
try
let label = Xml.attrib xml "label" in
let doc =
try Xml.attrib xml "doc" = "true"
with _ -> false
in
let ch = menu_item_list_of_xmls subs in
Some
(Submenu { mn_label = label ;
mn_doc = doc ;
mn_children = ch ;
}
)
with
Not_found ->
raise (Bad_format xml)
)
| Element ("command", atts, _) ->
(
try
let label = Xml.attrib xml "label" in
let com = Xml.attrib xml "command" in
let stock =
try Some (Xml.attrib xml "stock")
with _ -> None
in
Some (Command { mii_label = label ;
mii_command = com ;
mii_stock_image = stock ;
}
)
with
Not_found ->
raise (Bad_format xml)
)
| Element ("separator",_,_) ->
Some Separator
| _ ->
None
let menu_of_xml xml =
match menu_item_opt_of_xml xml with
Some (Submenu m) -> m
| _ -> raise (Bad_format xml)
let menus_of_source source =
try
let t_parser = XmlParser.make () in
let _ = XmlParser.prove t_parser false in
let xml = XmlParser.parse t_parser source in
match xml with
Element ("menus", _, subs) -> List.map menu_of_xml subs
| _ -> raise (Bad_format xml)
with
Bad_format xml ->
let s = Cam_misc.chop_n_char 120 (Xml.to_string xml) in
failwith (Cam_messages.bad_format s)
let xml_of_menus l =
Element ("menus", [], List.map xml_of_menu l)
let string_of_menus l = Xml.to_string_fmt (xml_of_menus l)
let rc_file = Filename.concat Cam_rc.rc_dir "menus.xml"
let write_menus menus =
Cam_misc.file_of_string ~file: rc_file (string_of_menus menus)
let menus_of_file file =
try menus_of_source (XmlParser.SFile file)
with
Sys_error s
| Failure s ->
prerr_endline s ;
default_menus
| Xml.File_not_found _ ->
let m = default_menus in
write_menus m;
m
let clipboard = ref (None : menu_item option)
module C = Configwin
module M = Cam_messages
let params_menu_item mi =
match mi with
Separator -> []
| Command mii ->
let coms = Cam_commands.available_command_names () in
let param_label = C.string
~f: (fun s -> mii.mii_label <- s)
M.label
mii.mii_label
in
let param_command = C.combo
~f: (fun s -> mii.mii_command <- s)
~new_allowed: true
~blank_allowed: false
M.command
coms
mii.mii_command
in
[ param_label ; param_command ]
| Submenu m ->
let param_label = C.string
~f: (fun s -> m.mn_label <- s)
M.label
m.mn_label
in
let param_doc = C.bool
~f: (fun b -> m.mn_doc <- b)
M.doc_flag
m.mn_doc
in
[ param_label ; param_doc ]
let rec copy_menu m =
{ mn_label = m.mn_label ;
mn_doc = m.mn_doc ;
mn_children = List.map copy_menu_item m.mn_children ;
}
and copy_menu_item mi =
match mi with
Separator -> Separator
| Command i -> Command { mii_label = i.mii_label ;
mii_command = i.mii_command ;
mii_stock_image = i.mii_stock_image ;
}
| Submenu m -> Submenu (copy_menu m)
class menu_config_box f_update () =
let hbox = GPack.hbox () in
let wscroll = GBin.scrolled_window
~hpolicy: `AUTOMATIC
~vpolicy: `AUTOMATIC
~packing: (hbox#pack ~expand: true)
()
in
let cols = new GTree.column_list in
let col_display = cols#add Gobject.Data.string in
let (col_data: menu_item GTree.column) = cols#add Gobject.Data.caml 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 vbox = GPack.vbox ~packing: (hbox#pack ~expand: false ~padding: 4) () in
let wb_copy = GButton.button ~label: M.copy
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_cut = GButton.button ~label: M.cut
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_paste = GButton.button ~label: M.paste
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_edit = GButton.button ~label: M.edit
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_up = GButton.button ~label: M.up
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_down = GButton.button ~label: M.down
~packing: (vbox#pack ~expand: false ~padding: 2) () in
let wb_add = GButton.button ~label: M.add
~packing: (vbox#pack ~expand: false ~padding: 2) () in
object (self)
val mutable menus =
List.map copy_menu (menus_of_file rc_file)
method box = hbox
method apply () : unit =
let menus = self#build_menus () in
write_menus menus;
f_update ()
method selected_rr =
match tv#selection#get_selected_rows with
| [] -> None
| path :: _ -> Some (store#get_row_reference path)
method insert_in_selected ele =
match self#selected_rr with
None -> self#insert_menu_item ele
| Some rr -> self#insert_menu_item ~parent: rr ele
method string_of_menu_item mi =
match mi with
Submenu m -> self#string_of_menu m
| Command mii -> self#string_of_menu_item_info mii
| Separator -> self#string_of_separator
method string_of_menu m =
Printf.sprintf "%s%s"
(if m.mn_doc then "["^Cam_messages.doc^"]" else "")
m.mn_label
method string_of_menu_item_info mii =
mii.mii_label^" ["^mii.mii_command^"]"
method string_of_separator =
"-----------------"
method insert_menu_item ?parent ?pos mi =
let row =
match pos with
None -> store#append ?parent: (Cam_misc.map_opt (fun rr -> rr#iter) parent) ()
| Some pos -> store#insert ?parent: (Cam_misc.map_opt (fun rr -> rr#iter) parent) pos
in
let iter_rr rr = store#get_row_reference (store#get_path rr) in
match mi with
Submenu m ->
store#set row col_display (self#string_of_menu m);
store#set row col_data (Submenu { m with mn_children = [] });
List.iter (self#insert_menu_item ~parent: (iter_rr row)) m.mn_children
| Command mii ->
store#set row col_display (self#string_of_menu_item_info mii);
store#set row col_data (Command { mii with mii_label = mii.mii_label })
| Separator ->
store#set row col_display self#string_of_separator;
store#set row col_data Separator
method show_menus menus =
store#clear ();
List.iter self#insert_menu_item (List.map (fun m -> Submenu m) menus)
method get_children (it_opt : Gtk.tree_iter option) =
let first =
match it_opt with
None -> store#get_iter_first
| Some it ->
if store#iter_has_child it then
Gstuff.find_first_child store it
else
None
in
match first with
None -> []
| Some it ->
let rr it = store#get_row_reference (store#get_path it) in
let rec f acc it =
if store#iter_next it then
f (rr it :: acc) it
else
List.rev acc
in
f [rr it] it
method build_menus () =
List.fold_left
(fun acc row ->
match self#build_menu_item row with
Submenu m -> acc @ [m]
| _ -> acc
)
[]
(self#get_children None)
method build_menu_item row =
let rec build rr =
let it = rr#iter in
match store#get ~row: it ~column: col_data with
Submenu m ->
Submenu
{ m with
mn_children = List.map build
(self#get_children (Some rr#iter))
}
| Command mii ->
Command { mii with mii_label = mii.mii_label }
| Separator ->
Separator
in
build row
method edit () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
let mi = store#get ~row ~column: col_data in
match mi with
Separator -> ()
| _ ->
match C.simple_get M.edit (params_menu_item mi) with
C.Return_cancel -> ()
| C.Return_apply
| C.Return_ok ->
store#set ~row ~column: col_display (self#string_of_menu_item mi)
method copy () =
match self#selected_rr with
None -> ()
| Some rr ->
clipboard := Some (self#build_menu_item rr)
method delete ?(cut=false) () =
match self#selected_rr with
None -> ()
| Some rr ->
if cut then clipboard := Some (self#build_menu_item rr);
ignore (store#remove rr#iter) ;
tv#selection#unselect_all ()
method paste () =
match !clipboard with
None -> ()
| Some mi ->
let rr = self#selected_rr in
match rr with
None ->
(
match mi with
Submenu m ->
self#insert_menu_item mi ;
tv#selection#unselect_all ()
| Separator | Command _ -> ()
)
| Some rr ->
match store#get ~row: rr#iter ~column: col_data with
Separator | Command _ -> ()
| _ ->
self#insert_menu_item ~parent: rr mi ;
tv#selection#unselect_all ()
method move_up () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match Gstuff.find_iter_above store#coerce row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method move_down () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match Gstuff.find_iter_below store row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method add_menu_item title mi =
match C.simple_get title (params_menu_item mi) with
C.Return_cancel -> ()
| C.Return_apply
| C.Return_ok ->
let b = !clipboard in
clipboard := Some mi;
self#paste ();
clipboard := b
method add_menu () =
let m = { mn_label = "" ;
mn_doc = false ;
mn_children = [] }
in
self#add_menu_item M.add_menu (Submenu m)
method add_command () =
let c = { mii_label = "" ;
mii_command = Cam_constant.com_new_file ;
mii_stock_image = None;
}
in
self#add_menu_item M.add_command (Command c)
method add_separator () =
let b = !clipboard in
clipboard := Some Separator;
self#paste ();
clipboard := b
method add_select () =
let choices =
match self#selected_rr with
None -> [ M.menu, self#add_menu ]
| Some rr ->
let row = rr#iter in
match store#get ~row ~column: col_data with
Submenu m ->
[ M.menu, self#add_menu ;
M.command, self#add_command ;
M.separator, self#add_separator ]
| Command _ | Separator ->
[]
in
match choices with
[] -> ()
| l ->
GToolbox.popup_menu ~button: 1 ~time: Int32.zero
~entries: (List.map (fun (l,f) -> `I (l,f)) l)
initializer
self#show_menus menus;
ignore (wb_copy#connect#clicked self#copy);
ignore (wb_cut#connect#clicked (self#delete ~cut: true));
ignore (wb_paste#connect#clicked self#paste);
ignore (wb_edit#connect#clicked self#edit);
ignore (wb_up#connect#clicked self#move_up);
ignore (wb_down#connect#clicked self#move_down);
ignore (wb_add#connect#clicked self#add_select);
end
let doc_menu = ref (GMenu.menu ())
let rec create_menu_item menu mi =
let item =
match mi with
Command mii ->
let i = GMenu.image_menu_item
?stock: (Cam_misc.map_opt (fun s -> `STOCK s) mii.mii_stock_image)
~label: mii.mii_label ()
in
(
try
let t = Cam_commands.string_to_argv mii.mii_command in
let len = Array.length t in
if len <= 0 then
()
else
let com = t.(0) in
let args = Array.sub t 1 (len - 1) in
ignore (i#connect#activate
(fun () -> Cam_commands.launch_command com args))
with
Not_found ->
i#misc#set_sensitive false
);
i
| Submenu mn ->
let i = GMenu.image_menu_item ~label: mn.mn_label () in
let m = GMenu.menu () in
i#set_submenu m;
List.iter (create_menu_item m) mn.mn_children;
if mn.mn_doc then doc_menu := m;
i
| Separator ->
let i = GMenu.image_menu_item () in
i
in
menu#append (item :> GMenu.menu_item)
let create_menu menubar m =
let menu = GMenu.menu () in
let item = GMenu.image_menu_item ~label: m.mn_label ~packing: menubar#add () in
item#set_submenu menu;
List.iter (create_menu_item menu) m.mn_children;
if m.mn_doc then doc_menu := menu
let update_doc_menu load_doc =
Cam_doc.update load_doc Cam_doc.default_doc_modules
Cam_doc_gui.open_element
Cam_doc_gui.search_exact
Cam_doc_gui.search_regexp
!doc_menu;
Gc.compact ();
match !Cam_doc_gui.modules_window with
None -> ()
| Some _ -> Cam_doc_gui.create_or_update_list_window Cam_doc.default_doc_modules
let main_menu_bar = ref None
let update_menus ?(load_doc=false) (menubar : GMenu.menu_shell) =
main_menu_bar := Some menubar;
List.iter menubar#remove menubar#children;
let menus = menus_of_file rc_file in
List.iter
(create_menu menubar)
menus;
update_doc_menu load_doc
let _configure_menus args =
match !main_menu_bar with
None -> ()
| Some mbar ->
let box = new menu_config_box (fun () -> update_menus mbar) () in
let p = C.custom box#box box#apply true in
ignore (C.simple_get "Menu config" [p])
let _ = Cam_commands.register
{ Cam_commands.com_name = Cam_constant.com_configure_menus ;
Cam_commands.com_args = [| |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _configure_menus ;
}