--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+
+module Type = struct
+ external name : gtk_type -> string = "ml_gtk_type_name"
+ external from_name : string -> gtk_type = "ml_gtk_type_from_name"
+ external parent : gtk_type -> gtk_type = "ml_gtk_type_parent"
+ external get_class : gtk_type -> gtk_class = "ml_gtk_type_class"
+ external parent_class : gtk_type -> gtk_class = "ml_gtk_type_parent_class"
+ external is_a : gtk_type -> gtk_type -> bool = "ml_gtk_type_is_a"
+ external fundamental : gtk_type -> fundamental_type
+ = "ml_gtk_type_fundamental"
+end
+
+module Object = struct
+ external get_type : 'a obj -> gtk_type = "ml_gtk_object_type"
+ let is_a obj name =
+ Type.is_a (get_type obj) (Type.from_name name)
+ external destroy : 'a obj -> unit = "ml_gtk_object_destroy"
+ external coerce : 'a obj -> unit obj = "%identity"
+ external unsafe_cast : 'a obj -> 'b obj = "%identity"
+ let try_cast w name =
+ if is_a w name then unsafe_cast w
+ else raise (Cannot_cast(Type.name(get_type w), name))
+ let get_id (obj : 'a obj) : int = (snd (Obj.magic obj) lor 0)
+ module Signals = struct
+ open GtkSignal
+ let destroy : (_,_) t =
+ { name = "destroy"; marshaller = marshal_unit }
+ end
+end
+
+module Widget = struct
+ let cast w : widget obj = Object.try_cast w "GtkWidget"
+ external coerce : [>`widget] obj -> widget obj = "%identity"
+ external unparent : [>`widget] obj -> unit = "ml_gtk_widget_unparent"
+ external show : [>`widget] obj -> unit = "ml_gtk_widget_show"
+ external show_now : [>`widget] obj -> unit = "ml_gtk_widget_show_now"
+ external show_all : [>`widget] obj -> unit = "ml_gtk_widget_show_all"
+ external hide : [>`widget] obj -> unit = "ml_gtk_widget_hide"
+ external hide_all : [>`widget] obj -> unit = "ml_gtk_widget_hide_all"
+ external map : [>`widget] obj -> unit = "ml_gtk_widget_map"
+ external unmap : [>`widget] obj -> unit = "ml_gtk_widget_unmap"
+ external realize : [>`widget] obj -> unit = "ml_gtk_widget_realize"
+ external unrealize : [>`widget] obj -> unit = "ml_gtk_widget_unrealize"
+ external queue_draw : [>`widget] obj -> unit = "ml_gtk_widget_queue_draw"
+ external queue_resize : [>`widget] obj -> unit = "ml_gtk_widget_queue_resize"
+ external draw : [>`widget] obj -> Gdk.Rectangle.t option -> unit
+ = "ml_gtk_widget_draw"
+ external draw_focus : [>`widget] obj -> unit
+ = "ml_gtk_widget_draw_focus"
+ external draw_default : [>`widget] obj -> unit
+ = "ml_gtk_widget_draw_default"
+ external event : [>`widget] obj -> 'a Gdk.event -> bool
+ = "ml_gtk_widget_event"
+ external activate : [>`widget] obj -> bool
+ = "ml_gtk_widget_activate"
+ external reparent : [>`widget] obj -> [>`widget] obj -> unit
+ = "ml_gtk_widget_reparent"
+ external popup : [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_widget_popup"
+ external intersect :
+ [>`widget] obj -> Gdk.Rectangle.t -> Gdk.Rectangle.t option
+ = "ml_gtk_widget_intersect"
+ external set_can_default : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_can_default"
+ external set_can_focus : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_can_focus"
+ external grab_focus : [>`widget] obj -> unit
+ = "ml_gtk_widget_grab_focus"
+ external grab_default : [>`widget] obj -> unit
+ = "ml_gtk_widget_grab_default"
+ external set_name : [>`widget] obj -> string -> unit
+ = "ml_gtk_widget_set_name"
+ external get_name : [>`widget] obj -> string
+ = "ml_gtk_widget_get_name"
+ external set_state : [>`widget] obj -> state_type -> unit
+ = "ml_gtk_widget_set_state"
+ external set_sensitive : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_sensitive"
+ external set_uposition : [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_widget_set_uposition"
+ external set_usize : [>`widget] obj -> width:int -> height:int -> unit
+ = "ml_gtk_widget_set_usize"
+ external add_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
+ = "ml_gtk_widget_add_events"
+ external set_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
+ = "ml_gtk_widget_set_events"
+ external set_extension_events :
+ [>`widget] obj -> Gdk.Tags.extension_events -> unit
+ = "ml_gtk_widget_set_extension_events"
+ external get_toplevel : [>`widget] obj -> widget obj
+ = "ml_gtk_widget_get_toplevel"
+ external get_ancestor : [>`widget] obj -> gtk_type -> widget obj
+ = "ml_gtk_widget_get_ancestor"
+ external get_colormap : [>`widget] obj -> Gdk.colormap
+ = "ml_gtk_widget_get_colormap"
+ external get_visual : [>`widget] obj -> Gdk.visual
+ = "ml_gtk_widget_get_visual"
+ external get_pointer : [>`widget] obj -> int * int
+ = "ml_gtk_widget_get_pointer"
+ external is_ancestor : [>`widget] obj -> [>`widget] obj -> bool
+ = "ml_gtk_widget_is_ancestor"
+ external set_style : [>`widget] obj -> style -> unit
+ = "ml_gtk_widget_set_style"
+ external set_rc_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_set_rc_style"
+ external ensure_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_ensure_style"
+ external get_style : [>`widget] obj -> style
+ = "ml_gtk_widget_get_style"
+ external restore_default_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_restore_default_style"
+ external add_accelerator :
+ ([>`widget] as 'a) obj -> sgn:('a,unit->unit) GtkSignal.t ->
+ accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list ->
+ ?flags:accel_flag list -> unit
+ = "ml_gtk_widget_add_accelerator_bc" "ml_gtk_widget_add_accelerator"
+ external remove_accelerator :
+ [>`widget] obj -> accel_group ->
+ key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> unit
+ = "ml_gtk_widget_remove_accelerator"
+ external lock_accelerators : [>`widget] obj -> unit
+ = "ml_gtk_widget_lock_accelerators"
+ external unlock_accelerators : [>`widget] obj -> unit
+ = "ml_gtk_widget_unlock_accelerators"
+ external accelerators_locked : [>`widget] obj -> bool
+ = "ml_gtk_widget_accelerators_locked"
+ external window : [>`widget] obj -> Gdk.window
+ = "ml_GtkWidget_window"
+ external visible : [>`widget] obj -> bool
+ = "ml_GTK_WIDGET_VISIBLE"
+ external has_focus : [>`widget] obj -> bool
+ = "ml_GTK_WIDGET_HAS_FOCUS"
+ external parent : [>`widget] obj -> widget obj
+ = "ml_gtk_widget_parent"
+ external set_app_paintable : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_app_paintable"
+ external allocation : [>`widget] obj -> rectangle
+ = "ml_gtk_widget_allocation"
+ external set_colormap : [>`widget] obj -> Gdk.colormap -> unit
+ = "ml_gtk_widget_set_colormap"
+ external set_visual : [>`widget] obj -> Gdk.visual -> unit
+ = "ml_gtk_widget_set_visual"
+ external set_default_colormap : Gdk.colormap -> unit
+ = "ml_gtk_widget_set_default_colormap"
+ external set_default_visual : Gdk.visual -> unit
+ = "ml_gtk_widget_set_default_visual"
+ external get_default_colormap : unit -> Gdk.colormap
+ = "ml_gtk_widget_get_default_colormap"
+ external get_default_visual : unit -> Gdk.visual
+ = "ml_gtk_widget_get_default_visual"
+ external push_colormap : Gdk.colormap -> unit
+ = "ml_gtk_widget_push_colormap"
+ external push_visual : Gdk.visual -> unit
+ = "ml_gtk_widget_push_visual"
+ external pop_colormap : unit -> unit
+ = "ml_gtk_widget_pop_colormap"
+ external pop_visual : unit -> unit
+ = "ml_gtk_widget_pop_visual"
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let marshal f _ = function
+ | OBJECT(Some p) :: _ -> f (cast p)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal"
+ let marshal_opt f _ = function
+ | OBJECT(Some obj) :: _ -> f (Some (cast obj))
+ | OBJECT None :: _ -> f None
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
+ let marshal_style f _ = function
+ | POINTER p :: _ -> f (Obj.magic p : Gtk.style option)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
+ let marshal_drag1 f _ = function
+ | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.drag_context)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag1"
+ let marshal_drag2 f _ = function
+ | POINTER(Some p) :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context) ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag2"
+ let marshal_drag3 f argv = function
+ | POINTER(Some p) :: INT x :: INT y :: INT time :: _ ->
+ let res = f (Obj.magic p : Gdk.drag_context) ~x ~y ~time
+ in GtkArgv.set_result argv (`BOOL res)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag3"
+ let show : ([>`widget],_) t =
+ { name = "show"; marshaller = marshal_unit }
+ let hide : ([>`widget],_) t =
+ { name = "hide"; marshaller = marshal_unit }
+ let map : ([>`widget],_) t =
+ { name = "map"; marshaller = marshal_unit }
+ let unmap : ([>`widget],_) t =
+ { name = "unmap"; marshaller = marshal_unit }
+ let realize : ([>`widget],_) t =
+ { name = "realize"; marshaller = marshal_unit }
+ let draw : ([>`widget],_) t =
+ let marshal f _ = function
+ | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.Rectangle.t)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_draw"
+ in { name = "draw"; marshaller = marshal }
+ let draw_focus : ([>`widget],_) t =
+ { name = "draw_focus"; marshaller = marshal_unit }
+ let draw_default : ([>`widget],_) t =
+ { name = "draw_default"; marshaller = marshal_unit }
+ external val_state : int -> state_type = "ml_Val_state_type"
+ let state_changed : ([>`widget],_) t =
+ let marshal f = marshal_int (fun x -> f (val_state x)) in
+ { name = "state_changed"; marshaller = marshal }
+ let parent_set : ([>`widget],_) t =
+ { name = "parent_set"; marshaller = marshal_opt }
+ let style_set : ([>`widget],_) t =
+ { name = "style_set"; marshaller = marshal_style }
+ let drag_begin : ([>`widget],_) t =
+ { name = "drag_begin"; marshaller = marshal_drag1 }
+ let drag_end : ([>`widget],_) t =
+ { name = "drag_end"; marshaller = marshal_drag1 }
+ let drag_data_delete : ([>`widget],_) t =
+ { name = "drag_data_delete"; marshaller = marshal_drag1 }
+ let drag_leave : ([>`widget],_) t =
+ { name = "drag_leave"; marshaller = marshal_drag2 }
+ let drag_motion : ([>`widget],_) t =
+ { name = "drag_motion"; marshaller = marshal_drag3 }
+ let drag_drop : ([>`widget],_) t =
+ { name = "drag_drop"; marshaller = marshal_drag3 }
+ let drag_data_get : ([>`widget],_) t =
+ let marshal f argv = function
+ | POINTER(Some p) :: POINTER(Some q) :: INT info :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context)
+ (Obj.magic q : GtkData.Selection.t)
+ ~info
+ ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_get"
+ in
+ { name = "drag_data_get"; marshaller = marshal }
+ let drag_data_received : ([>`widget],_) t =
+ let marshal f _ = function
+ | POINTER(Some p) :: INT x :: INT y :: POINTER(Some q) ::
+ INT info :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context) ~x ~y
+ (Obj.magic q : GtkData.Selection.t)
+ ~info ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_received"
+ in
+ { name = "drag_data_received"; marshaller = marshal }
+
+ module Event = struct
+ let marshal f argv = function
+ | [POINTER(Some p)] ->
+ let ev = GdkEvent.unsafe_copy p in
+ GtkArgv.set_result argv (`BOOL(f ev))
+ | _ -> invalid_arg "GtkBase.Widget.Event.marshal"
+ let any : ([>`widget], Gdk.Tags.event_type Gdk.event -> bool) t =
+ { name = "event"; marshaller = marshal }
+ let button_press : ([>`widget], GdkEvent.Button.t -> bool) t =
+ { name = "button_press_event"; marshaller = marshal }
+ let button_release : ([>`widget], GdkEvent.Button.t -> bool) t =
+ { name = "button_release_event"; marshaller = marshal }
+ let motion_notify : ([>`widget], GdkEvent.Motion.t -> bool) t =
+ { name = "motion_notify_event"; marshaller = marshal }
+ let delete : ([>`widget], [`DELETE] Gdk.event -> bool) t =
+ { name = "delete_event"; marshaller = marshal }
+ let destroy : ([>`widget], [`DESTROY] Gdk.event -> bool) t =
+ { name = "destroy_event"; marshaller = marshal }
+ let expose : ([>`widget], GdkEvent.Expose.t -> bool) t =
+ { name = "expose_event"; marshaller = marshal }
+ let key_press : ([>`widget], GdkEvent.Key.t -> bool) t =
+ { name = "key_press_event"; marshaller = marshal }
+ let key_release : ([>`widget], GdkEvent.Key.t -> bool) t =
+ { name = "key_release_event"; marshaller = marshal }
+ let enter_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
+ { name = "enter_notify_event"; marshaller = marshal }
+ let leave_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
+ { name = "leave_notify_event"; marshaller = marshal }
+ let configure : ([>`widget], GdkEvent.Configure.t -> bool) t =
+ { name = "configure_event"; marshaller = marshal }
+ let focus_in : ([>`widget], GdkEvent.Focus.t -> bool) t =
+ { name = "focus_in_event"; marshaller = marshal }
+ let focus_out : ([>`widget], GdkEvent.Focus.t -> bool) t =
+ { name = "focus_out_event"; marshaller = marshal }
+ let map : ([>`widget], [`MAP] Gdk.event -> bool) t =
+ { name = "map_event"; marshaller = marshal }
+ let unmap : ([>`widget], [`UNMAP] Gdk.event -> bool) t =
+ { name = "unmap_event"; marshaller = marshal }
+ let property_notify : ([>`widget], GdkEvent.Property.t -> bool) t =
+ { name = "property_notify_event"; marshaller = marshal }
+ let selection_clear : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_clear_event"; marshaller = marshal }
+ let selection_request : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_request_event"; marshaller = marshal }
+ let selection_notify : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_notify_event"; marshaller = marshal }
+ let proximity_in : ([>`widget], GdkEvent.Proximity.t -> bool) t =
+ { name = "proximity_in_event"; marshaller = marshal }
+ let proximity_out : ([>`widget], GdkEvent.Proximity.t -> bool) t =
+ { name = "proximity_out_event"; marshaller = marshal }
+ end
+ end
+end
+
+module Container = struct
+ let cast w : container obj = Object.try_cast w "GtkContainer"
+ external coerce : [>`container] obj -> container obj = "%identity"
+ external set_border_width : [>`container] obj -> int -> unit
+ = "ml_gtk_container_set_border_width"
+ external set_resize_mode : [>`container] obj -> resize_mode -> unit
+ = "ml_gtk_container_set_resize_mode"
+ external add : [>`container] obj -> [>`widget] obj -> unit
+ = "ml_gtk_container_add"
+ external remove : [>`container] obj -> [>`widget] obj -> unit
+ = "ml_gtk_container_remove"
+ let set ?border_width ?(width = -2) ?(height = -2) w =
+ may border_width ~f:(set_border_width w);
+ if width <> -2 || height <> -2 then
+ Widget.set_usize w ?width ?height
+ external foreach : [>`container] obj -> f:(widget obj-> unit) -> unit
+ = "ml_gtk_container_foreach"
+ let children w =
+ let l = ref [] in
+ foreach w ~f:(fun c -> l := c :: !l);
+ List.rev !l
+ external focus : [>`container] obj -> direction_type -> bool
+ = "ml_gtk_container_focus"
+ (* Called by Widget.grab_focus *)
+ external set_focus_child : [>`container] obj -> [>`widget] optobj -> unit
+ = "ml_gtk_container_set_focus_child"
+ external set_focus_vadjustment :
+ [>`container] obj -> [>`adjustment] optobj -> unit
+ = "ml_gtk_container_set_focus_vadjustment"
+ external set_focus_hadjustment :
+ [>`container] obj -> [>`adjustment] optobj -> unit
+ = "ml_gtk_container_set_focus_hadjustment"
+ module Signals = struct
+ open GtkSignal
+ let add : ([>`container],_) t =
+ { name = "add"; marshaller = Widget.Signals.marshal }
+ let remove : ([>`container],_) t =
+ { name = "remove"; marshaller = Widget.Signals.marshal }
+ let need_resize : ([>`container],_) t =
+ let marshal f argv _ = GtkArgv.set_result argv (`BOOL(f ())) in
+ { name = "need_resize"; marshaller = marshal }
+ external val_direction : int -> direction_type = "ml_Val_direction_type"
+ let focus : ([>`container],_) t =
+ let marshal f argv = function
+ | GtkArgv.INT dir :: _ ->
+ GtkArgv.set_result argv (`BOOL(f (val_direction dir)))
+ | _ -> invalid_arg "GtkBase.Container.Signals.marshal_focus"
+ in { name = "focus"; marshaller = marshal }
+ end
+end
+
+module Item = struct
+ let cast w : item obj = Object.try_cast w "GtkItem"
+ external coerce : [>`item] obj -> item obj = "%identity"
+ external select : [>`item] obj -> unit = "ml_gtk_item_select"
+ external deselect : [>`item] obj -> unit = "ml_gtk_item_deselect"
+ external toggle : [>`item] obj -> unit = "ml_gtk_item_toggle"
+ module Signals = struct
+ open GtkSignal
+ let select : ([>`item],_) t =
+ { name = "select"; marshaller = marshal_unit }
+ let deselect : ([>`item],_) t =
+ { name = "deselect"; marshaller = marshal_unit }
+ let toggle : ([>`item],_) t =
+ { name = "toggle"; marshaller = marshal_unit }
+ end
+end
+
+
+module DnD = struct
+ external dest_set :
+ [>`widget] obj -> flags:dest_defaults list ->
+ targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
+ = "ml_gtk_drag_dest_set"
+ external dest_unset : [>`widget] obj -> unit
+ = "ml_gtk_drag_dest_unset"
+ external finish :
+ Gdk.drag_context -> success:bool -> del:bool -> time:int -> unit
+ = "ml_gtk_drag_finish"
+ external get_data :
+ [>`widget] obj -> Gdk.drag_context -> target:Gdk.atom -> time:int -> unit
+ = "ml_gtk_drag_get_data"
+ external get_source_widget : Gdk.drag_context -> widget obj
+ = "ml_gtk_drag_get_source_widget"
+ external highlight : [>`widget] obj -> unit = "ml_gtk_drag_highlight"
+ external unhighlight : [>`widget] obj -> unit = "ml_gtk_drag_unhighlight"
+ external set_icon_widget :
+ Gdk.drag_context -> [>`widget] obj -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_icon_widget"
+ external set_icon_pixmap :
+ Gdk.drag_context -> colormap:Gdk.colormap ->
+ Gdk.pixmap -> ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_icon_pixmap_bc" "ml_gtk_drag_set_icon_pixmap"
+ external set_icon_default : Gdk.drag_context -> unit
+ = "ml_gtk_drag_set_icon_default"
+ external set_default_icon :
+ colormap:Gdk.colormap -> Gdk.pixmap ->
+ ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_default_icon"
+ external source_set :
+ [>`widget] obj -> ?modi:Gdk.Tags.modifier list ->
+ targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
+ = "ml_gtk_drag_source_set"
+ external source_set_icon :
+ [>`widget] obj -> colormap:Gdk.colormap ->
+ Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
+ = "ml_gtk_drag_source_set_icon"
+ external source_unset : [>`widget] obj -> unit
+ = "ml_gtk_drag_source_unset"
+(* external dest_handle_event : [>`widget] -> *)
+end
+
projects / helm.git / blobdiff