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

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6 open GtkBase
   7
   8 module Box = struct
   9   let cast w : box obj = Object.try_cast w "GtkBox"
  10   external coerce : [>`box] obj -> box obj = "%identity"
  11   external pack_start :
  12       [>`box] obj -> [>`widget] obj ->
  13       expand:bool -> fill:bool -> padding:int -> unit
  14       = "ml_gtk_box_pack_start"
  15   external pack_end :
  16       [>`box] obj -> [>`widget] obj ->
  17       expand:bool -> fill:bool -> padding:int -> unit
  18       = "ml_gtk_box_pack_end"
  19   let pack box ?from:( dir = (`START : pack_type))
  20       ?(expand=false) ?(fill=true) ?(padding=0) child =
  21     (match dir with `START -> pack_start | `END -> pack_end)
  22       box child ~expand ~fill ~padding
  23   external reorder_child : [>`box] obj -> [>`widget] obj -> pos:int -> unit
  24       = "ml_gtk_box_reorder_child"
  25   external set_homogeneous : [>`box] obj -> bool -> unit
  26       = "ml_gtk_box_set_homogeneous"
  27   external set_spacing : [>`box] obj -> int -> unit
  28       = "ml_gtk_box_set_spacing"
  29   let set ?homogeneous ?spacing w =
  30     may homogeneous ~f:(set_homogeneous w);
  31     may spacing ~f:(set_spacing w)
  32   type packing =
  33       { expand: bool; fill: bool; padding: int; pack_type: pack_type }
  34   external query_child_packing : [>`box] obj -> [>`widget] obj -> packing
  35       = "ml_gtk_box_query_child_packing"
  36   external set_child_packing :
  37       [>`box] obj -> [>`widget] obj ->
  38       ?expand:bool -> ?fill:bool -> ?padding:int -> ?from:pack_type -> unit
  39       = "ml_gtk_box_set_child_packing_bc" "ml_gtk_box_set_child_packing"
  40   external hbox_new : homogeneous:bool -> spacing:int -> box obj
  41       = "ml_gtk_hbox_new"
  42   external vbox_new : homogeneous:bool -> spacing:int -> box obj
  43       = "ml_gtk_vbox_new"
  44   let create (dir : orientation) ?(homogeneous=false) ?(spacing=0) () =
  45     (match dir with `HORIZONTAL -> hbox_new | `VERTICAL -> vbox_new)
  46       ~homogeneous ~spacing
  47 end
  48
  49 module BBox = struct
  50   (* Omitted defaults setting *)
  51   let cast w : button_box obj = Object.try_cast w "GtkBBox"
  52   external coerce : [>`bbox] obj -> button_box obj = "%identity"
  53   type bbox_style = [ `DEFAULT_STYLE|`SPREAD|`EDGE|`START|`END ]
  54   external get_spacing : [>`bbox] obj -> int = "ml_gtk_button_box_get_spacing"
  55   external get_child_width : [>`bbox] obj -> int
  56       = "ml_gtk_button_box_get_child_min_width"
  57   external get_child_height : [>`bbox] obj -> int
  58       = "ml_gtk_button_box_get_child_min_height"
  59   external get_child_ipadx : [>`bbox] obj -> int
  60       = "ml_gtk_button_box_get_child_ipad_x"
  61   external get_child_ipady : [>`bbox] obj -> int
  62       = "ml_gtk_button_box_get_child_ipad_y"
  63   external get_layout : [>`bbox] obj -> bbox_style
  64       = "ml_gtk_button_box_get_layout_style"
  65   external set_spacing : [>`bbox] obj -> int -> unit
  66       = "ml_gtk_button_box_set_spacing"
  67   external set_child_size : [>`bbox] obj -> width:int -> height:int -> unit
  68       = "ml_gtk_button_box_set_child_size"
  69   external set_child_ipadding : [>`bbox] obj -> x:int -> y:int -> unit
  70       = "ml_gtk_button_box_set_child_ipadding"
  71   external set_layout : [>`bbox] obj -> bbox_style -> unit
  72       = "ml_gtk_button_box_set_layout"
  73   let set_child_size w ?width ?height () =
  74     set_child_size w ~width:(may_default get_child_width w ~opt:width)
  75       ~height:(may_default get_child_height w ~opt:height)
  76   let set_child_ipadding w ?x ?y () =
  77     set_child_ipadding w
  78       ~x:(may_default get_child_ipadx w ~opt:x)
  79       ~y:(may_default get_child_ipady w ~opt:y)
  80   let set ?spacing ?child_width ?child_height ?child_ipadx
  81       ?child_ipady ?layout w =
  82     may spacing ~f:(set_spacing w);
  83     if child_width <> None || child_height <> None then
  84       set_child_size w ?width:child_width ?height:child_height ();
  85     if child_ipadx <> None || child_ipady <> None then
  86       set_child_ipadding w ?x:child_ipadx ?y:child_ipady ();
  87     may layout ~f:(set_layout w)
  88   external set_child_size_default : width:int -> height:int -> unit
  89       = "ml_gtk_button_box_set_child_size_default"
  90   external set_child_ipadding_default : x:int -> y:int -> unit
  91       = "ml_gtk_button_box_set_child_ipadding_default"
  92   external create_hbbox : unit -> button_box obj = "ml_gtk_hbutton_box_new"
  93   external create_vbbox : unit -> button_box obj = "ml_gtk_vbutton_box_new"
  94   let create (dir : orientation) =
  95     if dir = `HORIZONTAL then create_hbbox () else create_vbbox ()
  96 end
  97
  98 module Fixed = struct
  99   let cast w : fixed obj = Object.try_cast w "GtkFixed"
 100   external create : unit -> fixed obj = "ml_gtk_fixed_new"
 101   external put : [>`fixed] obj -> [>`widget] obj -> x:int -> y:int -> unit
 102       = "ml_gtk_fixed_put"
 103   external move : [>`fixed] obj -> [>`widget] obj -> x:int -> y:int -> unit
 104       = "ml_gtk_fixed_move"
 105 end
 106
 107 module Layout = struct
 108   let cast w : layout obj = Object.try_cast w "GtkLayout"
 109   external create :
 110       [>`adjustment] optobj -> [>`adjustment] optobj -> layout obj
 111       = "ml_gtk_layout_new"
 112   external put : [>`layout] obj -> [>`widget] obj -> x:int -> y:int -> unit
 113       = "ml_gtk_layout_put"
 114   external move : [>`layout] obj -> [>`widget] obj -> x:int -> y:int -> unit
 115       = "ml_gtk_layout_move"
 116   external set_size : [>`layout] obj -> width:int -> height:int -> unit
 117       = "ml_gtk_layout_set_size"
 118   external get_hadjustment : [>`layout] obj -> adjustment obj
 119       = "ml_gtk_layout_get_hadjustment"
 120   external get_vadjustment : [>`layout] obj -> adjustment obj
 121       = "ml_gtk_layout_get_vadjustment"
 122   external set_hadjustment : [>`layout] obj -> [>`adjustment] obj -> unit
 123       = "ml_gtk_layout_set_hadjustment"
 124   external set_vadjustment : [>`layout] obj -> [>`adjustment] obj -> unit
 125       = "ml_gtk_layout_set_vadjustment"
 126   external freeze : [>`layout] obj -> unit
 127       = "ml_gtk_layout_freeze"
 128   external thaw : [>`layout] obj -> unit
 129       = "ml_gtk_layout_thaw"
 130   external get_height : [>`layout] obj -> int
 131       = "ml_gtk_layout_get_height"
 132   external get_width : [>`layout] obj -> int
 133       = "ml_gtk_layout_get_width"
 134   let set_size ?width ?height w =
 135     set_size w ~width:(may_default get_width w ~opt:width)
 136       ~height:(may_default get_height w ~opt:height)
 137 end
 138
 139
 140 module Packer = struct
 141   let cast w : packer obj = Object.try_cast w "GtkPacker"
 142   external create : unit -> packer obj = "ml_gtk_packer_new"
 143   external add :
 144       [>`packer] obj -> [>`widget] obj ->
 145       ?side:side_type -> ?anchor:anchor_type ->
 146       ?options:packer_options list ->
 147       ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
 148       ?i_pad_x:int -> ?i_pad_y:int -> unit
 149       = "ml_gtk_packer_add_bc" "ml_gtk_packer_add"
 150   external add_defaults :
 151       [>`packer] obj -> [>`widget] obj ->
 152       ?side:side_type -> ?anchor:anchor_type ->
 153       ?options:packer_options list -> unit
 154       = "ml_gtk_packer_add_defaults"
 155   external set_child_packing :
 156       [>`packer] obj -> [>`widget] obj ->
 157       ?side:side_type -> ?anchor:anchor_type ->
 158       ?options:packer_options list ->
 159       ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
 160       ?i_pad_x:int -> ?i_pad_y:int -> unit
 161       = "ml_gtk_packer_set_child_packing_bc" "ml_gtk_packer_set_child_packing"
 162   external reorder_child : [>`packer] obj -> [>`widget] obj -> pos:int -> unit
 163       = "ml_gtk_packer_reorder_child"
 164   external set_spacing : [>`packer] obj -> int -> unit
 165       = "ml_gtk_packer_set_spacing"
 166   external set_defaults :
 167       [>`packer] obj -> ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
 168       ?i_pad_x:int -> ?i_pad_y:int -> unit -> unit
 169       = "ml_gtk_packer_set_defaults_bc" "ml_gtk_packer_set_defaults"
 170
 171   let build_options ?(expand=false) ?(fill=`BOTH) () =
 172     (if expand then [`PACK_EXPAND] else []) @
 173     (match (fill : expand_type) with `NONE -> []
 174     | `X -> [`FILL_X]
 175     | `Y -> [`FILL_Y]
 176     | `BOTH -> [`FILL_X;`FILL_Y])
 177 end
 178
 179 module Paned = struct
 180   let cast w : paned obj = Object.try_cast w "GtkPaned"
 181   external add1 : [>`paned] obj -> [>`widget] obj -> unit
 182       = "ml_gtk_paned_add1"
 183   external add2 : [>`paned] obj -> [>`widget] obj -> unit
 184       = "ml_gtk_paned_add2"
 185   external set_handle_size : [>`paned] obj -> int -> unit
 186       = "ml_gtk_paned_set_handle_size"
 187   external set_gutter_size : [>`paned] obj -> int -> unit
 188       = "ml_gtk_paned_set_gutter_size"
 189   let set ?handle_size ?gutter_size w =
 190     may ~f:(set_handle_size w) handle_size;
 191     may ~f:(set_gutter_size w) gutter_size
 192   external child1 : [>`paned] obj -> widget obj = "ml_gtk_paned_child1"
 193   external child2 : [>`paned] obj -> widget obj = "ml_gtk_paned_child2"
 194   external handle_size : [>`paned] obj -> int = "ml_gtk_paned_handle_size"
 195   external gutter_size : [>`paned] obj -> int = "ml_gtk_paned_handle_size"
 196   external hpaned_new : unit -> paned obj = "ml_gtk_hpaned_new"
 197   external vpaned_new : unit -> paned obj = "ml_gtk_vpaned_new"
 198   let create (dir : orientation) =
 199     if dir = `HORIZONTAL then hpaned_new () else vpaned_new ()
 200 end
 201
 202 module Table = struct
 203   let cast w : table obj = Object.try_cast w "GtkTable"
 204   external create : int -> int -> homogeneous:bool -> table obj
 205       = "ml_gtk_table_new"
 206   let create ~rows:r ~columns:c ?(homogeneous=false) () =
 207     create r c ~homogeneous
 208   external attach :
 209       [>`table] obj -> [>`widget] obj -> left:int -> right:int ->
 210       top:int -> bottom:int -> xoptions:attach_options list ->
 211       yoptions:attach_options list -> xpadding:int -> ypadding:int -> unit
 212       = "ml_gtk_table_attach_bc" "ml_gtk_table_attach"
 213   let has_x : expand_type -> bool =
 214     function `X|`BOTH -> true | `Y|`NONE -> false
 215   let has_y : expand_type -> bool =
 216     function `Y|`BOTH -> true | `X|`NONE -> false
 217   let attach t ~left ~top ?(right=left+1) ?(bottom=top+1)
 218       ?(expand=`NONE) ?(fill=`BOTH) ?(shrink=`NONE)
 219       ?(xpadding=0) ?(ypadding=0) w =
 220     let xoptions = if has_x shrink then [`SHRINK] else [] in
 221     let xoptions = if has_x fill then `FILL::xoptions else xoptions in
 222     let xoptions = if has_x expand then `EXPAND::xoptions else xoptions in
 223     let yoptions = if has_y shrink then [`SHRINK] else [] in
 224     let yoptions = if has_y fill then `FILL::yoptions else yoptions in
 225     let yoptions = if has_y expand then `EXPAND::yoptions else yoptions in
 226     attach t w ~left ~top ~right ~bottom ~xoptions ~yoptions
 227       ~xpadding ~ypadding
 228   external set_row_spacing : [>`table] obj -> int -> int -> unit
 229       = "ml_gtk_table_set_row_spacing"
 230   external set_col_spacing : [>`table] obj -> int -> int -> unit
 231       = "ml_gtk_table_set_col_spacing"
 232   external set_row_spacings : [>`table] obj -> int -> unit
 233       = "ml_gtk_table_set_row_spacings"
 234   external set_col_spacings : [>`table] obj -> int -> unit
 235       = "ml_gtk_table_set_col_spacings"
 236   external set_homogeneous : [>`table] obj -> bool -> unit
 237       = "ml_gtk_table_set_homogeneous"
 238   let set ?homogeneous ?row_spacings ?col_spacings w =
 239     may row_spacings ~f:(set_row_spacings w);
 240     may col_spacings ~f:(set_col_spacings w);
 241     may homogeneous ~f:(set_homogeneous w)
 242 end
 243
 244 module Notebook = struct
 245   let cast w : notebook obj = Object.try_cast w "GtkNotebook"
 246   external create : unit -> notebook obj = "ml_gtk_notebook_new"
 247   external insert_page :
 248       [>`notebook] obj -> [>`widget] obj -> tab_label:[>`widget] optobj ->
 249       menu_label:[>`widget] optobj -> pos:int -> unit
 250       = "ml_gtk_notebook_insert_page_menu"
 251       (* default is append to end *)
 252   external remove_page : [>`notebook] obj -> int -> unit
 253       = "ml_gtk_notebook_remove_page"
 254   external get_current_page : [>`notebook] obj -> int
 255       = "ml_gtk_notebook_get_current_page"
 256   external set_page : [>`notebook] obj -> int -> unit
 257       = "ml_gtk_notebook_set_page"
 258   external set_tab_pos : [>`notebook] obj -> position -> unit
 259       = "ml_gtk_notebook_set_tab_pos"
 260   external set_homogeneous_tabs : [>`notebook] obj -> bool -> unit
 261       = "ml_gtk_notebook_set_homogeneous_tabs"
 262   external set_show_tabs : [>`notebook] obj -> bool -> unit
 263       = "ml_gtk_notebook_set_show_tabs"
 264   external set_show_border : [>`notebook] obj -> bool -> unit
 265       = "ml_gtk_notebook_set_show_border"
 266   external set_scrollable : [>`notebook] obj -> bool -> unit
 267       = "ml_gtk_notebook_set_scrollable"
 268   external set_tab_border : [>`notebook] obj -> int -> unit
 269       = "ml_gtk_notebook_set_tab_border"
 270   external popup_enable : [>`notebook] obj -> unit
 271       = "ml_gtk_notebook_popup_enable"
 272   external popup_disable : [>`notebook] obj -> unit
 273       = "ml_gtk_notebook_popup_disable"
 274   external get_nth_page : [>`notebook] obj -> int -> widget obj
 275       = "ml_gtk_notebook_get_nth_page"
 276   external page_num : [>`notebook] obj -> [>`widget] obj -> int
 277       = "ml_gtk_notebook_page_num"
 278   external next_page : [>`notebook] obj -> unit
 279       = "ml_gtk_notebook_next_page"
 280   external prev_page : [>`notebook] obj -> unit
 281       = "ml_gtk_notebook_prev_page"
 282   external get_tab_label : [>`notebook] obj -> [>`widget] obj -> widget obj
 283       = "ml_gtk_notebook_get_tab_label"
 284   external set_tab_label :
 285       [>`notebook] obj -> [>`widget] obj -> [>`widget] obj -> unit
 286       = "ml_gtk_notebook_set_tab_label"
 287   external get_menu_label : [>`notebook] obj -> [>`widget] obj -> widget obj
 288       = "ml_gtk_notebook_get_menu_label"
 289   external set_menu_label :
 290       [>`notebook] obj -> [>`widget] obj -> [>`widget] obj -> unit
 291       = "ml_gtk_notebook_set_menu_label"
 292   external reorder_child : [>`notebook] obj -> [>`widget] obj -> int -> unit
 293       = "ml_gtk_notebook_reorder_child"
 294
 295   let set_popup w = function
 296       true -> popup_enable w
 297     | false -> popup_disable w
 298   let set ?page ?tab_pos ?show_tabs ?homogeneous_tabs
 299       ?show_border ?scrollable ?tab_border ?popup w =
 300     let may_set f = may ~f:(f w) in
 301     may_set set_page page;
 302     may_set set_tab_pos tab_pos;
 303     may_set set_show_tabs show_tabs;
 304     may_set set_homogeneous_tabs homogeneous_tabs;
 305     may_set set_show_border show_border;
 306     may_set set_scrollable scrollable;
 307     may_set set_tab_border tab_border;
 308     may_set set_popup popup
 309   module Signals = struct
 310     open GtkArgv
 311     open GtkSignal
 312     let marshal_page f argv = function
 313       | _ :: INT page :: _ -> f page
 314       | _ -> invalid_arg "GtkPack.Notebook.Signals.marshal_page"
 315     let switch_page : ([>`notebook],_) t =
 316       { name = "switch_page"; marshaller = marshal_page }
 317   end
 318 end