helm/DEVEL/lablgtk/lablgtk_20001129-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 *)