13 class menu_shell_signals obj = object
14 inherit container_signals obj
16 GtkSignal.connect ~sgn:MenuShell.Signals.deactivate obj ~after
19 class type virtual ['a] pre_menu = object
20 inherit ['a] item_container
21 method as_menu : Gtk.menu Gtk.obj
22 method deactivate : unit -> unit
23 method connect : menu_shell_signals
24 method event : event_ops
25 method popup : button:int -> time:int -> unit
26 method popdown : unit -> unit
27 method set_accel_group : accel_group -> unit
32 class menu_item_signals obj = object
33 inherit item_signals obj
34 method activate = GtkSignal.connect ~sgn:MenuItem.Signals.activate obj
38 class ['a] pre_menu_item_skel obj = object
40 method as_item = MenuItem.coerce obj
41 method set_submenu (w : 'a pre_menu) = MenuItem.set_submenu obj w#as_menu
42 method remove_submenu () = MenuItem.remove_submenu obj
43 method configure = MenuItem.configure obj
44 method activate () = MenuItem.activate obj
45 method right_justify () = MenuItem.right_justify obj
46 method add_accelerator ~group ?modi:m ?flags key=
47 Widget.add_accelerator obj ~sgn:MenuItem.Signals.activate group ?flags
51 class menu_item obj = object
52 inherit [menu_item] pre_menu_item_skel obj
53 method connect = new menu_item_signals obj
54 method event = new GObj.event_ops obj
57 class menu_item_skel = [menu_item] pre_menu_item_skel
59 let pack_item self ~packing ~show =
60 may packing ~f:(fun f -> (f (self :> menu_item) : unit));
61 if show <> Some false then self#misc#show ();
64 let menu_item ?label ?border_width ?width ?height ?packing ?show () =
65 let w = MenuItem.create ?label () in
66 Container.set w ?border_width ?width ?height;
67 pack_item (new menu_item w) ?packing ?show
69 let tearoff_item ?border_width ?width ?height ?packing ?show () =
70 let w = MenuItem.tearoff_create () in
71 Container.set w ?border_width ?width ?height;
72 pack_item (new menu_item w) ?packing ?show
74 class check_menu_item_signals obj = object
75 inherit menu_item_signals obj
77 GtkSignal.connect ~sgn:CheckMenuItem.Signals.toggled obj ~after
80 class check_menu_item obj = object
81 inherit menu_item_skel obj
82 method set_active = CheckMenuItem.set_active obj
83 method set_show_toggle = CheckMenuItem.set_show_toggle obj
84 method active = CheckMenuItem.get_active obj
85 method toggled () = CheckMenuItem.toggled obj
86 method connect = new check_menu_item_signals obj
87 method event = new GObj.event_ops obj
90 let check_menu_item ?label ?active ?show_toggle
91 ?border_width ?width ?height ?packing ?show () =
92 let w = CheckMenuItem.create ?label () in
93 CheckMenuItem.set w ?active ?show_toggle;
94 Container.set w ?border_width ?width ?height;
95 pack_item (new check_menu_item w) ?packing ?show
97 class radio_menu_item obj = object
98 inherit check_menu_item (obj : Gtk.radio_menu_item obj)
99 method group = Some obj
100 method set_group = RadioMenuItem.set_group obj
103 let radio_menu_item ?group ?label ?active ?show_toggle
104 ?border_width ?width ?height ?packing ?show () =
105 let w = RadioMenuItem.create ?group ?label () in
106 CheckMenuItem.set w ?active ?show_toggle;
107 Container.set w ?border_width ?width ?height;
108 pack_item (new radio_menu_item w) ?packing ?show
112 class menu_shell obj = object
113 inherit [menu_item] item_container obj
114 method private wrap w = new menu_item (MenuItem.cast w)
115 method insert w = MenuShell.insert obj w#as_item
116 method deactivate () = MenuShell.deactivate obj
117 method connect = new menu_shell_signals obj
118 method event = new GObj.event_ops obj
121 class menu obj = object
122 inherit menu_shell obj
123 method popup = Menu.popup obj
124 method popdown () = Menu.popdown obj
125 method as_menu : Gtk.menu obj = obj
126 method set_accel_group = Menu.set_accel_group obj
129 let menu ?border_width ?packing ?show () =
130 let w = Menu.create () in
131 may border_width ~f:(Container.set_border_width w);
132 let self = new menu w in
133 may packing ~f:(fun f -> (f (self :> menu) : unit));
134 if show <> Some false then self#misc#show ();
137 (* Option Menu (GtkButton?) *)
139 class option_menu obj = object
140 inherit GButton.button_skel obj
141 method connect = new GButton.button_signals obj
142 method event = new GObj.event_ops obj
143 method set_menu (menu : menu) = OptionMenu.set_menu obj menu#as_menu
144 method get_menu = new menu (OptionMenu.get_menu obj)
145 method remove_menu () = OptionMenu.remove_menu obj
146 method set_history = OptionMenu.set_history obj
149 let option_menu ?border_width ?width ?height ?packing ?show () =
150 let w = OptionMenu.create () in
151 Container.set w ?border_width ?width ?height;
152 pack_return (new option_menu w) ~packing ~show
156 let menu_bar ?border_width ?width ?height ?packing ?show () =
157 let w = MenuBar.create () in
158 Container.set w ?border_width ?width ?height;
159 pack_return (new menu_shell w) ~packing ~show
164 ?(accel_group=AccelGroup.create ())
165 ?(accel_modi=[`CONTROL])
166 ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
168 val menu_shell : #menu_shell = menu_shell
169 val group = accel_group
171 val flags = accel_flags
172 method menu = menu_shell
173 method accel_group = group
174 method private bind ?key ?callback (item : menu_item) =
175 menu_shell#append item;
176 may key ~f:(item#add_accelerator ~group ~modi:m ~flags);
177 may callback ~f:(fun callback -> item#connect#activate ~callback)
178 method add_item ?key ?callback ?submenu label =
179 let item = menu_item ~label () in
180 self#bind item ?key ?callback;
181 may (submenu : menu option) ~f:item#set_submenu;
183 method add_check_item ?active ?key ?callback label =
184 let item = check_menu_item ~label ?active () in
185 self#bind (item :> menu_item) ?key
186 ?callback:(may_map callback ~f:(fun f () -> f item#active));
188 method add_radio_item ?group ?active ?key ?callback label =
189 let item = radio_menu_item ~label ?group ?active () in
190 self#bind (item :> menu_item) ?key
191 ?callback:(may_map callback ~f:(fun f () -> f item#active));
193 method add_separator () = menu_item ~packing:menu_shell#append ()
194 method add_submenu ?key label =
195 let item = menu_item ~label () in
197 menu ~packing:item#set_submenu ();
198 method add_tearoff () = tearoff_item ~packing:menu_shell#append ()