]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gObj.ml
- DoubleTypeInference.does_not_occur exposed
[helm.git] / 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