helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gPack.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open GtkBase
   6 open GtkPack
   7 open GObj
   8 open GContainer
   9
  10 class box_skel obj = object
  11   inherit container obj
  12   method pack ?from:f ?expand ?fill ?padding w =
  13     Box.pack obj (as_widget w) ?from:f ?expand ?fill ?padding
  14   method set_homogeneous = Box.set_homogeneous obj
  15   method set_spacing = Box.set_spacing obj
  16   method set_child_packing ?from:f ?expand ?fill ?padding w =
  17     Box.set_child_packing obj (as_widget w) ?from:f ?expand ?fill ?padding
  18   method reorder_child w = Box.reorder_child obj (as_widget w)
  19 end
  20
  21 class box obj = object
  22   inherit box_skel obj
  23   method connect = new container_signals obj
  24 end
  25
  26 let box dir ?homogeneous ?spacing ?border_width ?width ?height
  27     ?packing ?show () =
  28   let w = Box.create dir ?homogeneous ?spacing () in
  29   Container.set w ?border_width ?width ?height;
  30   pack_return (new box w) ~packing ~show
  31
  32 let vbox = box `VERTICAL
  33 let hbox = box `HORIZONTAL
  34
  35 class button_box obj = object
  36   inherit box_skel (obj : Gtk.button_box obj)
  37   method connect = new container_signals obj
  38   method set_layout  = BBox.set_layout  obj
  39   method set_spacing = BBox.set_spacing obj
  40   method set_child_size = BBox.set_child_size obj
  41   method set_child_ipadding = BBox.set_child_ipadding obj
  42 end
  43
  44 let button_box dir ?spacing ?child_width ?child_height ?child_ipadx
  45     ?child_ipady ?layout ?border_width ?width ?height ?packing ?show ()=
  46   let w = BBox.create dir in
  47   BBox.set w ?spacing ?child_width ?child_height ?child_ipadx
  48     ?child_ipady ?layout;
  49   Container.set w ?border_width ?width ?height;
  50   pack_return (new button_box w) ~packing ~show
  51
  52 class table obj = object
  53   inherit container_full (obj : Gtk.table obj)
  54   method attach ~left ~top ?right ?bottom ?expand ?fill ?shrink
  55       ?xpadding ?ypadding w =
  56     Table.attach obj (as_widget w) ~left ~top ?right ?bottom ?expand
  57       ?fill ?shrink ?xpadding ?ypadding
  58   method set_row_spacing = Table.set_row_spacing obj
  59   method set_col_spacing = Table.set_col_spacing obj
  60   method set_row_spacings = Table.set_row_spacings obj
  61   method set_col_spacings = Table.set_col_spacings obj
  62   method set_homogeneous = Table.set_homogeneous obj
  63 end
  64
  65 let table ~rows ~columns ?homogeneous ?row_spacings ?col_spacings
  66     ?border_width ?width ?height ?packing ?show () =
  67   let w = Table.create ~rows ~columns ?homogeneous () in
  68   Table.set w ?row_spacings ?col_spacings;
  69   Container.set w ?border_width ?width ?height;
  70   pack_return (new table w) ~packing ~show
  71
  72 class fixed obj = object
  73   inherit container_full (obj : Gtk.fixed obj)
  74   method event = new GObj.event_ops obj
  75   method put w = Fixed.put obj (as_widget w)
  76   method move w = Fixed.move obj (as_widget w)
  77 end
  78
  79 let fixed ?border_width ?width ?height ?packing ?show () =
  80   let w = Fixed.create () in
  81   Container.set w ?border_width ?width ?height;
  82   pack_return (new fixed w) ~packing ~show
  83
  84 class layout obj = object
  85   inherit container_full (obj : Gtk.layout obj)
  86   method event = new GObj.event_ops obj
  87   method put w = Layout.put obj (as_widget w)
  88   method move w = Layout.move obj (as_widget w)
  89   method set_hadjustment adj =
  90     Layout.set_hadjustment obj (GData.as_adjustment adj)
  91   method set_vadjustment adj =
  92     Layout.set_vadjustment obj (GData.as_adjustment adj)
  93   method set_width width = Layout.set_size obj ~width
  94   method set_height height = Layout.set_size obj ~height
  95   method hadjustment = new GData.adjustment (Layout.get_hadjustment obj)
  96   method vadjustment = new GData.adjustment (Layout.get_vadjustment obj)
  97   method freeze () = Layout.freeze obj
  98   method thaw () = Layout.thaw obj
  99   method width = Layout.get_width obj
 100   method height = Layout.get_height obj
 101 end
 102
 103 let layout ?hadjustment ?vadjustment ?layout_width ?layout_height
 104     ?border_width ?width ?height ?packing ?show () =
 105   let w = Layout.create
 106       (Gpointer.optboxed (may_map ~f:GData.as_adjustment hadjustment))
 107       (Gpointer.optboxed (may_map ~f:GData.as_adjustment vadjustment)) in
 108   if layout_width <> None || layout_height <> None then
 109     Layout.set_size w ?width:layout_width ?height:layout_height;
 110   Container.set w ?border_width ?width ?height;
 111   pack_return (new layout w) ~packing ~show
 112
 113
 114 class packer obj = object
 115   inherit container_full (obj : Gtk.packer obj)
 116   method pack ?side ?anchor ?expand ?fill
 117       ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y w =
 118     let options = Packer.build_options ?expand ?fill () in
 119     if border_width == None && pad_x == None && pad_y == None &&
 120       i_pad_x == None && i_pad_y == None
 121       then Packer.add_defaults obj (as_widget w) ?side ?anchor ~options
 122       else Packer.add obj (as_widget w) ?side ?anchor ~options
 123           ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y
 124   method set_child_packing ?side ?anchor ?expand ?fill
 125       ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y w =
 126     Packer.set_child_packing obj (as_widget w) ?side ?anchor
 127       ~options:(Packer.build_options ?expand ?fill ())
 128       ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y
 129   method reorder_child w = Packer.reorder_child obj (as_widget w)
 130   method set_spacing = Packer.set_spacing obj
 131   method set_defaults = Packer.set_defaults obj
 132 end
 133
 134 let packer ?spacing ?border_width ?width ?height ?packing ?show () =
 135   let w = Packer.create () in
 136   may spacing ~f:(Packer.set_spacing w);
 137   Container.set w ?border_width ?width ?height;
 138   pack_return (new packer w) ~packing ~show
 139
 140 class paned obj = object
 141   inherit container_full (obj : Gtk.paned obj)
 142   method event = new GObj.event_ops obj
 143   method add w =
 144     if List.length (Container.children obj) = 2 then
 145       raise(Error "Gpack.paned#add: already full");
 146     Container.add obj (as_widget w)
 147   method add1 w =
 148     try ignore(Paned.child1 obj); raise(Error "GPack.paned#add1: already full")
 149     with _ -> Paned.add1 obj (as_widget w)
 150   method add2 w =
 151     try ignore(Paned.child2 obj); raise(Error "GPack.paned#add2: already full")
 152     with _ -> Paned.add2 obj (as_widget w)
 153   method set_handle_size = Paned.set_handle_size obj
 154   method set_gutter_size = Paned.set_gutter_size obj
 155   method child1 = new widget (Paned.child1 obj)
 156   method child2 = new widget (Paned.child2 obj)
 157   method handle_size = Paned.handle_size obj
 158   method gutter_size = Paned.gutter_size obj
 159 end
 160
 161 let paned dir ?handle_size ?gutter_size
 162     ?border_width ?width ?height ?packing ?show () =
 163   let w = Paned.create dir in
 164   Paned.set w ?handle_size ?gutter_size;
 165   Container.set w ?border_width ?width ?height;
 166   pack_return (new paned w) ~packing ~show
 167
 168 class notebook_signals obj = object
 169   inherit GContainer.container_signals obj
 170   method switch_page =
 171     GtkSignal.connect obj ~sgn:Notebook.Signals.switch_page ~after
 172 end
 173
 174 class notebook obj = object (self)
 175   inherit GContainer.container obj
 176   method event = new GObj.event_ops obj
 177   method connect = new notebook_signals obj
 178   method insert_page ?tab_label ?menu_label ~pos child =
 179       Notebook.insert_page obj (as_widget child) ~pos
 180         ~tab_label:(Gpointer.may_box tab_label ~f:as_widget)
 181         ~menu_label:(Gpointer.may_box menu_label ~f:as_widget)
 182   method append_page = self#insert_page ~pos:(-1)
 183   method prepend_page = self#insert_page ~pos:0
 184   method remove_page = Notebook.remove_page obj
 185   method current_page = Notebook.get_current_page obj
 186   method goto_page = Notebook.set_page obj
 187   method previous_page () = Notebook.prev_page obj
 188   method next_page () = Notebook.next_page obj
 189   method set_tab_pos = Notebook.set_tab_pos obj
 190   method set_show_tabs = Notebook.set_show_tabs obj
 191   method set_homogeneous_tabs = Notebook.set_homogeneous_tabs obj
 192   method set_show_border = Notebook.set_show_border obj
 193   method set_scrollable = Notebook.set_scrollable obj
 194   method set_tab_border = Notebook.set_tab_border obj
 195   method set_popup = Notebook.set_popup obj
 196   method page_num w = Notebook.page_num obj (as_widget w)
 197   method get_nth_page n = new widget (Notebook.get_nth_page obj n)
 198   method get_tab_label w =
 199     new widget (Notebook.get_tab_label obj (as_widget w))
 200   method get_menu_label w =
 201     new widget (Notebook.get_tab_label obj (as_widget w))
 202   method set_page ?tab_label ?menu_label page =
 203     let child = as_widget page in
 204     may tab_label
 205       ~f:(fun lbl -> Notebook.set_tab_label obj child (as_widget lbl));
 206     may menu_label
 207       ~f:(fun lbl -> Notebook.set_menu_label obj child (as_widget lbl))
 208 end
 209
 210 let notebook ?tab_pos ?tab_border ?show_tabs ?homogeneous_tabs
 211     ?show_border ?scrollable ?popup
 212     ?border_width ?width ?height ?packing ?show () =
 213   let w = Notebook.create () in
 214   Notebook.set w ?tab_pos ?tab_border ?show_tabs
 215     ?homogeneous_tabs ?show_border ?scrollable ?popup;
 216   Container.set w ?border_width ?width ?height;
 217   pack_return (new notebook w) ~packing ~show