lablgtk_20001129* created

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20001129-0.1.0 / gtkNew.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gtkNew.ml b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gtkNew.ml
new file mode 100644 (file)
index 0000000..532a709
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gtkNew.ml
@@ -0,0 +1,56 @@
+(* $Id$ *)
+
+open Gtk
+
+type t
+
+(* if you modify this type modify widget_info_array 
+   in ml_gtk.c in accordance *)
+type object_type =
+  | OBJECT  | WIDGET  | MISC  | LABEL  | ACCELLABEL  | TIPSQUERY  | ARROW
+  | IMAGE   | PIXMAP  | CONTAINER  | BIN  | ALIGNMENT  | FRAME  | ASPECTFRAME
+  | BUTTON  | TOGGLEBUTTON  | CHECKBUTTON  | RADIOBUTTON  | OPTIONMENU
+  | ITEM  | MENUITEM  | CHECKMENUITEM  | RADIOMENUITEM  | TEAROFFMENUITEM
+  | LISTITEM  | TREEITEM  | WINDOW  | COLORSELECTIONDIALOG  | DIALOG
+  | INPUTDIALOG  | FILESELECTION  | FONTSELECTIONDIALOG  | PLUG
+  | EVENTBOX  | HANDLEBOX  | SCROLLEDWINDOW  | VIEWPORT  | BOX
+  | BUTTONBOX  | HBUTTONBOX  | VBUTTONBOX  | VBOX  | COLORSELECTION
+  | GAMMACURVE  | HBOX  | COMBO  | STATUSBAR  | CLIST  | CTREE  | FIXED
+  | NOTEBOOK  | FONTSELECTION  | PANED  | HPANED  | VPANED  | LAYOUT
+  | LIST  | MENUSHELL  | MENUBAR  | MENU  | PACKER  | SOCKET  | TABLE
+  | TOOLBAR  | TREE  | CALENDAR  | DRAWINGAREA  | CURVE  | EDITABLE
+  | ENTRY  | SPINBUTTON  | TEXT  | RULER  | HRULER  | VRULER  | RANGE
+  | SCALE  | HSCALE  | VSCALE  | SCROLLBAR  | HSCROLLBAR  | VSCROLLBAR
+  | SEPARATOR  | HSEPARATOR  | VSEPARATOR  | PREVIEW  | PROGRESS
+  | PROGRESSBAR  | DATA  | ADJUSTMENT  | TOOLTIPS  | ITEMFACTORY
+
+external set_ml_class_init  : (t -> unit) -> unit = "set_ml_class_init"
+external signal_new : string -> int -> t -> object_type -> int  -> int
+    = "ml_gtk_signal_new"
+external object_class_add_signals : t -> int array -> int -> unit
+    = "ml_gtk_object_class_add_signals"
+external type_unique :
+    name:string -> parent:object_type -> nsignals:int -> gtk_type
+    = "ml_gtk_type_unique"
+external type_new : gtk_type -> unit obj
+    = "ml_gtk_type_new"
+
+open GtkSignal
+
+let make_new_widget ~name ~parent
+    ~(signals : ('a, unit -> unit) GtkSignal.t list) =
+  let nsignals = List.length signals in
+  let new_type = type_unique ~name ~parent ~nsignals in
+  let signal_num_array = Array.create nsignals 0 in
+  let class_init_func classe =
+    List.fold_left signals ~init:0 ~f:
+      (fun i signal ->
+       signal_num_array.(i) <- signal_new signal.name 1 classe parent i;
+       i+1);
+    object_class_add_signals classe signal_num_array nsignals
+  in
+  new_type,
+  (fun () ->
+    set_ml_class_init class_init_func;
+    type_new new_type)
+  (* , signal_num_array *)