]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gMenu.ml
.cvsignore files missing
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20001129-0.1.0 / gMenu.ml
1 (* $Id$ *)
2
3 open Gaux
4 open Gtk
5 open GtkData
6 open GtkBase
7 open GtkMenu
8 open GObj
9 open GContainer
10
11 (* Menu type *)
12
13 class menu_shell_signals obj = object
14   inherit container_signals obj
15   method deactivate =
16     GtkSignal.connect ~sgn:MenuShell.Signals.deactivate obj ~after
17 end
18
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
28 end
29
30 (* Menu items *)
31
32 class menu_item_signals obj = object
33   inherit item_signals obj
34   method activate = GtkSignal.connect ~sgn:MenuItem.Signals.activate obj
35 end
36
37
38 class ['a] pre_menu_item_skel obj = object
39   inherit container obj
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
48       ?modi:m ~key
49 end
50
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
55 end
56
57 class menu_item_skel = [menu_item] pre_menu_item_skel
58
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 ();
62   self
63
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
68
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
73
74 class check_menu_item_signals obj = object
75   inherit menu_item_signals obj
76   method toggled =
77     GtkSignal.connect ~sgn:CheckMenuItem.Signals.toggled obj ~after
78 end
79
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
88 end
89
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
96
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
101 end
102
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
109
110 (* Menus *)
111
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
119 end
120
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
127 end
128
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 ();
135   self
136
137 (* Option Menu (GtkButton?) *)
138
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
147 end
148
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
153
154 (* Menu Bar *)
155
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
160
161 (* Menu Factory *)
162
163 class ['a] factory
164     ?(accel_group=AccelGroup.create ())
165     ?(accel_modi=[`CONTROL])
166     ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
167   object (self)
168     val menu_shell : #menu_shell = menu_shell
169     val group = accel_group
170     val m = accel_modi
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;
182       item
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));
187       item
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));
192       item
193     method add_separator () = menu_item ~packing:menu_shell#append ()
194     method add_submenu ?key label =
195       let item = menu_item ~label () in
196       self#bind item ?key;
197       menu ~packing:item#set_submenu ();
198     method add_tearoff () = tearoff_item ~packing:menu_shell#append ()
199 end