]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMisc.ml
- DoubleTypeInference.does_not_occur exposed
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / gtkMisc.ml
1 (* $Id$ *)
2
3 open Gaux
4 open Gtk
5 open Tags
6 open GtkBase
7
8 module GammaCurve = struct
9   let cast w : gamma_curve obj = Object.try_cast w "GtkGammaCurve"
10   external create : unit -> gamma_curve obj = "ml_gtk_gamma_curve_new"
11   external get_gamma : [>`gamma] obj -> float = "ml_gtk_gamma_curve_get_gamma"
12 end
13
14 module ColorSelection = struct
15   let cast w : color_selection obj = Object.try_cast w "GtkColorSelection"
16   external create : unit -> color_selection obj = "ml_gtk_color_selection_new"
17   external create_dialog : string -> color_selection_dialog obj
18       = "ml_gtk_color_selection_dialog_new"
19   external set_update_policy : [>`colorsel] obj -> update_type -> unit
20       = "ml_gtk_color_selection_set_update_policy"
21   external set_opacity : [>`colorsel] obj -> bool -> unit
22       = "ml_gtk_color_selection_set_opacity"
23   let set ?update_policy ?opacity w =
24     may update_policy ~f:(set_update_policy w);
25     may opacity ~f:(set_opacity w)
26   external set_color :
27       [>`colorsel] obj ->
28       red:float -> green:float -> blue:float -> ?opacity:float -> unit
29       = "ml_gtk_color_selection_set_color"
30   external get_color : [>`colorsel] obj -> color
31       = "ml_gtk_color_selection_get_color"
32
33   external ok_button : [>`colorseldialog] obj -> button obj =
34     "ml_gtk_color_selection_dialog_ok_button"
35   external cancel_button : [>`colorseldialog] obj -> button obj =
36     "ml_gtk_color_selection_dialog_cancel_button"
37   external help_button : [>`colorseldialog] obj -> button obj =
38     "ml_gtk_color_selection_dialog_help_button"
39   external colorsel : [>`colorseldialog] obj -> color_selection obj =
40     "ml_gtk_color_selection_dialog_colorsel"
41   module Signals = struct
42     open GtkSignal
43     let color_changed : ([>`colorsel],_) t =
44       { name = "color_changed"; marshaller = marshal_unit }
45   end
46 end
47
48 module Statusbar = struct
49   let cast w : statusbar obj = Object.try_cast w "GtkStatusbar"
50   external create : unit -> statusbar obj = "ml_gtk_statusbar_new"
51   external get_context : [>`statusbar] obj -> string -> statusbar_context
52       = "ml_gtk_statusbar_get_context_id"
53   external push :
54       [>`statusbar] obj ->
55       statusbar_context -> text:string -> statusbar_message
56       = "ml_gtk_statusbar_push"
57   external pop : [>`statusbar] obj -> statusbar_context ->  unit
58       = "ml_gtk_statusbar_pop"
59   external remove :
60       [>`statusbar] obj -> statusbar_context -> statusbar_message -> unit
61       = "ml_gtk_statusbar_remove"
62   module Signals = struct
63     open GtkSignal
64     let text_pushed : ([>`statusbar],_) t =
65       let marshal f _ = function
66         | GtkArgv.INT ctx :: GtkArgv.STRING s :: _ ->
67             f (Obj.magic ctx : statusbar_context) s
68         | _ -> invalid_arg "GtkMisc.Statusbar.Signals.marshal_text"
69       in
70       { name = "text_pushed"; marshaller = marshal }
71   end
72 end
73
74 module Calendar = struct
75   let cast w : calendar obj = Object.try_cast w "GtkCalendar"
76   external create : unit -> calendar obj = "ml_gtk_calendar_new"
77   external select_month : [>`calendar] obj -> month:int -> year:int -> unit
78       = "ml_gtk_calendar_select_month"
79   external select_day : [>`calendar] obj -> int -> unit
80       = "ml_gtk_calendar_select_day"
81   external mark_day : [>`calendar] obj -> int -> unit
82       = "ml_gtk_calendar_mark_day"
83   external unmark_day : [>`calendar] obj -> int -> unit
84       = "ml_gtk_calendar_unmark_day"
85   external clear_marks : [>`calendar] obj -> unit
86       = "ml_gtk_calendar_clear_marks"
87   external display_options :
88       [>`calendar] obj -> Tags.calendar_display_options list -> unit
89       = "ml_gtk_calendar_display_options"
90   external get_date : [>`calendar] obj -> int * int * int
91       = "ml_gtk_calendar_get_date"   (* year * month * day *)
92   external freeze : [>`calendar] obj -> unit
93       = "ml_gtk_calendar_freeze"
94   external thaw : [>`calendar] obj -> unit
95       = "ml_gtk_calendar_thaw"
96   module Signals = struct
97     open GtkSignal
98     let month_changed : ([>`calendar],_) t =
99       { name = "month_changed"; marshaller = marshal_unit }
100     let day_selected : ([>`calendar],_) t =
101       { name = "day_selected"; marshaller = marshal_unit }
102     let day_selected_double_click : ([>`calendar],_) t =
103       { name = "day_selected_double_click"; marshaller = marshal_unit }
104     let prev_month : ([>`calendar],_) t =
105       { name = "prev_month"; marshaller = marshal_unit }
106     let next_month : ([>`calendar],_) t =
107       { name = "next_month"; marshaller = marshal_unit }
108     let prev_year : ([>`calendar],_) t =
109       { name = "prev_year"; marshaller = marshal_unit }
110     let next_year : ([>`calendar],_) t =
111       { name = "next_year"; marshaller = marshal_unit }
112   end
113 end
114
115 module DrawingArea = struct
116   let cast w : drawing_area obj = Object.try_cast w "GtkDrawingArea"
117   external create : unit -> drawing_area obj = "ml_gtk_drawing_area_new"
118   external size : [>`drawing] obj -> width:int -> height:int -> unit
119       = "ml_gtk_drawing_area_size"
120 end
121
122 (* Does not seem very useful ...
123 module Curve = struct
124   type t = [widget drawing curve] obj
125   let cast w : t = Object.try_cast w "GtkCurve"
126   external create : unit -> t = "ml_gtk_curve_new"
127   external reset : [>`curve] obj -> unit = "ml_gtk_curve_reset"
128   external set_gamma : [>`curve] obj -> float -> unit
129       = "ml_gtk_curve_set_gamma"
130   external set_range :
131       [>`curve] obj -> min_x:float -> max_x:float ->
132       min_y:float -> max_y:float -> unit
133       = "ml_gtk_curve_set_gamma"
134 end
135 *)
136
137 module Misc = struct
138   let cast w : misc obj = Object.try_cast w "GtkMisc"
139   external coerce : [>`misc] obj -> misc obj = "%identity"
140   external set_alignment : [>`misc] obj -> x:float -> y:float -> unit
141       = "ml_gtk_misc_set_alignment"
142   external set_padding : [>`misc] obj -> x:int -> y:int -> unit
143       = "ml_gtk_misc_set_padding"
144   external get_xalign : [>`misc] obj -> float = "ml_gtk_misc_get_xalign"
145   external get_yalign : [>`misc] obj -> float = "ml_gtk_misc_get_yalign"
146   external get_xpad : [>`misc] obj -> int = "ml_gtk_misc_get_xpad"
147   external get_ypad : [>`misc] obj -> int = "ml_gtk_misc_get_ypad"
148   let set_alignment w ?x ?y () =
149     set_alignment w ~x:(may_default get_xalign w ~opt:x)
150       ~y:(may_default get_yalign w ~opt:y)
151   let set_padding w ?x ?y () =
152     set_padding w ~x:(may_default get_xpad w ~opt:x)
153       ~y:(may_default get_ypad w ~opt:y)
154   let set ?xalign ?yalign ?xpad ?ypad ?(width = -2) ?(height = -2) w =
155     if xalign <> None || yalign <> None then
156       set_alignment w ?x:xalign ?y:yalign ();
157     if xpad <> None || ypad <> None then
158       set_padding w ?x:xpad ?y:ypad ();
159     if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
160 end
161
162 module Arrow = struct
163   let cast w : arrow obj = Object.try_cast w "GtkArrow"
164   external create : kind:arrow_type -> shadow:shadow_type -> arrow obj
165       = "ml_gtk_arrow_new"
166   external set : [>`arrow] obj -> kind:arrow_type -> shadow:shadow_type -> unit
167       = "ml_gtk_arrow_set"
168 end
169
170 module Image = struct
171   let cast w : image obj = Object.try_cast w "GtkImage"
172   external create : Gdk.image -> ?mask:Gdk.bitmap -> image obj
173       = "ml_gtk_image_new"
174   let create ?mask img = create img ?mask
175   external set : [>`image] obj -> Gdk.image -> ?mask:Gdk.bitmap -> unit
176       = "ml_gtk_image_set"
177 end
178
179 module Label = struct
180   let cast w : label obj = Object.try_cast w "GtkLabel"
181   external coerce : [>`label] obj -> label obj = "%identity"
182   external create : string -> label obj = "ml_gtk_label_new"
183   external set_text : [>`label] obj -> string -> unit = "ml_gtk_label_set_text"
184   external set_justify : [>`label] obj -> justification -> unit
185       = "ml_gtk_label_set_justify"
186   external set_pattern : [>`label] obj -> string -> unit
187       = "ml_gtk_label_set_pattern"
188   external set_line_wrap : [>`label] obj -> bool -> unit
189       = "ml_gtk_label_set_line_wrap"
190   let set ?text ?justify ?line_wrap ?pattern w =
191     may ~f:(set_text w) text;
192     may ~f:(set_justify w) justify;
193     may ~f:(set_line_wrap w) line_wrap;
194     may ~f:(set_pattern w) pattern
195   external get_text : [>`label] obj -> string = "ml_gtk_label_get_label"
196 end
197
198 module TipsQuery = struct
199   let cast w : tips_query obj = Object.try_cast w "GtkTipsQuery"
200   external create : unit -> tips_query obj = "ml_gtk_tips_query_new"
201   external start : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_start_query"
202   external stop : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_stop_query"
203   external set_caller : [>`tipsquery] obj -> [>`widget] obj -> unit
204       = "ml_gtk_tips_query_set_caller"
205   external set_labels :
206       [>`tipsquery] obj -> inactive:string -> no_tip:string -> unit
207       = "ml_gtk_tips_query_set_labels"
208   external set_emit_always : [>`tipsquery] obj -> bool -> unit
209       = "ml_gtk_tips_query_set_emit_always"
210   external get_caller : [>`tipsquery] obj -> widget obj
211       = "ml_gtk_tips_query_get_caller"
212   external get_label_inactive : [>`tipsquery] obj -> string
213       = "ml_gtk_tips_query_get_label_inactive"
214   external get_label_no_tip : [>`tipsquery] obj -> string
215       = "ml_gtk_tips_query_get_label_no_tip"
216   external get_emit_always : [>`tipsquery] obj -> bool
217       = "ml_gtk_tips_query_get_emit_always"
218   let set_labels ?inactive ?no_tip w =
219     set_labels w
220       ~inactive:(may_default get_label_inactive w ~opt:inactive)
221       ~no_tip:(may_default get_label_no_tip w ~opt:no_tip)
222   let set ?caller ?emit_always ?label_inactive ?label_no_tip w =
223     may caller ~f:(set_caller w);
224     may emit_always ~f:(set_emit_always w);
225     if label_inactive <> None || label_no_tip <> None then
226       set_labels w ?inactive:label_inactive ?no_tip:label_no_tip
227   module Signals = struct
228     open GtkArgv
229     open GtkSignal
230     let start_query : ([>`tipsquery],_) t =
231       { name = "start_query"; marshaller = marshal_unit }
232     let stop_query : ([>`tipsquery],_) t =
233       { name = "stop_query"; marshaller = marshal_unit }
234     let widget_entered :
235         ([>`tipsquery],
236          widget obj option ->
237          text:string option -> privat:string option -> unit) t =
238       let marshal f _ = function
239         | OBJECT opt :: STRING text :: STRING privat :: _ ->
240             f (may_map ~f:Widget.cast opt) ~text ~privat
241         | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_entered"
242       in
243       { name = "widget_entered"; marshaller = marshal }
244     let widget_selected :
245         ([>`tipsquery],
246          widget obj option ->
247          text:string option ->
248          privat:string option -> GdkEvent.Button.t option -> bool) t =
249       let marshal f argv = function
250         | OBJECT obj :: STRING text :: STRING privat :: POINTER p :: _ ->
251             let stop = 
252               f (may_map ~f:Widget.cast obj) ~text ~privat
253                 (may_map ~f:GdkEvent.unsafe_copy p)
254             in set_result argv (`BOOL stop)
255         | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_selected"
256       in
257       { name = "widget_selected"; marshaller = marshal }
258   end
259 end
260
261 module Pixmap = struct
262   let cast w : pixmap obj = Object.try_cast w "GtkPixmap"
263   external create : Gdk.pixmap -> ?mask:Gdk.bitmap -> pixmap obj
264       = "ml_gtk_pixmap_new"
265   let create ?mask img = create img ?mask
266   external set :
267       [>`pixmap] obj -> ?pixmap:Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
268       = "ml_gtk_pixmap_set"
269   external pixmap : [>`pixmap] obj -> Gdk.pixmap = "ml_GtkPixmap_pixmap"
270   external mask : [>`pixmap] obj -> Gdk.bitmap = "ml_GtkPixmap_mask"
271 end
272
273 module Separator = struct
274   let cast w : separator obj = Object.try_cast w "GtkSeparator"
275   external hseparator_new : unit -> separator obj = "ml_gtk_hseparator_new"
276   external vseparator_new : unit -> separator obj = "ml_gtk_vseparator_new"
277   let create (dir : Tags.orientation) =
278     if dir = `HORIZONTAL then hseparator_new () else vseparator_new ()
279 end
280
281 module FontSelection = struct
282   type null_terminated
283   let null_terminated arg : null_terminated =
284     match arg with None -> Obj.magic Gpointer.raw_null
285     | Some l ->
286         let len = List.length l in
287         let arr = Array.create (len + 1) "" in
288         let rec loop i = function
289             [] -> arr.(i) <- Obj.magic Gpointer.raw_null
290           | s::l -> arr.(i) <- s; loop (i+1) l
291         in loop 0 l;
292         Obj.magic (arr : string array)
293   let cast w : font_selection obj =
294     Object.try_cast w "GtkFontSelection"
295   external create : unit -> font_selection obj
296       = "ml_gtk_font_selection_new"
297   external get_font : [>`fontsel] obj -> Gdk.font
298       = "ml_gtk_font_selection_get_font"
299   let get_font w =
300     try Some (get_font w) with Gpointer.Null -> None
301   external get_font_name : [>`fontsel] obj -> string
302       = "ml_gtk_font_selection_get_font_name"
303   let get_font_name w =
304     try Some (get_font_name w) with Gpointer.Null -> None
305   external set_font_name : [>`fontsel] obj -> string -> unit
306       = "ml_gtk_font_selection_set_font_name"
307   external set_filter :
308     [>`fontsel] obj -> font_filter_type -> font_type list ->
309     null_terminated -> null_terminated -> null_terminated ->
310     null_terminated -> null_terminated -> null_terminated -> unit
311     = "ml_gtk_font_selection_set_filter_bc"
312       "ml_gtk_font_selection_set_filter"
313   let set_filter w ?kind:(tl=[`ALL]) ?foundry
314       ?weight ?slant ?setwidth ?spacing ?charset filter =
315     set_filter w filter tl (null_terminated foundry)
316       (null_terminated weight) (null_terminated slant)
317       (null_terminated setwidth) (null_terminated spacing)
318       (null_terminated charset)
319   external get_preview_text : [>`fontsel] obj -> string
320       = "ml_gtk_font_selection_get_preview_text"
321   external set_preview_text : [>`fontsel] obj -> string -> unit
322       = "ml_gtk_font_selection_set_preview_text"
323 end