helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gObj.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open GtkData
   6 open GtkBase
   7
   8 (* Object *)
   9
  10 class gtkobj obj = object
  11   val obj = obj
  12   method destroy () = Object.destroy obj
  13   method get_id = Object.get_id obj
  14 end
  15
  16 class gtkobj_misc obj = object
  17   val obj = obj
  18   method get_type = Type.name (Object.get_type obj)
  19   method disconnect = GtkSignal.disconnect obj
  20   method handler_block = GtkSignal.handler_block obj
  21   method handler_unblock = GtkSignal.handler_unblock obj
  22 end
  23
  24 class gtkobj_signals ?(after=false) obj = object
  25   val obj = obj
  26   val after = after
  27   method after = {< after = true >}
  28   method destroy = GtkSignal.connect ~sgn:Object.Signals.destroy obj
  29 end
  30
  31 (* Widget *)
  32
  33 class event_signals ?(after=false) obj = object
  34   val obj = Widget.coerce obj
  35   val after = after
  36   method after = {< after = true >}
  37   method any = GtkSignal.connect ~sgn:Widget.Signals.Event.any ~after obj
  38   method button_press =
  39     GtkSignal.connect ~sgn:Widget.Signals.Event.button_press ~after obj
  40   method button_release =
  41     GtkSignal.connect ~sgn:Widget.Signals.Event.button_release ~after obj
  42   method configure =
  43     GtkSignal.connect ~sgn:Widget.Signals.Event.configure ~after obj
  44   method delete =
  45     GtkSignal.connect ~sgn:Widget.Signals.Event.delete ~after obj
  46   method destroy =
  47     GtkSignal.connect ~sgn:Widget.Signals.Event.destroy ~after obj
  48   method enter_notify =
  49     GtkSignal.connect ~sgn:Widget.Signals.Event.enter_notify ~after obj
  50   method expose =
  51     GtkSignal.connect ~sgn:Widget.Signals.Event.expose ~after obj
  52   method focus_in =
  53     GtkSignal.connect ~sgn:Widget.Signals.Event.focus_in ~after obj
  54   method focus_out =
  55     GtkSignal.connect ~sgn:Widget.Signals.Event.focus_out ~after obj
  56   method key_press =
  57     GtkSignal.connect ~sgn:Widget.Signals.Event.key_press ~after obj
  58   method key_release =
  59     GtkSignal.connect ~sgn:Widget.Signals.Event.key_release ~after obj
  60   method leave_notify =
  61     GtkSignal.connect ~sgn:Widget.Signals.Event.leave_notify ~after obj
  62   method map = GtkSignal.connect ~sgn:Widget.Signals.Event.map ~after obj
  63   method motion_notify =
  64     GtkSignal.connect ~sgn:Widget.Signals.Event.motion_notify ~after obj
  65   method property_notify =
  66     GtkSignal.connect ~sgn:Widget.Signals.Event.property_notify ~after obj
  67   method proximity_in =
  68     GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_in ~after obj
  69   method proximity_out =
  70     GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_out ~after obj
  71   method selection_clear =
  72     GtkSignal.connect ~sgn:Widget.Signals.Event.selection_clear ~after obj
  73   method selection_notify =
  74     GtkSignal.connect ~sgn:Widget.Signals.Event.selection_notify ~after obj
  75   method selection_request =
  76     GtkSignal.connect ~sgn:Widget.Signals.Event.selection_request ~after obj
  77   method unmap = GtkSignal.connect ~sgn:Widget.Signals.Event.unmap ~after obj
  78 end
  79
  80 class event_ops obj = object
  81   val obj = Widget.coerce obj
  82   method add = Widget.add_events obj
  83   method connect = new event_signals obj
  84   method send : Gdk.Tags.event_type Gdk.event -> bool = Widget.event obj
  85   method set_extensions = Widget.set_extension_events obj
  86 end
  87
  88 class style st = object
  89   val style = st
  90   method as_style = style
  91   method copy = {< style = Style.copy style >}
  92   method bg state = Style.get_bg style ~state
  93   method colormap = Style.get_colormap style
  94   method font = Style.get_font style
  95   method set_bg =
  96     List.iter ~f:
  97       (fun (state,c) -> Style.set_bg style ~state ~color:(GDraw.color c))
  98   method set_font = Style.set_font style
  99   method set_background = Style.set_background style
 100 end
 101
 102 class selection_data (sel : Selection.t) = object
 103   val sel = sel
 104   method selection = Selection.selection sel
 105   method target = Selection.target sel
 106   method seltype = Selection.seltype sel
 107   method format = Selection.format sel
 108   method data = Selection.get_data sel
 109   method set = Selection.set sel
 110 end
 111
 112 class drag_signals ?(after=false) obj = object
 113   val obj =  Widget.coerce obj
 114   val after = after
 115   method after = {< after = true >}
 116   method beginning ~callback =
 117     GtkSignal.connect ~sgn:Widget.Signals.drag_begin ~after obj
 118       ~callback:(fun context -> callback (new drag_context context))
 119   method ending ~callback =
 120     GtkSignal.connect ~sgn:Widget.Signals.drag_end ~after obj
 121       ~callback:(fun context -> callback (new drag_context context))
 122   method data_delete ~callback =
 123     GtkSignal.connect ~sgn:Widget.Signals.drag_data_delete ~after obj
 124       ~callback:(fun context -> callback (new drag_context context))
 125   method leave ~callback =
 126     GtkSignal.connect ~sgn:Widget.Signals.drag_leave ~after obj
 127       ~callback:(fun context -> callback (new drag_context context))
 128   method motion ~callback =
 129     GtkSignal.connect ~sgn:Widget.Signals.drag_motion ~after obj
 130       ~callback:(fun context -> callback (new drag_context context))
 131   method drop ~callback =
 132     GtkSignal.connect ~sgn:Widget.Signals.drag_drop ~after obj
 133       ~callback:(fun context -> callback (new drag_context context))
 134   method data_get ~callback =
 135     GtkSignal.connect ~sgn:Widget.Signals.drag_data_get ~after obj
 136       ~callback:(fun context data -> callback (new drag_context context)
 137                (new selection_data data))
 138   method data_received ~callback =
 139     GtkSignal.connect ~sgn:Widget.Signals.drag_data_received ~after obj
 140       ~callback:(fun context ~x ~y data -> callback (new drag_context context)
 141                ~x ~y (new selection_data data))
 142
 143 end
 144
 145 and drag_ops obj = object
 146   val obj = Widget.coerce obj
 147   method connect = new drag_signals obj
 148   method dest_set ?(flags=[`ALL]) ?(actions=[]) targets =
 149     DnD.dest_set obj ~flags ~actions ~targets:(Array.of_list targets)
 150   method dest_unset () = DnD.dest_unset obj
 151   method get_data ?(time=0) ~context:(context : drag_context) target =
 152     DnD.get_data obj (context : < context : Gdk.drag_context; .. >)#context
 153       ~target ~time
 154   method highlight () = DnD.highlight obj
 155   method unhighlight () = DnD.unhighlight obj
 156   method source_set ?modi:m ?(actions=[]) targets =
 157     DnD.source_set obj ?modi:m ~actions ~targets:(Array.of_list targets)
 158   method source_set_icon ?(colormap = Gdk.Color.get_system_colormap ())
 159       (pix : GDraw.pixmap) =
 160     DnD.source_set_icon obj ~colormap pix#pixmap ?mask:pix#mask
 161   method source_unset () = DnD.source_unset obj
 162 end
 163
 164 and drag_context context = object
 165   inherit GDraw.drag_context context
 166   method context = context
 167   method finish = DnD.finish context
 168   method source_widget =
 169     new widget (Object.unsafe_cast (DnD.get_source_widget context))
 170   method set_icon_widget (w : widget) =
 171     DnD.set_icon_widget context (w#as_widget)
 172   method set_icon_pixmap ?(colormap = Gdk.Color.get_system_colormap ())
 173       (pix : GDraw.pixmap) =
 174     DnD.set_icon_pixmap context ~colormap pix#pixmap ?mask:pix#mask
 175 end
 176
 177 and misc_signals ?after obj = object
 178   inherit gtkobj_signals ?after obj
 179   method draw ~callback =
 180     GtkSignal.connect obj ~sgn:Widget.Signals.draw ~after ~callback:
 181       begin fun rect ->
 182         callback
 183           { x = Gdk.Rectangle.x rect ; y = Gdk.Rectangle.y rect;
 184             width = Gdk.Rectangle.width rect;
 185             height = Gdk.Rectangle.height rect }
 186       end
 187   method show = GtkSignal.connect ~sgn:Widget.Signals.show ~after obj
 188   method hide = GtkSignal.connect ~sgn:Widget.Signals.hide ~after obj
 189   method map = GtkSignal.connect ~sgn:Widget.Signals.map ~after obj
 190   method unmap = GtkSignal.connect ~sgn:Widget.Signals.unmap ~after obj
 191   method realize = GtkSignal.connect ~sgn:Widget.Signals.realize ~after obj
 192   method state_changed =
 193     GtkSignal.connect ~sgn:Widget.Signals.state_changed ~after obj
 194   method parent_set ~callback =
 195     GtkSignal.connect obj ~sgn:Widget.Signals.parent_set ~after ~callback:
 196       begin function
 197           None   -> callback None
 198         | Some w -> callback (Some (new widget (Object.unsafe_cast w)))
 199       end
 200   method style_set ~callback =
 201     GtkSignal.connect obj ~sgn:Widget.Signals.style_set ~after ~callback:
 202       (fun opt -> callback (may opt ~f:(new style)))
 203 end
 204
 205 and misc_ops obj = object
 206   inherit gtkobj_misc (Widget.coerce obj)
 207   method connect = new misc_signals obj
 208   method show () = Widget.show obj
 209   method unparent () = Widget.unparent obj
 210   method show_all () = Widget.show_all obj
 211   method hide () = Widget.hide obj
 212   method hide_all () = Widget.hide_all obj
 213   method map () = Widget.map obj
 214   method unmap () = Widget.unmap obj
 215   method realize () = Widget.realize obj
 216   method unrealize () = Widget.unrealize obj
 217   method draw = Widget.draw obj
 218   method activate () = Widget.activate obj
 219   method reparent (w : widget) =  Widget.reparent obj w#as_widget
 220   method popup = Widget.popup obj
 221   method intersect = Widget.intersect obj
 222   method grab_focus () = Widget.grab_focus obj
 223   method grab_default () = Widget.grab_default obj
 224   method is_ancestor (w : widget) = Widget.is_ancestor obj w#as_widget
 225   method add_accelerator ~sgn:sg ~group ?modi ?flags key =
 226     Widget.add_accelerator obj ~sgn:sg group ~key ?modi ?flags
 227   method remove_accelerator ~group ?modi key =
 228     Widget.remove_accelerator obj group ~key ?modi
 229   method lock_accelerators () = Widget.lock_accelerators obj
 230   method set_name = Widget.set_name obj
 231   method set_state = Widget.set_state obj
 232   method set_sensitive = Widget.set_sensitive obj
 233   method set_can_default = Widget.set_can_default obj
 234   method set_can_focus = Widget.set_can_focus obj
 235   method set_geometry ?(x = -2) ?(y = -2) ?(width = -2) ?(height = -2)  () =
 236     if x+y <> -4 then Widget.set_uposition obj ~x ~y;
 237     if width+height <> -4 then Widget.set_usize obj ~width ~height
 238   method set_style (style : style) = Widget.set_style obj style#as_style
 239   (* get functions *)
 240   method name = Widget.get_name obj
 241   method toplevel =
 242     try Some (new widget (Object.unsafe_cast (Widget.get_toplevel obj)))
 243     with Gpointer.Null -> None
 244   method window = Widget.window obj
 245   method colormap = Widget.get_colormap obj
 246   method visual = Widget.get_visual obj
 247   method visual_depth = Gdk.Window.visual_depth (Widget.get_visual obj)
 248   method pointer = Widget.get_pointer obj
 249   method style = new style (Widget.get_style obj)
 250   method visible = Widget.visible obj
 251   method has_focus = Widget.has_focus obj
 252   method parent =
 253     try Some (new widget (Object.unsafe_cast (Widget.parent obj)))
 254     with Gpointer.Null -> None
 255   method set_app_paintable = Widget.set_app_paintable obj
 256   method allocation = Widget.allocation obj
 257 end
 258
 259 and widget obj = object (self)
 260   inherit gtkobj obj
 261   method as_widget = Widget.coerce obj
 262   method misc = new misc_ops obj
 263   method drag = new drag_ops (Object.unsafe_cast obj)
 264   method coerce =
 265     (self :> < destroy : _; get_id : _; as_widget : _; misc : _;
 266                drag : _; coerce : _ >)
 267 end
 268
 269 (* just to check that GDraw.misc_ops is compatible with misc_ops *)
 270 let _ = fun (x : #GDraw.misc_ops) -> (x : misc_ops)
 271
 272 class widget_signals ?after (obj : [> `widget] obj) =
 273   gtkobj_signals ?after obj
 274
 275 (*
 276 class widget_coerce obj = object
 277   inherit widget obj
 278   method coerce = (self :> widget)
 279 end
 280 *)
 281
 282 class widget_full obj = object
 283   inherit widget obj
 284   method connect = new widget_signals obj
 285 end
 286
 287 let as_widget (w : widget) = w#as_widget
 288
 289 let pack_return self ~packing ~show =
 290   may packing ~f:(fun f -> (f (self :> widget) : unit));
 291   if show <> Some false then self#misc#show ();
 292   self