+++ /dev/null
-(* $Id$ *)
-
-open Gaux
-open Gtk
-open GtkData
-open GtkBase
-open GtkMenu
-open GObj
-open GContainer
-
-(* Menu type *)
-
-class menu_shell_signals obj = object
- inherit container_signals obj
- method deactivate =
- GtkSignal.connect ~sgn:MenuShell.Signals.deactivate obj ~after
-end
-
-class type virtual ['a] pre_menu = object
- inherit ['a] item_container
- method as_menu : Gtk.menu Gtk.obj
- method deactivate : unit -> unit
- method connect : menu_shell_signals
- method event : event_ops
- method popup : button:int -> time:int -> unit
- method popdown : unit -> unit
- method set_accel_group : accel_group -> unit
-end
-
-(* Menu items *)
-
-class menu_item_signals obj = object
- inherit item_signals obj
- method activate = GtkSignal.connect ~sgn:MenuItem.Signals.activate obj
-end
-
-
-class ['a] pre_menu_item_skel obj = object
- inherit container obj
- method as_item = MenuItem.coerce obj
- method set_submenu (w : 'a pre_menu) = MenuItem.set_submenu obj w#as_menu
- method remove_submenu () = MenuItem.remove_submenu obj
- method configure = MenuItem.configure obj
- method activate () = MenuItem.activate obj
- method right_justify () = MenuItem.right_justify obj
- method add_accelerator ~group ?modi:m ?flags key=
- Widget.add_accelerator obj ~sgn:MenuItem.Signals.activate group ?flags
- ?modi:m ~key
-end
-
-class menu_item obj = object
- inherit [menu_item] pre_menu_item_skel obj
- method connect = new menu_item_signals obj
- method event = new GObj.event_ops obj
-end
-
-class menu_item_skel = [menu_item] pre_menu_item_skel
-
-let pack_item self ~packing ~show =
- may packing ~f:(fun f -> (f (self :> menu_item) : unit));
- if show <> Some false then self#misc#show ();
- self
-
-let menu_item ?label ?border_width ?width ?height ?packing ?show () =
- let w = MenuItem.create ?label () in
- Container.set w ?border_width ?width ?height;
- pack_item (new menu_item w) ?packing ?show
-
-let tearoff_item ?border_width ?width ?height ?packing ?show () =
- let w = MenuItem.tearoff_create () in
- Container.set w ?border_width ?width ?height;
- pack_item (new menu_item w) ?packing ?show
-
-class check_menu_item_signals obj = object
- inherit menu_item_signals obj
- method toggled =
- GtkSignal.connect ~sgn:CheckMenuItem.Signals.toggled obj ~after
-end
-
-class check_menu_item obj = object
- inherit menu_item_skel obj
- method set_active = CheckMenuItem.set_active obj
- method set_show_toggle = CheckMenuItem.set_show_toggle obj
- method active = CheckMenuItem.get_active obj
- method toggled () = CheckMenuItem.toggled obj
- method connect = new check_menu_item_signals obj
- method event = new GObj.event_ops obj
-end
-
-let check_menu_item ?label ?active ?show_toggle
- ?border_width ?width ?height ?packing ?show () =
- let w = CheckMenuItem.create ?label () in
- CheckMenuItem.set w ?active ?show_toggle;
- Container.set w ?border_width ?width ?height;
- pack_item (new check_menu_item w) ?packing ?show
-
-class radio_menu_item obj = object
- inherit check_menu_item (obj : Gtk.radio_menu_item obj)
- method group = Some obj
- method set_group = RadioMenuItem.set_group obj
-end
-
-let radio_menu_item ?group ?label ?active ?show_toggle
- ?border_width ?width ?height ?packing ?show () =
- let w = RadioMenuItem.create ?group ?label () in
- CheckMenuItem.set w ?active ?show_toggle;
- Container.set w ?border_width ?width ?height;
- pack_item (new radio_menu_item w) ?packing ?show
-
-(* Menus *)
-
-class menu_shell obj = object
- inherit [menu_item] item_container obj
- method private wrap w = new menu_item (MenuItem.cast w)
- method insert w = MenuShell.insert obj w#as_item
- method deactivate () = MenuShell.deactivate obj
- method connect = new menu_shell_signals obj
- method event = new GObj.event_ops obj
-end
-
-class menu obj = object
- inherit menu_shell obj
- method popup = Menu.popup obj
- method popdown () = Menu.popdown obj
- method as_menu : Gtk.menu obj = obj
- method set_accel_group = Menu.set_accel_group obj
-end
-
-let menu ?border_width ?packing ?show () =
- let w = Menu.create () in
- may border_width ~f:(Container.set_border_width w);
- let self = new menu w in
- may packing ~f:(fun f -> (f (self :> menu) : unit));
- if show <> Some false then self#misc#show ();
- self
-
-(* Option Menu (GtkButton?) *)
-
-class option_menu obj = object
- inherit GButton.button_skel obj
- method connect = new GButton.button_signals obj
- method event = new GObj.event_ops obj
- method set_menu (menu : menu) = OptionMenu.set_menu obj menu#as_menu
- method get_menu = new menu (OptionMenu.get_menu obj)
- method remove_menu () = OptionMenu.remove_menu obj
- method set_history = OptionMenu.set_history obj
-end
-
-let option_menu ?border_width ?width ?height ?packing ?show () =
- let w = OptionMenu.create () in
- Container.set w ?border_width ?width ?height;
- pack_return (new option_menu w) ~packing ~show
-
-(* Menu Bar *)
-
-let menu_bar ?border_width ?width ?height ?packing ?show () =
- let w = MenuBar.create () in
- Container.set w ?border_width ?width ?height;
- pack_return (new menu_shell w) ~packing ~show
-
-(* Menu Factory *)
-
-class ['a] factory
- ?(accel_group=AccelGroup.create ())
- ?(accel_modi=[`CONTROL])
- ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
- object (self)
- val menu_shell : #menu_shell = menu_shell
- val group = accel_group
- val m = accel_modi
- val flags = accel_flags
- method menu = menu_shell
- method accel_group = group
- method private bind ?key ?callback (item : menu_item) =
- menu_shell#append item;
- may key ~f:(item#add_accelerator ~group ~modi:m ~flags);
- may callback ~f:(fun callback -> item#connect#activate ~callback)
- method add_item ?key ?callback ?submenu label =
- let item = menu_item ~label () in
- self#bind item ?key ?callback;
- may (submenu : menu option) ~f:item#set_submenu;
- item
- method add_check_item ?active ?key ?callback label =
- let item = check_menu_item ~label ?active () in
- self#bind (item :> menu_item) ?key
- ?callback:(may_map callback ~f:(fun f () -> f item#active));
- item
- method add_radio_item ?group ?active ?key ?callback label =
- let item = radio_menu_item ~label ?group ?active () in
- self#bind (item :> menu_item) ?key
- ?callback:(may_map callback ~f:(fun f () -> f item#active));
- item
- method add_separator () = menu_item ~packing:menu_shell#append ()
- method add_submenu ?key label =
- let item = menu_item ~label () in
- self#bind item ?key;
- menu ~packing:item#set_submenu ();
- method add_tearoff () = tearoff_item ~packing:menu_shell#append ()
-end
projects / helm.git / blobdiff