+++ /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