--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkData
+open GtkBase
+
+(* Object *)
+
+class gtkobj obj = object
+ val obj = obj
+ method destroy () = Object.destroy obj
+ method get_id = Object.get_id obj
+end
+
+class gtkobj_misc obj = object
+ val obj = obj
+ method get_type = Type.name (Object.get_type obj)
+ method disconnect = GtkSignal.disconnect obj
+ method handler_block = GtkSignal.handler_block obj
+ method handler_unblock = GtkSignal.handler_unblock obj
+end
+
+class gtkobj_signals ?(after=false) obj = object
+ val obj = obj
+ val after = after
+ method after = {< after = true >}
+ method destroy = GtkSignal.connect ~sgn:Object.Signals.destroy obj
+end
+
+(* Widget *)
+
+class event_signals ?(after=false) obj = object
+ val obj = Widget.coerce obj
+ val after = after
+ method after = {< after = true >}
+ method any = GtkSignal.connect ~sgn:Widget.Signals.Event.any ~after obj
+ method button_press =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.button_press ~after obj
+ method button_release =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.button_release ~after obj
+ method configure =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.configure ~after obj
+ method delete =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.delete ~after obj
+ method destroy =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.destroy ~after obj
+ method enter_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.enter_notify ~after obj
+ method expose =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.expose ~after obj
+ method focus_in =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.focus_in ~after obj
+ method focus_out =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.focus_out ~after obj
+ method key_press =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.key_press ~after obj
+ method key_release =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.key_release ~after obj
+ method leave_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.leave_notify ~after obj
+ method map = GtkSignal.connect ~sgn:Widget.Signals.Event.map ~after obj
+ method motion_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.motion_notify ~after obj
+ method property_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.property_notify ~after obj
+ method proximity_in =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_in ~after obj
+ method proximity_out =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_out ~after obj
+ method selection_clear =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_clear ~after obj
+ method selection_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_notify ~after obj
+ method selection_request =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_request ~after obj
+ method unmap = GtkSignal.connect ~sgn:Widget.Signals.Event.unmap ~after obj
+end
+
+class event_ops obj = object
+ val obj = Widget.coerce obj
+ method add = Widget.add_events obj
+ method connect = new event_signals obj
+ method send : Gdk.Tags.event_type Gdk.event -> bool = Widget.event obj
+ method set_extensions = Widget.set_extension_events obj
+end
+
+class style st = object
+ val style = st
+ method as_style = style
+ method copy = {< style = Style.copy style >}
+ method bg state = Style.get_bg style ~state
+ method colormap = Style.get_colormap style
+ method font = Style.get_font style
+ method set_bg =
+ List.iter ~f:
+ (fun (state,c) -> Style.set_bg style ~state ~color:(GDraw.color c))
+ method set_font = Style.set_font style
+ method set_background = Style.set_background style
+end
+
+class selection_data (sel : Selection.t) = object
+ val sel = sel
+ method selection = Selection.selection sel
+ method target = Selection.target sel
+ method seltype = Selection.seltype sel
+ method format = Selection.format sel
+ method data = Selection.get_data sel
+ method set = Selection.set sel
+end
+
+class drag_signals ?(after=false) obj = object
+ val obj = Widget.coerce obj
+ val after = after
+ method after = {< after = true >}
+ method beginning ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_begin ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method ending ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_end ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method data_delete ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_delete ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method leave ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_leave ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method motion ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_motion ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method drop ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_drop ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method data_get ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_get ~after obj
+ ~callback:(fun context data -> callback (new drag_context context)
+ (new selection_data data))
+ method data_received ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_received ~after obj
+ ~callback:(fun context ~x ~y data -> callback (new drag_context context)
+ ~x ~y (new selection_data data))
+
+end
+
+and drag_ops obj = object
+ val obj = Widget.coerce obj
+ method connect = new drag_signals obj
+ method dest_set ?(flags=[`ALL]) ?(actions=[]) targets =
+ DnD.dest_set obj ~flags ~actions ~targets:(Array.of_list targets)
+ method dest_unset () = DnD.dest_unset obj
+ method get_data ?(time=0) ~context:(context : drag_context) target =
+ DnD.get_data obj (context : < context : Gdk.drag_context; .. >)#context
+ ~target ~time
+ method highlight () = DnD.highlight obj
+ method unhighlight () = DnD.unhighlight obj
+ method source_set ?modi:m ?(actions=[]) targets =
+ DnD.source_set obj ?modi:m ~actions ~targets:(Array.of_list targets)
+ method source_set_icon ?(colormap = Gdk.Color.get_system_colormap ())
+ (pix : GDraw.pixmap) =
+ DnD.source_set_icon obj ~colormap pix#pixmap ?mask:pix#mask
+ method source_unset () = DnD.source_unset obj
+end
+
+and drag_context context = object
+ inherit GDraw.drag_context context
+ method context = context
+ method finish = DnD.finish context
+ method source_widget =
+ new widget (Object.unsafe_cast (DnD.get_source_widget context))
+ method set_icon_widget (w : widget) =
+ DnD.set_icon_widget context (w#as_widget)
+ method set_icon_pixmap ?(colormap = Gdk.Color.get_system_colormap ())
+ (pix : GDraw.pixmap) =
+ DnD.set_icon_pixmap context ~colormap pix#pixmap ?mask:pix#mask
+end
+
+and misc_signals ?after obj = object
+ inherit gtkobj_signals ?after obj
+ method draw ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.draw ~after ~callback:
+ begin fun rect ->
+ callback
+ { x = Gdk.Rectangle.x rect ; y = Gdk.Rectangle.y rect;
+ width = Gdk.Rectangle.width rect;
+ height = Gdk.Rectangle.height rect }
+ end
+ method show = GtkSignal.connect ~sgn:Widget.Signals.show ~after obj
+ method hide = GtkSignal.connect ~sgn:Widget.Signals.hide ~after obj
+ method map = GtkSignal.connect ~sgn:Widget.Signals.map ~after obj
+ method unmap = GtkSignal.connect ~sgn:Widget.Signals.unmap ~after obj
+ method realize = GtkSignal.connect ~sgn:Widget.Signals.realize ~after obj
+ method state_changed =
+ GtkSignal.connect ~sgn:Widget.Signals.state_changed ~after obj
+ method parent_set ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.parent_set ~after ~callback:
+ begin function
+ None -> callback None
+ | Some w -> callback (Some (new widget (Object.unsafe_cast w)))
+ end
+ method style_set ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.style_set ~after ~callback:
+ (fun opt -> callback (may opt ~f:(new style)))
+end
+
+and misc_ops obj = object
+ inherit gtkobj_misc (Widget.coerce obj)
+ method connect = new misc_signals obj
+ method show () = Widget.show obj
+ method unparent () = Widget.unparent obj
+ method show_all () = Widget.show_all obj
+ method hide () = Widget.hide obj
+ method hide_all () = Widget.hide_all obj
+ method map () = Widget.map obj
+ method unmap () = Widget.unmap obj
+ method realize () = Widget.realize obj
+ method unrealize () = Widget.unrealize obj
+ method draw = Widget.draw obj
+ method activate () = Widget.activate obj
+ method reparent (w : widget) = Widget.reparent obj w#as_widget
+ method popup = Widget.popup obj
+ method intersect = Widget.intersect obj
+ method grab_focus () = Widget.grab_focus obj
+ method grab_default () = Widget.grab_default obj
+ method is_ancestor (w : widget) = Widget.is_ancestor obj w#as_widget
+ method add_accelerator ~sgn:sg ~group ?modi ?flags key =
+ Widget.add_accelerator obj ~sgn:sg group ~key ?modi ?flags
+ method remove_accelerator ~group ?modi key =
+ Widget.remove_accelerator obj group ~key ?modi
+ method lock_accelerators () = Widget.lock_accelerators obj
+ method set_name = Widget.set_name obj
+ method set_state = Widget.set_state obj
+ method set_sensitive = Widget.set_sensitive obj
+ method set_can_default = Widget.set_can_default obj
+ method set_can_focus = Widget.set_can_focus obj
+ method set_geometry ?(x = -2) ?(y = -2) ?(width = -2) ?(height = -2) () =
+ if x+y <> -4 then Widget.set_uposition obj ~x ~y;
+ if width+height <> -4 then Widget.set_usize obj ~width ~height
+ method set_style (style : style) = Widget.set_style obj style#as_style
+ (* get functions *)
+ method name = Widget.get_name obj
+ method toplevel =
+ try Some (new widget (Object.unsafe_cast (Widget.get_toplevel obj)))
+ with Gpointer.Null -> None
+ method window = Widget.window obj
+ method colormap = Widget.get_colormap obj
+ method visual = Widget.get_visual obj
+ method visual_depth = Gdk.Window.visual_depth (Widget.get_visual obj)
+ method pointer = Widget.get_pointer obj
+ method style = new style (Widget.get_style obj)
+ method visible = Widget.visible obj
+ method has_focus = Widget.has_focus obj
+ method parent =
+ try Some (new widget (Object.unsafe_cast (Widget.parent obj)))
+ with Gpointer.Null -> None
+ method set_app_paintable = Widget.set_app_paintable obj
+ method allocation = Widget.allocation obj
+end
+
+and widget obj = object (self)
+ inherit gtkobj obj
+ method as_widget = Widget.coerce obj
+ method misc = new misc_ops obj
+ method drag = new drag_ops (Object.unsafe_cast obj)
+ method coerce =
+ (self :> < destroy : _; get_id : _; as_widget : _; misc : _;
+ drag : _; coerce : _ >)
+end
+
+(* just to check that GDraw.misc_ops is compatible with misc_ops *)
+let _ = fun (x : #GDraw.misc_ops) -> (x : misc_ops)
+
+class widget_signals ?after (obj : [> `widget] obj) =
+ gtkobj_signals ?after obj
+
+(*
+class widget_coerce obj = object
+ inherit widget obj
+ method coerce = (self :> widget)
+end
+*)
+
+class widget_full obj = object
+ inherit widget obj
+ method connect = new widget_signals obj
+end
+
+let as_widget (w : widget) = w#as_widget
+
+let pack_return self ~packing ~show =
+ may packing ~f:(fun f -> (f (self :> widget) : unit));
+ if show <> Some false then self#misc#show ();
+ self
projects / helm.git / blobdiff