]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkNew.ml
- DoubleTypeInference.does_not_occur exposed
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / gtkNew.ml
1 (* $Id$ *)
2
3 open Gtk
4
5 type t
6
7 (* if you modify this type modify widget_info_array 
8    in ml_gtk.c in accordance *)
9 type object_type =
10   | OBJECT  | WIDGET  | MISC  | LABEL  | ACCELLABEL  | TIPSQUERY  | ARROW
11   | IMAGE   | PIXMAP  | CONTAINER  | BIN  | ALIGNMENT  | FRAME  | ASPECTFRAME
12   | BUTTON  | TOGGLEBUTTON  | CHECKBUTTON  | RADIOBUTTON  | OPTIONMENU
13   | ITEM  | MENUITEM  | CHECKMENUITEM  | RADIOMENUITEM  | TEAROFFMENUITEM
14   | LISTITEM  | TREEITEM  | WINDOW  | COLORSELECTIONDIALOG  | DIALOG
15   | INPUTDIALOG  | FILESELECTION  | FONTSELECTIONDIALOG  | PLUG
16   | EVENTBOX  | HANDLEBOX  | SCROLLEDWINDOW  | VIEWPORT  | BOX
17   | BUTTONBOX  | HBUTTONBOX  | VBUTTONBOX  | VBOX  | COLORSELECTION
18   | GAMMACURVE  | HBOX  | COMBO  | STATUSBAR  | CLIST  | CTREE  | FIXED
19   | NOTEBOOK  | FONTSELECTION  | PANED  | HPANED  | VPANED  | LAYOUT
20   | LIST  | MENUSHELL  | MENUBAR  | MENU  | PACKER  | SOCKET  | TABLE
21   | TOOLBAR  | TREE  | CALENDAR  | DRAWINGAREA  | CURVE  | EDITABLE
22   | ENTRY  | SPINBUTTON  | TEXT  | RULER  | HRULER  | VRULER  | RANGE
23   | SCALE  | HSCALE  | VSCALE  | SCROLLBAR  | HSCROLLBAR  | VSCROLLBAR
24   | SEPARATOR  | HSEPARATOR  | VSEPARATOR  | PREVIEW  | PROGRESS
25   | PROGRESSBAR  | DATA  | ADJUSTMENT  | TOOLTIPS  | ITEMFACTORY
26
27 external set_ml_class_init  : (t -> unit) -> unit = "set_ml_class_init"
28 external signal_new : string -> int -> t -> object_type -> int  -> int
29     = "ml_gtk_signal_new"
30 external object_class_add_signals : t -> int array -> int -> unit
31     = "ml_gtk_object_class_add_signals"
32 external type_unique :
33     name:string -> parent:object_type -> nsignals:int -> gtk_type
34     = "ml_gtk_type_unique"
35 external type_new : gtk_type -> unit obj
36     = "ml_gtk_type_new"
37
38 open GtkSignal
39
40 let make_new_widget ~name ~parent
41     ~(signals : ('a, unit -> unit) GtkSignal.t list) =
42   let nsignals = List.length signals in
43   let new_type = type_unique ~name ~parent ~nsignals in
44   let signal_num_array = Array.create nsignals 0 in
45   let class_init_func classe =
46     List.fold_left signals ~init:0 ~f:
47       (fun i signal ->
48         signal_num_array.(i) <- signal_new signal.name 1 classe parent i;
49         i+1);
50     object_class_add_signals classe signal_num_array nsignals
51   in
52   new_type,
53   (fun () ->
54     set_ml_class_init class_init_func;
55     type_new new_type)
56   (* , signal_num_array *)