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