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

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6
   7 module Type = struct
   8   external name : gtk_type -> string = "ml_gtk_type_name"
   9   external from_name : string -> gtk_type = "ml_gtk_type_from_name"
  10   external parent : gtk_type -> gtk_type = "ml_gtk_type_parent"
  11   external get_class : gtk_type -> gtk_class = "ml_gtk_type_class"
  12   external parent_class : gtk_type -> gtk_class = "ml_gtk_type_parent_class"
  13   external is_a : gtk_type -> gtk_type -> bool = "ml_gtk_type_is_a"
  14   external fundamental : gtk_type -> fundamental_type
  15       = "ml_gtk_type_fundamental"
  16 end
  17
  18 module Object = struct
  19   external get_type : 'a obj -> gtk_type = "ml_gtk_object_type"
  20   let is_a obj name =
  21     Type.is_a (get_type obj) (Type.from_name name)
  22   external destroy : 'a obj -> unit = "ml_gtk_object_destroy"
  23   external coerce : 'a obj -> unit obj = "%identity"
  24   external unsafe_cast : 'a obj -> 'b obj = "%identity"
  25   let try_cast w name =
  26     if is_a w name then unsafe_cast w
  27     else raise (Cannot_cast(Type.name(get_type w), name))
  28   let get_id (obj : 'a obj) : int = (snd (Obj.magic obj) lor 0)
  29   module Signals = struct
  30     open GtkSignal
  31     let destroy : (_,_) t =
  32       { name = "destroy"; marshaller = marshal_unit }
  33   end
  34 end
  35
  36 module Widget = struct
  37   let cast w : widget obj = Object.try_cast w "GtkWidget"
  38   external coerce : [>`widget] obj -> widget obj = "%identity"
  39   external unparent : [>`widget] obj -> unit = "ml_gtk_widget_unparent"
  40   external show : [>`widget] obj -> unit = "ml_gtk_widget_show"
  41   external show_now : [>`widget] obj -> unit = "ml_gtk_widget_show_now"
  42   external show_all : [>`widget] obj -> unit = "ml_gtk_widget_show_all"
  43   external hide : [>`widget] obj -> unit = "ml_gtk_widget_hide"
  44   external hide_all : [>`widget] obj -> unit = "ml_gtk_widget_hide_all"
  45   external map : [>`widget] obj -> unit = "ml_gtk_widget_map"
  46   external unmap : [>`widget] obj -> unit = "ml_gtk_widget_unmap"
  47   external realize : [>`widget] obj -> unit = "ml_gtk_widget_realize"
  48   external unrealize : [>`widget] obj -> unit = "ml_gtk_widget_unrealize"
  49   external queue_draw : [>`widget] obj -> unit = "ml_gtk_widget_queue_draw"
  50   external queue_resize : [>`widget] obj -> unit = "ml_gtk_widget_queue_resize"
  51   external draw : [>`widget] obj -> Gdk.Rectangle.t option -> unit
  52       = "ml_gtk_widget_draw"
  53   external draw_focus : [>`widget] obj -> unit
  54       = "ml_gtk_widget_draw_focus"
  55   external draw_default : [>`widget] obj -> unit
  56       = "ml_gtk_widget_draw_default"
  57   external event : [>`widget] obj -> 'a Gdk.event -> bool
  58       = "ml_gtk_widget_event"
  59   external activate : [>`widget] obj -> bool
  60       = "ml_gtk_widget_activate"
  61   external reparent : [>`widget] obj -> [>`widget] obj -> unit
  62       = "ml_gtk_widget_reparent"
  63   external popup : [>`widget] obj -> x:int -> y:int -> unit
  64       = "ml_gtk_widget_popup"
  65   external intersect :
  66       [>`widget] obj -> Gdk.Rectangle.t -> Gdk.Rectangle.t option
  67       = "ml_gtk_widget_intersect"
  68   external set_can_default : [>`widget] obj -> bool -> unit
  69       = "ml_gtk_widget_set_can_default"
  70   external set_can_focus : [>`widget] obj -> bool -> unit
  71       = "ml_gtk_widget_set_can_focus"
  72   external grab_focus : [>`widget] obj -> unit
  73       = "ml_gtk_widget_grab_focus"
  74   external grab_default : [>`widget] obj -> unit
  75       = "ml_gtk_widget_grab_default"
  76   external set_name : [>`widget] obj -> string -> unit
  77       = "ml_gtk_widget_set_name"
  78   external get_name : [>`widget] obj -> string
  79       = "ml_gtk_widget_get_name"
  80   external set_state : [>`widget] obj -> state_type -> unit
  81       = "ml_gtk_widget_set_state"
  82   external set_sensitive : [>`widget] obj -> bool -> unit
  83       = "ml_gtk_widget_set_sensitive"
  84   external set_uposition : [>`widget] obj -> x:int -> y:int -> unit
  85       = "ml_gtk_widget_set_uposition"
  86   external set_usize : [>`widget] obj -> width:int -> height:int -> unit
  87       = "ml_gtk_widget_set_usize"
  88   external add_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
  89       = "ml_gtk_widget_add_events"
  90   external set_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
  91       = "ml_gtk_widget_set_events"
  92   external set_extension_events :
  93       [>`widget] obj -> Gdk.Tags.extension_events -> unit
  94       = "ml_gtk_widget_set_extension_events"
  95   external get_toplevel : [>`widget] obj -> widget obj
  96       = "ml_gtk_widget_get_toplevel"
  97   external get_ancestor : [>`widget] obj -> gtk_type -> widget obj
  98       = "ml_gtk_widget_get_ancestor"
  99   external get_colormap : [>`widget] obj -> Gdk.colormap
 100       = "ml_gtk_widget_get_colormap"
 101   external get_visual : [>`widget] obj -> Gdk.visual
 102       = "ml_gtk_widget_get_visual"
 103   external get_pointer : [>`widget] obj -> int * int
 104       = "ml_gtk_widget_get_pointer"
 105   external is_ancestor : [>`widget] obj -> [>`widget] obj -> bool
 106       = "ml_gtk_widget_is_ancestor"
 107   external set_style : [>`widget] obj -> style -> unit
 108       = "ml_gtk_widget_set_style"
 109   external set_rc_style : [>`widget] obj -> unit
 110       = "ml_gtk_widget_set_rc_style"
 111   external ensure_style : [>`widget] obj -> unit
 112       = "ml_gtk_widget_ensure_style"
 113   external get_style : [>`widget] obj -> style
 114       = "ml_gtk_widget_get_style"
 115   external restore_default_style : [>`widget] obj -> unit
 116       = "ml_gtk_widget_restore_default_style"
 117   external add_accelerator :
 118       ([>`widget] as 'a) obj -> sgn:('a,unit->unit) GtkSignal.t ->
 119       accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list ->
 120       ?flags:accel_flag list -> unit
 121       = "ml_gtk_widget_add_accelerator_bc" "ml_gtk_widget_add_accelerator"
 122   external remove_accelerator :
 123       [>`widget] obj -> accel_group ->
 124       key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> unit
 125       = "ml_gtk_widget_remove_accelerator"
 126   external lock_accelerators : [>`widget] obj -> unit
 127       = "ml_gtk_widget_lock_accelerators"
 128   external unlock_accelerators : [>`widget] obj -> unit
 129       = "ml_gtk_widget_unlock_accelerators"
 130   external accelerators_locked : [>`widget] obj -> bool
 131       = "ml_gtk_widget_accelerators_locked"
 132   external window : [>`widget] obj -> Gdk.window
 133       = "ml_GtkWidget_window"
 134   external visible : [>`widget] obj -> bool
 135       = "ml_GTK_WIDGET_VISIBLE"
 136   external has_focus : [>`widget] obj -> bool
 137       = "ml_GTK_WIDGET_HAS_FOCUS"
 138   external parent : [>`widget] obj -> widget obj
 139       = "ml_gtk_widget_parent"
 140   external set_app_paintable : [>`widget] obj -> bool -> unit
 141       = "ml_gtk_widget_set_app_paintable"
 142   external allocation : [>`widget] obj -> rectangle
 143       = "ml_gtk_widget_allocation"
 144   external set_colormap : [>`widget] obj -> Gdk.colormap -> unit
 145       = "ml_gtk_widget_set_colormap"
 146   external set_visual : [>`widget] obj -> Gdk.visual -> unit
 147       = "ml_gtk_widget_set_visual"
 148   external set_default_colormap : Gdk.colormap -> unit
 149       = "ml_gtk_widget_set_default_colormap"
 150   external set_default_visual : Gdk.visual -> unit
 151       = "ml_gtk_widget_set_default_visual"
 152   external get_default_colormap : unit -> Gdk.colormap
 153       = "ml_gtk_widget_get_default_colormap"
 154   external get_default_visual : unit -> Gdk.visual
 155       = "ml_gtk_widget_get_default_visual"
 156   external push_colormap : Gdk.colormap -> unit
 157       = "ml_gtk_widget_push_colormap"
 158   external push_visual : Gdk.visual -> unit
 159       = "ml_gtk_widget_push_visual"
 160   external pop_colormap : unit -> unit
 161       = "ml_gtk_widget_pop_colormap"
 162   external pop_visual : unit -> unit
 163       = "ml_gtk_widget_pop_visual"
 164   module Signals = struct
 165     open GtkArgv
 166     open GtkSignal
 167     let marshal f _ = function
 168       | OBJECT(Some p) :: _ -> f (cast p)
 169       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal"
 170     let marshal_opt f _ = function
 171       | OBJECT(Some obj) :: _ -> f (Some (cast obj))
 172       | OBJECT None :: _ -> f None
 173       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
 174     let marshal_style f _ = function
 175       | POINTER p :: _ -> f (Obj.magic p : Gtk.style option)
 176       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
 177     let marshal_drag1 f _ = function
 178       | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.drag_context)
 179       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag1"
 180     let marshal_drag2 f _ = function
 181       | POINTER(Some p) :: INT time :: _ ->
 182           f (Obj.magic p : Gdk.drag_context) ~time
 183       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag2"
 184     let marshal_drag3 f argv = function
 185       | POINTER(Some p) :: INT x :: INT y :: INT time :: _ ->
 186           let res = f (Obj.magic p : Gdk.drag_context) ~x ~y ~time
 187           in GtkArgv.set_result argv (`BOOL res)
 188       | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag3"
 189     let show : ([>`widget],_) t =
 190       { name = "show"; marshaller = marshal_unit }
 191     let hide : ([>`widget],_) t =
 192       { name = "hide"; marshaller = marshal_unit }
 193     let map : ([>`widget],_) t =
 194       { name = "map"; marshaller = marshal_unit }
 195     let unmap : ([>`widget],_) t =
 196       { name = "unmap"; marshaller = marshal_unit }
 197     let realize : ([>`widget],_) t =
 198       { name = "realize"; marshaller = marshal_unit }
 199     let draw : ([>`widget],_) t =
 200       let marshal f _ = function
 201         | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.Rectangle.t)
 202         | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_draw"
 203       in { name = "draw"; marshaller = marshal }
 204     let draw_focus : ([>`widget],_) t =
 205       { name = "draw_focus"; marshaller = marshal_unit }
 206     let draw_default : ([>`widget],_) t =
 207       { name = "draw_default"; marshaller = marshal_unit }
 208     external val_state : int -> state_type = "ml_Val_state_type"
 209     let state_changed : ([>`widget],_) t =
 210       let marshal f = marshal_int (fun x -> f (val_state x)) in
 211       { name = "state_changed"; marshaller = marshal }
 212     let parent_set : ([>`widget],_) t =
 213       { name = "parent_set"; marshaller = marshal_opt }
 214     let style_set : ([>`widget],_) t =
 215       { name = "style_set"; marshaller = marshal_style }
 216     let drag_begin : ([>`widget],_) t =
 217       { name = "drag_begin"; marshaller = marshal_drag1 }
 218     let drag_end : ([>`widget],_) t =
 219       { name = "drag_end"; marshaller = marshal_drag1 }
 220     let drag_data_delete : ([>`widget],_) t =
 221       { name = "drag_data_delete"; marshaller = marshal_drag1 }
 222     let drag_leave : ([>`widget],_) t =
 223       { name = "drag_leave"; marshaller = marshal_drag2 }
 224     let drag_motion : ([>`widget],_) t =
 225       { name = "drag_motion"; marshaller = marshal_drag3 }
 226     let drag_drop : ([>`widget],_) t =
 227       { name = "drag_drop"; marshaller = marshal_drag3 }
 228     let drag_data_get : ([>`widget],_) t =
 229       let marshal f argv = function
 230         | POINTER(Some p) :: POINTER(Some q) :: INT info :: INT time :: _ ->
 231             f (Obj.magic p : Gdk.drag_context)
 232               (Obj.magic q : GtkData.Selection.t)
 233               ~info
 234               ~time
 235         | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_get"
 236       in
 237       { name = "drag_data_get"; marshaller = marshal }
 238     let drag_data_received : ([>`widget],_) t =
 239       let marshal f _ = function
 240         | POINTER(Some p) :: INT x :: INT y :: POINTER(Some q) ::
 241           INT info :: INT time :: _ ->
 242             f (Obj.magic p : Gdk.drag_context) ~x ~y
 243               (Obj.magic q : GtkData.Selection.t)
 244               ~info ~time
 245         | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_received"
 246       in
 247       { name = "drag_data_received"; marshaller = marshal }
 248
 249     module Event = struct
 250       let marshal f argv = function
 251         | [POINTER(Some p)] ->
 252             let ev = GdkEvent.unsafe_copy p in
 253             GtkArgv.set_result argv (`BOOL(f ev))
 254         | _ -> invalid_arg "GtkBase.Widget.Event.marshal"
 255       let any : ([>`widget], Gdk.Tags.event_type Gdk.event -> bool) t =
 256         { name = "event"; marshaller = marshal }
 257       let button_press : ([>`widget], GdkEvent.Button.t -> bool) t =
 258         { name = "button_press_event"; marshaller = marshal }
 259       let button_release : ([>`widget], GdkEvent.Button.t -> bool) t =
 260         { name = "button_release_event"; marshaller = marshal }
 261       let motion_notify : ([>`widget], GdkEvent.Motion.t -> bool) t =
 262         { name = "motion_notify_event"; marshaller = marshal }
 263       let delete : ([>`widget], [`DELETE] Gdk.event -> bool) t =
 264         { name = "delete_event"; marshaller = marshal }
 265       let destroy : ([>`widget], [`DESTROY] Gdk.event -> bool) t =
 266         { name = "destroy_event"; marshaller = marshal }
 267       let expose : ([>`widget], GdkEvent.Expose.t -> bool) t =
 268         { name = "expose_event"; marshaller = marshal }
 269       let key_press : ([>`widget], GdkEvent.Key.t -> bool) t =
 270         { name = "key_press_event"; marshaller = marshal }
 271       let key_release : ([>`widget], GdkEvent.Key.t -> bool) t =
 272         { name = "key_release_event"; marshaller = marshal }
 273       let enter_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
 274         { name = "enter_notify_event"; marshaller = marshal }
 275       let leave_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
 276         { name = "leave_notify_event"; marshaller = marshal }
 277       let configure : ([>`widget], GdkEvent.Configure.t -> bool) t =
 278         { name = "configure_event"; marshaller = marshal }
 279       let focus_in : ([>`widget], GdkEvent.Focus.t -> bool) t =
 280         { name = "focus_in_event"; marshaller = marshal }
 281       let focus_out : ([>`widget], GdkEvent.Focus.t -> bool) t =
 282         { name = "focus_out_event"; marshaller = marshal }
 283       let map : ([>`widget], [`MAP] Gdk.event -> bool) t =
 284         { name = "map_event"; marshaller = marshal }
 285       let unmap : ([>`widget], [`UNMAP] Gdk.event -> bool) t =
 286         { name = "unmap_event"; marshaller = marshal }
 287       let property_notify : ([>`widget], GdkEvent.Property.t -> bool) t =
 288         { name = "property_notify_event"; marshaller = marshal }
 289       let selection_clear : ([>`widget], GdkEvent.Selection.t -> bool) t =
 290         { name = "selection_clear_event"; marshaller = marshal }
 291       let selection_request : ([>`widget], GdkEvent.Selection.t -> bool) t =
 292         { name = "selection_request_event"; marshaller = marshal }
 293       let selection_notify : ([>`widget], GdkEvent.Selection.t -> bool) t =
 294         { name = "selection_notify_event"; marshaller = marshal }
 295       let proximity_in : ([>`widget], GdkEvent.Proximity.t -> bool) t =
 296         { name = "proximity_in_event"; marshaller = marshal }
 297       let proximity_out : ([>`widget], GdkEvent.Proximity.t -> bool) t =
 298         { name = "proximity_out_event"; marshaller = marshal }
 299     end
 300   end
 301 end
 302
 303 module Container = struct
 304   let cast w : container obj = Object.try_cast w "GtkContainer"
 305   external coerce : [>`container] obj -> container obj = "%identity"
 306   external set_border_width : [>`container] obj -> int -> unit
 307       = "ml_gtk_container_set_border_width"
 308   external set_resize_mode : [>`container] obj -> resize_mode -> unit
 309       = "ml_gtk_container_set_resize_mode"
 310   external add : [>`container] obj -> [>`widget] obj -> unit
 311       = "ml_gtk_container_add"
 312   external remove : [>`container] obj -> [>`widget] obj -> unit
 313       = "ml_gtk_container_remove"
 314   let set ?border_width ?(width = -2) ?(height = -2) w =
 315     may border_width ~f:(set_border_width w);
 316     if width <> -2 || height <> -2 then
 317       Widget.set_usize w ?width ?height
 318   external foreach : [>`container] obj -> f:(widget obj-> unit) -> unit
 319       = "ml_gtk_container_foreach"
 320   let children w =
 321     let l = ref [] in
 322     foreach w ~f:(fun c -> l := c :: !l);
 323     List.rev !l
 324   external focus : [>`container] obj -> direction_type -> bool
 325       = "ml_gtk_container_focus"
 326   (* Called by Widget.grab_focus *)
 327   external set_focus_child : [>`container] obj -> [>`widget] optobj -> unit
 328       = "ml_gtk_container_set_focus_child"
 329   external set_focus_vadjustment :
 330       [>`container] obj -> [>`adjustment] optobj -> unit
 331       = "ml_gtk_container_set_focus_vadjustment"
 332   external set_focus_hadjustment :
 333       [>`container] obj -> [>`adjustment] optobj -> unit
 334       = "ml_gtk_container_set_focus_hadjustment"
 335   module Signals = struct
 336     open GtkSignal
 337     let add : ([>`container],_) t =
 338       { name = "add"; marshaller = Widget.Signals.marshal }
 339     let remove : ([>`container],_) t =
 340       { name = "remove"; marshaller = Widget.Signals.marshal }
 341     let need_resize : ([>`container],_) t =
 342       let marshal f argv _ = GtkArgv.set_result argv (`BOOL(f ())) in
 343       { name = "need_resize"; marshaller = marshal }
 344     external val_direction : int -> direction_type = "ml_Val_direction_type"
 345     let focus : ([>`container],_) t =
 346       let marshal f argv = function
 347         | GtkArgv.INT dir :: _ ->
 348             GtkArgv.set_result argv (`BOOL(f (val_direction dir)))
 349         | _ -> invalid_arg "GtkBase.Container.Signals.marshal_focus"
 350       in { name = "focus"; marshaller = marshal }
 351   end
 352 end
 353
 354 module Item = struct
 355   let cast w : item obj = Object.try_cast w "GtkItem"
 356   external coerce : [>`item] obj -> item obj = "%identity"
 357   external select : [>`item] obj -> unit = "ml_gtk_item_select"
 358   external deselect : [>`item] obj -> unit = "ml_gtk_item_deselect"
 359   external toggle : [>`item] obj -> unit = "ml_gtk_item_toggle"
 360   module Signals = struct
 361     open GtkSignal
 362     let select : ([>`item],_) t =
 363       { name = "select"; marshaller = marshal_unit }
 364     let deselect : ([>`item],_) t =
 365       { name = "deselect"; marshaller = marshal_unit }
 366     let toggle : ([>`item],_) t =
 367       { name = "toggle"; marshaller = marshal_unit }
 368   end
 369 end
 370
 371
 372 module DnD = struct
 373   external dest_set :
 374       [>`widget] obj -> flags:dest_defaults list ->
 375       targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
 376     = "ml_gtk_drag_dest_set"
 377   external dest_unset : [>`widget] obj -> unit
 378       = "ml_gtk_drag_dest_unset"
 379   external finish :
 380       Gdk.drag_context -> success:bool -> del:bool -> time:int -> unit
 381       = "ml_gtk_drag_finish"
 382   external get_data :
 383       [>`widget] obj -> Gdk.drag_context -> target:Gdk.atom -> time:int -> unit
 384       = "ml_gtk_drag_get_data"
 385   external get_source_widget : Gdk.drag_context -> widget obj
 386       = "ml_gtk_drag_get_source_widget"
 387   external highlight : [>`widget] obj -> unit = "ml_gtk_drag_highlight"
 388   external unhighlight : [>`widget] obj -> unit = "ml_gtk_drag_unhighlight"
 389   external set_icon_widget :
 390       Gdk.drag_context -> [>`widget] obj -> hot_x:int -> hot_y:int -> unit
 391       = "ml_gtk_drag_set_icon_widget"
 392   external set_icon_pixmap :
 393       Gdk.drag_context -> colormap:Gdk.colormap ->
 394       Gdk.pixmap -> ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
 395       = "ml_gtk_drag_set_icon_pixmap_bc" "ml_gtk_drag_set_icon_pixmap"
 396   external set_icon_default : Gdk.drag_context -> unit
 397       = "ml_gtk_drag_set_icon_default"
 398   external set_default_icon :
 399       colormap:Gdk.colormap -> Gdk.pixmap ->
 400       ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
 401       = "ml_gtk_drag_set_default_icon"
 402   external source_set :
 403       [>`widget] obj -> ?modi:Gdk.Tags.modifier list ->
 404       targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
 405       = "ml_gtk_drag_source_set"
 406   external source_set_icon :
 407       [>`widget] obj -> colormap:Gdk.colormap ->
 408       Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
 409       = "ml_gtk_drag_source_set_icon"
 410   external source_unset : [>`widget] obj -> unit
 411       = "ml_gtk_drag_source_unset"
 412 (*  external dest_handle_event : [>`widget] -> *)
 413 end
 414