--- /dev/null
+Summary: LablGTK : an interface to the GIMP Tool Kit for OCaml
+Name: lablgtk_20001129
+Version: 0.1.0
+Release: 1
+Copyright: LGPL
+Group: Development/Libraries
+Source: ftp://ftp.kurims.kyoto-u.ac.jp/pub/lang/olabl/lablgtk-20001129.tar.gz
+%description
+LablGTK is an interface to the GIMP Tool Kit for OCaml.
+
+%prep
+%setup
+
+%build
+make configure
+make
+make opt
+
+%install
+make install
+
+%files
+%doc CHANGES COPYING README doc
+
+/usr/lib/ocaml/lablgtk/
--- /dev/null
+$Id$
+
+2000.11.29
+ * remove unison port, since unison already works with this snapshot
+
+2000.11.16
+ * internal change: switch from var2def/var2conv to varcc,
+ and split ml_gtk.c in smaller files
+
+2000.8.29
+ * bugs in color selection reported by Nicolas George
+ * changed the license
+
+2000.8.21
+ * correct GtkStyle.set_font bug reported by Patrick Doane
+
+2000.7.27
+ * changed GUtil.signal and GUtil.variable for better usability
+ * suppressed obsolete color settings in tooltips
+
+2000.6.19
+ * patch by Michael Welsh for Gdk regions
+
+2000.6.15
+ * add CList.set_cell_style/set_row_style
+ * change set_usize/set_uposition into set_geometry
+ * return an option rather than raise an exception for null pointers
+ * map empty strings to NULL when meaningful
+ * Gdk.Font.get_type/ascent/descent
+
+2000.6.14
+ * add GDraw.optcolor for functions with a default (Jerome suggested)
+
+2000.6.8
+ * apply Jerome Vouillon's patch
+ * changes in GtkSignal and GtkArgv.ml
+
+2000.6.7
+ * create #misc#connect for widget generic signals
+
+2000.6.6
+ * move notebook from GMisc to GPack
+ * #connect#event, #add_event, #misc#event, #misc#set_events_extension
+ transferred to #event su-bobject.
+ * #connect#drag -> #drag#connect.
+ * #get_type, #connect#disconnect, #connect#stop_emit transferred to #misc.
+
+2000.5.25
+ * split misc.ml into gaux.ml and gpointer.ml
+
+2000.5.23
+ * add GMisc.notebook#get_{tab,menu}_label. Rename nth_page to get_nth_page.
+ * modified ML signals in GUtil, to allow signals without widget.
+
+2000.5.22
+ * Incompatible!: Change default for ~expand in Box.pack,
+ Pack.build_options, Table.build_options. Now defaults to false/`NONE.
+ This means that all options default to false/`NONE, except ~show
+ (true for all widgets except windows) and ~fill (always true but
+ effect controlled by ~expand).
+ * add GtkArgv.get_nativeint and GtkArgv.set_nativeint.
+ * make offset and length optional in GtkArgv.string_at_pointer.
+
+2000.5.10
+ * rename GtkFrame to GtkBin and GFrame to GBin
+ * move socket to GBin
+
+2000.5.9
+ * add arrow and image classes to GMisc
+ * add list and set_item_string methods to GEdit.combo
+ * add socket and plug classes to GContainer and GWindow
+ * two new examples: combo.ml and socket.ml
+
+2000.4.28
+ * add GUtil.variable
+
+2000.4.27
+ * add GtkXmHTML widget
+
+2000.4.26
+ * release 1.00
+
+2000.4.24
+ * merge in changes for ocaml 3.00: label and syntax changes, autolink
+ * added better visual and colormap handling to Gdk
+ * GdkObj renamed to GDraw, GtkPixmap moved to GMisc
+ * Initialize Gtk in gtkInit.cmo/cmx, start a thread in gtkInitThread.cmo.
+ These are only included in toplevels, link them explicitely or call
+ GMain.Main.init and GtkThread.start otherwise.
+ * install to caml standard library
+ * many other forgotten changes...
+
+2000.3.02
+ * move locale setting inside GtkMain.init, since it requires an
+ X display
+
+2000.2.24
+ * add checks in add methods, to avoid critical errors
+
+2000.2.23
+ * add dcalendar.ml (submitted by Ken Wakita) and csview.ml
+ * correct bug in GdkObj.pixmap#line
+
+1999.12.19
+ * release lablGTK beta2
+
+1999.12.16
+ * upgraded unison to version 1.169
+ * radio groups are of type {radio_menu_item,radio_button} obj option,
+ otherwise you could not use them several times
+
+1999.12.13
+ * added GtkEdit::{insert_text,delete_text} signals
+ * better syntax highlighting and ergonomy in the browser's shell
+
+1999.11...
+ * switched to Objective Caml 3
+ * constructors are no longer classes, but simple functions
+
+1999.10.29
+ * changed GtkArgv.get_{string,pointer,object} to return option types
+
+1999.10.27
+ * added radtest/CHANGES for cooperative editing on radtest
+
+1999.10.21
+ * added a UI for unison
+ (ask bcpierce@saul.cis.upenn.edu about how to get unison)
+
+1999.10.20
+ * corrected CList signals
+ * moved initialization out of the library, in gtkInit.cmo
+
+1999.10.15
+ * release lablGTK beta1
+
+1999.10.13
+ * improved gtkThread.ml (no timer)
+ * modify Sys.argv in place (gtkMain.ml)
+ * add set_row_data and get_row_data for GtkCList
+
+1999.10.11
+ * bugfixes in Makefile, radtest and lv
+
+1999.10.6
+ * added Gdk.X.flush and Gdk.X.beep
+ * Gdk.X.flush is exported in GtkMain.Main
+
+1999.9.9
+ * added font selection dialog
+
+1999.8.25
+ * re-added connect#draw
+
+1999.8.10
+ * reduced the number of methods in widget
+ * moved disconnect and stop_emit to object_signals
+ * moved ?:after to each signal
+ * more functions in applications/browser
+
+1999.8.9
+ * Major change: created one set_param method by parameter,
+ rather than grouping them and using options.
+ You can get previous versions with tag "changing_set"
+ * corrected examples, radtest and browser for these changes
+ * a bit of clean-up in radtest (treew.ml and Makefile)
+
+1999.8.5
+ * corrected a bad bug with indirected pointers in caml heap
+
+1999.7.15
+ * add GdkKeysyms for exotic keysyms
+
+1999.7.14
+ * moved Truecolor inside Gdk
+ * added COPYING
+ * prepared for release
+
+1999.7.12
+ * clean up drag-and-drop
+
+1999.7.9
+ * corrected bug in Container.children
+ * added ML signal support in GUtil
+
+1999.7.6
+ * added DnD, improved radtest (Hubert)
+ * small corrections (Jacques)
+
+1999.7.1
+ * added some gdk functions related window and ximage
+ * also added applications/lv, "labl image viewer" with
+ the camlimage library.
+ (JPF)
+
+1999.7.1
+ * added applications/lablglade (Koji)
+
+1999.6.28
+ * added applications/radtest (Hubert)
+
+1999.6.23
+ * improved variant conversions for space.
+
+1999.6.22
+ * updated olabl.patch. With this new version you can access fields
+ of records without opening modules. You can also use several times
+ the same label in one module.
+ * examples/GL/morph3d.ml uses it.
+
+1999.6.21
+ * moved event functions to GdkEvent
+
+1999.6.20
+ * new example: radtest.ml (Hubert)
+
+1999.6.18
+ * added GL extension
+
+1999.6.15
+ * grouped set methods into set_<keyword>
+ * added width and height option to all classes
+ * windows not shown are automatically destroyed by the GC
+
+1999.6.14
+ * added GPack.layout, GPack.packer, GPack.paned, GMisc.notebook,
+ GRange.scale, GMisc.calendar
+ * added 3 examples
+ * #add_events only available on windowed widgets
+
+1999.6.11
+ * added CList widget in GList module, and examples/clist.ml
+ * improved pixmap abstraction in GdkObj / GPix
+
+1999.6.10
+ * suppressed almost all raw pointers from the code. Pointers are now
+ either boxed (second field of an abstract block) or marked (lowest
+ bit set to 1).
+
+1999.6.9
+ * added GtkBase.Object.get_id and GObj.gtkobj#get_id to get an
+ unique identifier to gtk objects. Nice for hash-tables, etc...
+ * GUtil.memo is such an hash-table, allowing you to recover an
+ object's wrapper.
+ * added a show option to all classes, commanding whether the widget
+ should be shown immediately. It is by default true on all widgets
+ except in module GWindow.
+ * moved non-OO examples to examples/old. Do "cvs update -d old" to
+ get them.
+ * changes in Gdk/GtkData/GObj about styles.
+
+1999.6.8
+ * updated olabl.patch
+
+1999.6.7
+ * split gtk.ml into gtk*.ml
+
+1999.6.5
+ * grouped Container focus operations in a "focus" subwidget
+
+1999.6.4
+ * slightly reorganized widget grouping
+
+1999.6.3
+ * disabled gtk_caller
+ * subtle hack to have GTree get the right interface
+ * switched completely to the new widget scheme (including examples)
+ * added olabl.patch to apply to olabl-2.02 to compile new sources
+
+1999.6.2
+ * integrated changes from Hubert in Gtk, GtkObj and testgtk.ml
+ * added G* modules to replace GtkObj. "make lablgtk2" for it
+
+1999.6.1
+ * added experimental GtkMenu for a cleaner approach to OO (Jacques)
+
+1999.5.31
+ * GtkObj: list, tree and menu_shell inherit from item_container (Jacques)
+ * Argv.get_{string,pointer,object} may raise Null_pointer (Jacques)
+ * Support for creating new widgets (Hubert)
+
+1999.5.28
+ * a few stylistic corrections
+ * added Packer in gtk.ml
+
+1999.5.27
+ * new Gtk.Main.main Gtk.Main.quit and GtkThread.main (for modal windows)
+ * added x: and y: to Window.setter
+ * new methods: object#get_type widget#misc#lock_accelerators
+ widget#misc#visible widget#misc#parent container#set_focus#vadjustment
+ container#set_focus#hadjustment (could be container#set_focus#adjustment with a dir param)
+ window#set_modal window#set_position window#set_default_size
+ window#set_transient_for
+ menu#set_accel_group
+ * new classes: handle_box_skel handle_box_signals handle_box
+ bbox color_selection color_selection_dialog toolbar
+ and the corresponding modules in gtk.ml
+ new class type: is_window and method as_window
+ * new param tearoff: in new_menu_item
+ new param x: and y: modal: in Window.setter
+ * Widget.event and Widget.activate return bool
+ * new example: examples/testgtk.ml and test.xpm
+ (Hubert)
+
+1999.5.25
+ * upgraded to gtk+-1.2.3 (all examples work)
+ * suppressed deprecated function calls and corrected examples
+ * added a patch to use toplevel threads in olabl-2.02
+
+1998.12.13
+ * upgraded to olabl-2.01
+
+1998.12.9
+ * replicated Main, Timeout and Grab to GtkObj (no need to open Gtk anymore)
+ * moved some non standard classes to GtkExt
+
+1998.12.8
+ * added the first application, xxaplay, Playstation audio track
+ player for linux. (How architecture specific!) (Furuse)
+
+1998.12.8
+ * more widgets in GtkObj
+ * refined memory management
+ * all variants in upper case
+
+1998.12.7
+ * after deeper thought, re-introduced the connect sub-object
+ * simplified GtkObj: use simple inheritance and allow easy subtyping
+ * updated olabl.diffs for bugs in class functions parsing and printing
+ * add ThreadObj for concurrent object programming
+ (Jacques)
+
+1998.12.3
+ * pousse.ml is now a reversi game (idea for strategy ?)
+ * solved startup bug (a value checker for ocaml is now available)
+ (Jacques)
+
+1998.12.2
+ * added GdkObj for high level drawing primitives (Jacques)
+
+1998.11.30
+ * removed cast checking for NULL valued widgets (ml_gtk.[ch])
+ * module Arg is renamed as GtkArg because of the name corrision with
+ the module Arg in the standard library
+ * Makefile : native code compilation added
+ (Furuse)
+
+1998.11.29
+ * renamed widget_ops sub-object to misc
+ * various improvements of set functions
+ (Jacques)
+
+1998.11.28
+ * switched to object-oriented model. GtkObj is now the standard way
+ to access the library, but not all objects are ready (see README)
+ * removed inheritance in gtk.ml
+ (Jacques)
+
+1998.11.24
+ * added inheritance in gtk.ml
+
+1998.11.22
+ * added gtkObj.ml and examples/*_obj.ml
+ * various modifications in gtk.ml
+
--- /dev/null
+This library is made available under the LGPL.
+You should have got a copy of the LGPL with Objective Caml.
+The LGPL applies to all the files in this directory, but not in
+subdirectories.
+
+For the examples subdirectory, there is no specific licensing policy,
+but you may freely take inspiration from the code, and copy parts of
+it in your application.
+
+For the applications subdirectory, stricter rules apply:
+
+* You are free to do anything you want with this code as long as it is
+ for personal use.
+
+* Redistribution can only be "as is". Binary distribution and bug
+ fixes are allowed, but you cannot extensively modify the code
+ without asking the authors.
+
+The authors may choose to remove any of the above restrictions on a
+per request basis.
+
+Authors:
+ Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
+ Hubert Fauque <hubert.fauque@wanadoo.fr>
+ Jun Furuse <Jun.Furuse@inria.fr>
+ Koji Kagawa <kagawa@eng.kagawa-u.ac.jp>
+
+$Id$
\ No newline at end of file
--- /dev/null
+# $Id$
+# Makefile for lablgtk.
+
+TARGETS = varcc lablgtktop lablgtktop_t lablgtkrun lablgtk
+
+all: $(TARGETS)
+
+opt: lablgtkopt
+
+configure:
+ @rm -f config.make
+ @$(MAKE) --no-print-directory -f configure.mk
+
+depend:
+ @rm -f .depend
+ @$(MAKE) --no-print-directory -f configure.mk .depend
+
+.depend config.make:
+ @$(MAKE) --no-print-directory -f configure.mk
+
+COMPILER = $(CAMLC) $(MLFLAGS) -w s -labels -c
+LINKER = $(CAMLC) $(MLFLAGS)
+COMPOPT = $(CAMLOPT) $(MLFLAGS) -w s -labels -c
+LINKOPT = $(CAMLOPT) $(MLFLAGS)
+TOPLEVEL = ocamlmktop $(MLFLAGS)
+
+include config.make
+
+INSTALLDIR = $(LIBDIR)/lablgtk
+LABLGLDIR = $(LIBDIR)/lablGL
+
+MLLIBS = lablgtk.cma
+CLIBS = liblablgtk.a
+MLLINK = unix.cma str.cma
+
+ifdef DEBUG
+CFLAGS = -g $(GTKCFLAGS)
+MLLINK += -cclib -lcamlrund
+MLFLAGS = -g
+else
+CFLAGS = -O -DGTK_NO_CHECK_CASTS -DGTK_DISABLE_COMPAT_H $(GTKCFLAGS)
+endif
+
+THFLAGS = -thread
+THLINK = unix.cma threads.cma
+
+ifdef USE_CC
+CCOMPILER = $(CC) -c -I$(LIBDIR) $(CFLAGS)
+else
+CCOMPILER = ocamlc -c -ccopt "$(CFLAGS)"
+endif
+
+ifdef USE_GL
+MLFLAGS += -I $(LABLGLDIR)
+MLLINK += lablgl.cma
+MLLIBS += lablgtkgl.cma
+CLIBS += liblablgtkgl.a
+GLLINK = -cclib -llablgtkgl -cclib -lgtkgl
+GLMLOBJS = glGtk.cmo
+GLCOBJS = ml_gtkgl.o
+
+endif
+
+ifdef USE_GNOME
+MLLIBS += lablgnome.cma
+CLIBS += liblablgnome.a
+GNOMEMLOBJS = gtkXmHTML.cmo gHtml.cmo
+GNOMECOBJS = ml_gtkxmhtml.o
+endif
+
+# Rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .o .var .h .opt .def
+.c.o:
+ $(CCOMPILER) $<
+.ml.cmo:
+ $(COMPILER) $<
+.mli.cmi:
+ $(COMPILER) $<
+.ml.cmx:
+ $(COMPOPT) $<
+.var.h:
+ ./varcc $<
+
+# Targets
+GTKOBJS = ml_gtk.o ml_gtkbin.o ml_gtkbutton.o ml_gtkedit.o ml_gtklist.o \
+ ml_gtkmenu.o ml_gtkmisc.o ml_gtknew.o ml_gtkpack.o ml_gtkrange.o \
+ ml_gtktree.o
+COBJS = ml_gdk.o ml_glib.o wrappers.o $(GTKOBJS)
+MLOBJS = gaux.cmo gpointer.cmo glib.cmo gdk.cmo gdkEvent.cmo gdkKeysyms.cmo \
+ gtk.cmo gtkArgv.cmo gtkSignal.cmo \
+ gtkData.cmo gtkBase.cmo gtkPack.cmo gtkButton.cmo \
+ gtkMenu.cmo gtkMisc.cmo gtkWindow.cmo gtkTree.cmo gtkList.cmo \
+ gtkBin.cmo gtkEdit.cmo gtkRange.cmo gtkMain.cmo gtkNew.cmo \
+ gDraw.cmo \
+ gObj.cmo gMain.cmo gData.cmo gContainer.cmo gPack.cmo gButton.cmo \
+ gMenu.cmo gMisc.cmo gWindow.cmo gTree.cmo gList.cmo gBin.cmo \
+ gEdit.cmo gRange.cmo gUtil.cmo
+THOBJS = gtkThread.cmo
+INITOBJS = gtkInit.cmo
+THINITOBJS = gtkThInit.cmo
+ALLOBJS = $(MLOBJS) $(GLMLOBJS) $(GNOMEMLOBJS) $(THOBJS) \
+ $(INITOBJS) $(THINITOBJS)
+
+lablgtktop: $(CLIBS) $(MLLIBS) $(INITOBJS)
+ $(TOPLEVEL) -o $@ $(MLLINK) -ccopt -L. $(MLLIBS) $(INITOBJS)
+
+lablgtktop_t: $(CLIBS) $(MLLIBS) $(THOBJS) $(INITOBJS) $(THINITOBJS)
+ $(TOPLEVEL) $(THFLAGS) -o $@ $(THLINK) $(MLLINK) \
+ -ccopt -L. $(MLLIBS) $(THOBJS) $(INITOBJS) $(THINITOBJS)
+
+lablgtk: Makefile config.make lablgtk.in
+ sed -e "s|@INSTALLDIR@|$(INSTALLDIR)|g" \
+ -e "s|@LABLGLDIR@|$(LABLGLDIR)|g" \
+ -e "s|@LIBDIR@|$(LIBDIR)|g" \
+ < lablgtk.in > $@
+ chmod 755 $@
+
+lablgtkrun: $(CLIBS) $(MLLIBS)
+ $(LINKER) -o $@ -make-runtime $(MLLINK) -ccopt -L. $(MLLIBS)
+
+lablgtkopt: $(CLIBS) $(MLLIBS:.cma=.cmxa) $(INITOBJS:.cmo=.cmx) \
+ $(THOBJS:.cmo=.cmx)
+
+install:
+ if test -d $(INSTALLDIR); then : ; else mkdir -p $(INSTALLDIR); fi
+ cp $(ALLOBJS:.cmo=.cmi) $(INSTALLDIR)
+ cp *.mli $(INSTALLDIR)
+ cp *.h $(INSTALLDIR)
+ cp $(ALLOBJS:.cmo=.ml) $(INSTALLDIR)
+ cp $(MLLIBS) $(THOBJS) $(INITOBJS) $(THINITOBJS) $(INSTALLDIR)
+ cp $(CLIBS) $(INSTALLDIR)
+ cp lablgtktop lablgtktop_t $(INSTALLDIR)
+ cp lablgtk lablgtkrun $(BINDIR)
+ if test -f lablgtk.cmxa; then \
+ cp $(MLLIBS:.cma=.cmxa) $(MLLIBS:.cma=.a) \
+ $(INITOBJS:.cmo=.cmx) $(INITOBJS:.cmo=.o) $(INSTALLDIR); fi
+ if test -f gtkThread.cmx; then \
+ cp $(THOBJS:.cmo=.cmx) $(THOBJS:.cmo=.o) $(INSTALLDIR); fi
+
+liblablgtk.a: $(COBJS)
+ ar rc $@ $(COBJS)
+ $(RANLIB) $@
+lablgtk.cma: $(MLOBJS)
+ $(LINKER) -a -custom -o $@ $(MLOBJS) \
+ -cclib -llablgtk $(GTKLIBS)
+lablgtk.cmxa: $(MLOBJS:.cmo=.cmx)
+ $(LINKOPT) -a -o $@ $(MLOBJS:.cmo=.cmx) \
+ -cclib -llablgtk $(GTKLIBS)
+
+liblablgtkgl.a: $(GLCOBJS)
+ ar rc $@ $(GLCOBJS)
+ $(RANLIB) $@
+lablgtkgl.cma: $(GLMLOBJS)
+ $(LINKER) -a -custom -o $@ $(GLLINK) $(GLMLOBJS)
+lablgtkgl.cmxa: $(GLMLOBJS:.cmo=.cmx)
+ $(LINKOPT) -a -o $@ $(GLLINK) $(GLMLOBJS:.cmo=.cmx)
+
+liblablgnome.a: $(GNOMECOBJS)
+ ar rc $@ $(GNOMECOBJS)
+ $(RANLIB) $@
+lablgnome.cma: $(GNOMEMLOBJS)
+ $(LINKER) -a -custom -o $@ $(GNOMEMLOBJS) \
+ -cclib -llablgnome $(GNOMELIBS)
+lablgnome.cmxa: $(GNOMEMLOBJS:.cmo=.cmx)
+ $(LINKOPT) -a -o $@ $(GNOMEMLOBJS:.cmo=.cmx) \
+ -cclib -llablgnome $(GNOMELIBS)
+
+gtkThread.cmo: gtkThread.ml
+ $(COMPILER) $(THFLAGS) gtkThread.ml
+
+gtkThread.cmx: gtkThread.ml
+ if test -f $(LIBDIR)/libthreadsnat.a; then \
+ $(COMPOPT) $(THFLAGS) gtkThread.ml; fi
+
+varcc: varcc.cmo
+ $(LINKER) -o $@ varcc.cmo
+ rm -f *_tags.h *_tags.c
+
+clean:
+ rm -f *.cm* *.o *.a *_tags.[ch] $(TARGETS)
+
+$(GTKOBJS): gtk_tags.h ml_gtk.h ml_gdk.h wrappers.h
+ml_gdk.o: gdk_tags.h ml_gdk.h wrappers.h
+ml_gtkgl.o: gtkgl_tags.h ml_gtk.h ml_gdk.h wrappers.h
+ml_gtkxmhtml.o: gtkxmhtml_tags.h ml_gtk.h ml_gdk.h wrappers.h
+
+include .depend
--- /dev/null
+# $Id$
+# Makefile for lablgtk.
+
+EXE = .exe
+TARGETS = var2conv var2def lablgtk$(EXE) lablgtk_t$(EXE) \
+ lablgtkrun$(EXE) config.make
+
+all: $(TARGETS)
+
+opt: lablgtkopt
+
+CAMLC = ocamlc
+CAMLOPT = ocamlopt
+COMPILER = $(CAMLC) $(MLFLAGS) -w s -labels -c
+LINKER = $(CAMLC) $(MLFLAGS)
+COMPOPT = $(CAMLOPT) $(MLFLAGS) -w s -labels -c
+LINKOPT = $(CAMLOPT) $(MLFLAGS)
+
+TOPLEVEL = ocamlmktop $(MLFLAGS)
+### How to invoke the librarian
+MKLIB=lib /nologo /debugtype:CV /out:
+
+!include config.make.nt
+
+INSTALLDIR = $(LIBDIR:/=\)\lablgtk
+BINDIR = $(LIBDIR:/=\)\..\bin
+LABLGLDIR = $(LIBDIR)/lablGL
+
+CFLAGS = -O -DGTK_NO_CHECK_CASTS -DGTK_DISABLE_COMPAT_H $(GTKCFLAGS)
+LDFLAGS = $(GTKLIBS)
+
+THFLAGS = -thread
+THLIBS = unix.cma threads.cma
+
+!if $(USE_CC) == 1
+CCOMPILER = $(CC) -c -I$(LIBDIR) $(CFLAGS)
+!else
+CCOMPILER = ocamlc -c -ccopt "$(CFLAGS)"
+!endif
+
+!if $(USE_GL) == 1
+MLFLAGS = $(MLFLAGS) -I $(LIBDIR)/lablGL
+GLLINK = -I $(LABLGLDIR) lablgl.cma -cclib -lgtkgl
+GLMLOBJS = glGtk.cmo
+GLCOBJS = ml_gtkgl.o
+!endif
+
+# Rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .obj .var .h .opt .def
+.c.obj:
+ $(CCOMPILER) $<
+.ml.cmo:
+ $(COMPILER) $<
+.mli.cmi:
+ $(COMPILER) $<
+.ml.cmx:
+ $(COMPOPT) $<
+.var.h:
+ ocamlrun ./var2def < $< > $@
+.var.c:
+ ocamlrun ./var2conv < $< > $@
+
+# Targets
+COBJS = ml_gtk.obj ml_gdk.obj ml_glib.obj wrappers.obj $(GLCOBJS)
+OLDMLOBJS = misc.cmo glib.cmo gdk.cmo gtk.cmo gdkObj.cmo gtkObj.cmo gtkExt.cmo
+MLOBJS = misc.cmo glib.cmo gdk.cmo gdkEvent.cmo gdkKeysyms.cmo \
+ gtk.cmo gtkArgv.cmo gtkSignal.cmo \
+ gtkData.cmo gtkBase.cmo gtkPack.cmo gtkButton.cmo \
+ gtkMenu.cmo gtkMisc.cmo gtkWindow.cmo gtkTree.cmo gtkList.cmo \
+ gtkFrame.cmo gtkEdit.cmo gtkRange.cmo gtkMain.cmo gtkNew.cmo \
+ gDraw.cmo \
+ gObj.cmo gMain.cmo gData.cmo gContainer.cmo gPack.cmo gButton.cmo \
+ gMenu.cmo gMisc.cmo gWindow.cmo gTree.cmo gList.cmo gFrame.cmo \
+ gEdit.cmo gRange.cmo gUtil.cmo $(GLMLOBJS)
+THOBJS = gtkThread.cmo threadObj.cmo
+INITOBJS = gtkInit.cmo
+THINITOBJS = gtkThInit.cmo
+ALLOBJS = $(MLOBJS) $(THOBJS) $(INITOBJS) $(THINITOBJS)
+
+lablgtk$(EXE): liblablgtk.lib lablgtk.cma $(INITOBJS)
+ $(TOPLEVEL) -custom -o $@ unix.cma str.cma $(GLLINK) \
+ lablgtk.cma $(INITOBJS)
+
+lablgtk_t$(EXE): liblablgtk.lib lablgtk.cma $(THOBJS) $(INITOBJS) $(THINITOBJS)
+ $(TOPLEVEL) -custom $(THFLAGS) -o $@ $(THLIBS) str.cma $(GLLINK) \
+ lablgtk.cma $(THOBJS) $(INITOBJS) $(THINITOBJS)
+
+lablgtkrun$(EXE): liblablgtk.lib lablgtk.cma
+ $(LINKER) -o $@ -make-runtime $(GLLINK) lablgtk.cma
+
+lablgtkopt: liblablgtk.lib lablgtk.cmxa gtkInit.cmx
+
+install:
+ if not exist $(INSTALLDIR) mkdir $(INSTALLDIR)
+ cp $(ALLOBJS:.cmo=.cmi) $(INSTALLDIR)
+ cp *.mli $(INSTALLDIR)
+ cp $(ALLOBJS:.cmo=.ml) $(INSTALLDIR)
+ cp lablgtk.cma $(THOBJS) $(INITOBJS) $(THINITOBJS) $(INSTALLDIR)
+ cp liblablgtk.lib $(INSTALLDIR)
+ cp lablgtk$(EXE) lablgtk_t$(EXE) lablgtkrun$(EXE) $(BINDIR)
+ if exist lablgtk.cmxa cp lablgtk.cmxa lablgtk.lib gtkInit.cmx gtkInit.obj $(INSTALLDIR)
+
+liblablgtk.lib: $(COBJS)
+ $(MKLIB)$@ $(COBJS)
+
+lablgtk.cma: $(MLOBJS)
+ $(LINKER) -a -custom -o $@ $(MLOBJS) \
+ -cclib -llablgtk $(GTKLIBS)
+
+lablgtk.cmxa: $(MLOBJS:.cmo=.cmx)
+ $(LINKOPT) -a -o $@ $(MLOBJS:.cmo=.cmx) \
+ -cclib -llablgtk $(GTKLIBS)
+
+gtkThread.cmo: gtkThread.ml
+ $(COMPILER) $(THFLAGS) gtkThread.ml
+
+threadObj.cmo: threadObj.ml
+ $(COMPILER) $(THFLAGS) threadObj.ml
+
+gtkThread.cmx: gtkThread.ml
+ $(COMPOPT) $(THFLAGS) gtkThread.ml
+
+threadObj.cmx: threadObj.ml
+ $(COMPOPT) $(THFLAGS) threadObj.ml
+
+var2conv: var2conv.cmo
+ $(LINKER) -o $@ var2conv.cmo
+ rm -f *_tags.c
+
+var2def: var2def.cmo
+ $(LINKER) -o $@ var2def.cmo
+ rm -f *_tags.h
+
+clean:
+ rm -f *.cm* *.obj *.lib *_tags.[ch] $(TARGETS)
+
+config.make: config.make.nt
+ cp config.make.nt config.make
+
+depend .depend:
+ ocamldep *.ml *.mli > .depend
+
+ml_gtk.obj: gtk_tags.c gtk_tags.h ml_gtk.h ml_gdk.h wrappers.h
+ml_gdk.obj: gdk_tags.c gdk_tags.h ml_gdk.h wrappers.h
+ml_gtkgl.obj: gtkgl_tags.c gtkgl_tags.h ml_gtk.h ml_gdk.h wrappers.h
+
+!include .depend
--- /dev/null
+
+ LablGTK : an interface to the GIMP Tool Kit
+
+
+Needed:
+ ocaml-3.00
+ gtk-1.2.x
+ gmake (there is no standard for conditionals)
+
+How to compile:
+
+ You should normally not need to modify Makefiles.
+ First type "make configure <options>".
+ Options are
+ USE_CC=1 to use $(CC) rather than gcc
+ USE_GL=1 to compile with OpenGL support (see lower)
+ USE_GNOME=1 to compile GtkXmHTML support (requires gnome)
+
+ Then just type "make" to build the library and toplevels.
+
+ On FreeBSD, you need to link with libxpg4.so for Japanese
+ output.
+
+Contents:
+
+ gdk.ml low-level interface to the General Drawing Kit
+ gtk.ml low-level interface to the GIMP Tool Kit
+ gtkThread.ml main loop for threaded version
+ g[A-Z]*.ml object-oriented interface to GTK
+ gdkObj.ml object-oriented interface to GDK
+
+ lablgtk toplevel
+
+ examples/*.ml various examples
+ applications/* applications using the library
+ radtest a very experimental RAD for lablgtk
+ (by Hubert Fauque)
+ browser the begin of a port of OCamlBrowser
+ (by Jacques Garrigue)
+ unison a frontend for the Unison file synchronizer
+ see the README for details.
+
+Upgrading from lablgtk-1.00:
+ There are a few incompatibilities between this version and the
+ previous release. We do not describe them all, since usually a type
+ error message will inform you.
+ * all signals are no longer under #connect. #connect#event changed
+ to #event#connect, and some signals are under #misc#connect or
+ #grab#connect. See lower for a description of the new widget
+ structure.
+ * some defaults changed. In particular GPack.box#pack have now all
+ its parameter defaulting to false rather than true. See lower for
+ the new default policy. Beware that this does not cause type
+ errors, just changes in the aspect.
+
+How to run the examples:
+ In the examples directory just type:
+ lablgtk -labels examples/???.ml
+
+ Before installing lablgtk you have to be more explicit:
+ ../lablgtktop -labels -w s -I .. ???.ml
+
+How to link them:
+ lablgtktop contains an extra module GtkInit, whose only contents is:
+ let locale = GtkMain.Main.init ()
+ You must either add this line, or add this module to your link,
+ before calling any Gtk function.
+ ocamlc -I CAMLLIB/lablgtk -labels -w s lablgtk.cma gtkInit.cmo ???.ml -o ???
+
+How to use the threaded toplevel:
+
+ % lablgtk -thread (or lablgtktop_t before installing)
+ Objective Caml version 3.00
+
+ # let w = GWindow.window ~show:true ();;
+
+ You should at once see a window appear.
+ The GTK main loop is running in a separate thread. Any command
+ is immediately reflected by the system.
+ Beware that you cannot switch threads within a callback, that is the
+ only thread related command you may use in a callback is
+ Thread.create. On the other hand, all newly created threads will be
+ run directly by the caml main loop, so they can use all thread
+ operations.
+
+Structure of the (raw) Gtk* modules:
+
+ These modules are composed of one submodule for each class.
+ Signals specific to a widget are in a Signals inner module.
+ A setter function is defined to give access to set_param functions.
+
+Structure of the G[A-Z]* modules:
+
+ These modules provide classes to wrap the raw function calls.
+ Here are the widget classes contained in each module:
+
+ GDraw Gdk pixmaps, etc...
+ GObj gtkobj, widget, style
+ GData data, adjustment, tooltips
+ GContainer container, item_container
+ GWindow window, dialog, color_selection_dialog, file_selection, plug
+ GPack box, button_box, table, fixed, layout, packer, paned, notebook
+ GBin scrolled_window, event_box, handle_box, frame,
+ aspect_frame, viewport, socket
+ GButton button, toggle_button, check_button, radio_button, toolbar
+ GMenu menu_item, tearoff_item, check_menu_item, radio_menu_item,
+ menu_shell, menu, option_menu, menu_bar, factory
+ GMisc separator, statusbar, calendar, drawing_area,
+ misc, arrow, image, pixmap, label, tips_query,
+ color_selection, font_selection
+ GTree tree_item, tree
+ GList list_item, liste, clist
+ GEdit editable, entry, spin_button, combo, text
+ GRange progress, progress_bar, range, scale, scrollbar
+
+ While subtyping follows the Gtk widget hierarchy, you cannot always
+ use width subtyping (i.e. #super is not unifiable with all the
+ subclasses of super). Still, it works for some classes, like
+ #widget and #container, and allows subtyping without coercion towards
+ these classes (cf. #container in pousse.ml for instance).
+
+ Practically, each widget class is composed of:
+ * a coerce method, returning the object coerced to the type widget.
+ * an as_widget method, returning the raw Gtk widget used for packing, etc...
+ * a connect sub-object, allowing one to widget specific
+ signals (this is what prevents width subtyping in subclasses.)
+ * a misc sub-object, giving access to miscellanous functionality of
+ the basic gtkwidget class, and a misc#connect sub-object.
+ * an event sub-object, for Xevent related functions (only if the widget
+ has an Xwindow), and an event#connect sub-object.
+ * a grab sub-object, containing drag and drop functions,
+ and a grab#connect sub-object.
+ * widget specific methods.
+
+ Here is a diagram of the structure (- for methods, + for sub-objects)
+ - coerce : widget
+ - as_widget : Gtk.widget obj
+ - destroy : unit -> unit
+ - ...
+ + connect : mywidget_signals
+ | - after
+ | - signal_name : callback:(... -> ...) -> GtkSignal.id
+ + misc : misc_ops
+ | - show, hide, disconnect, ...
+ | + connect : misc_signals
+ + event : event_ops
+ | - add, ...
+ | + connect : event_signals
+ + grab : grab_ops
+ | - ...
+ | + connect : grab_signals
+
+ You create a widget by [<Module>.<widget name> options ... ()].
+ Many optional arguments are admitted. The last two of them, packing:
+ and show:, allow you respectively to call a function on your newly
+ created widget, and to decide wether to show it immediately or not.
+ By default all widgets except toplevel windows (GWindow module) are
+ shown immediately.
+
+Default arguments:
+ For many constructor or method arguments, default values are provided.
+ Generally, this default value is defined by GTK, and you must refer
+ to GTK's documentation.
+ For ML defined defaults, usually default values are either false, 0, None
+ or `NONE, according to the expected type.
+ Important exceptions are ~show, which default to true in all widgets
+ except those in GWindow, and ~fill, which defaults to true or `BOTH.
+
+Note about unit as method argument:
+
+ O'Caml introduces no distinction between methods having side-effects
+ and methods simply returning a value. In practice, this is
+ confusing, and awkward when used as callbacks. For this reason all
+ methods having noticeable side-effects should take arguments, and
+ unit if they have no argument.
+
+Memory management:
+
+ Important efforts have been dedicated to cooperate with Gtk's
+ reference counting mechanism. As a result you should generally be
+ able to use Gdk/Gtk data structures without caring about memory
+ management. They will be freed when nobody points to them any more.
+ This also means that you do not need to pay too much attention to
+ whether a data structure is still alive or not. If it is not, you
+ should get an error rather than a core dump.
+ The case of Gtk objects deserves special care. Since they are
+ interactive, we cannot just destroy them when they are no longer
+ referenced. They have to be explicitely destroyed. If a widget was
+ added to a container widget, it will automatically be destroyed when
+ its last container is destroyed. For this reason you need only
+ destroy toplevel widgets.
+
+GL extension
+
+ You can use lablgtk in combination with LablGL
+
+ * get and install lablGL 0.94 from
+ http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgl.html
+ * get and install gtkglarea-1.2.x.tar.gz from
+ http://www.student.oulu.fi/~jlof/gtkglarea/index.html
+ * reconfigure: "make configure USE_GL=1"
+
+ You can then use the widget GlGtk.gl_area as an OpenGL window.
+ Some examples are in examples/GL, but basically any LablGL example
+ can be easily ported.
+
+Windows port
+
+ A Win32 port is provided. In order to compile it, you will need to
+ get and unpack glib-dev-????.zip and gtk+-dev-????.zip from
+ http://www.gimp.org/~tml/gimp/win32/
+ Do not forget to get also extralibs-dev-????.zip, since you will
+ need some of the DLLs.
+
+ Edit config.make.nt, then, using Visual C++,
+ nmake -f Makefile.nt
+ nmake -f Makefile.nt opt (if you have an MS Assembler)
+ Then install with
+ nmake -f Makefile.nt install
+
+ Since the link is dynamic you will also need to have in your path:
+ gnu-intl.dll (extralibs), glib-1.3.dll, module-1.3.dll and
+ gthread-1.3.dll (glib), gdk-1.3.dll and gtk-1.3.dll (gtk+).
+
+ I checked with the 2000-02-02 version of these libraries.
+ Currently threads do not seem to work, but otherwise everything
+ seems OK. In particular, you can run all examples, and build
+ applications\unison as usual.
+
+Authors:
+ Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
+ Hubert Fauque <hubert.fauque@wanadoo.fr>
+ Jun Furuse <Jun.Furuse@inria.fr>
+ Koji Kagawa <kagawa@eng.kagawa-u.ac.jp>
+
+Bug reports:
+ Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
+
+$Id$
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkBin
+open GObj
+open GContainer
+
+class scrolled_window obj = object
+ inherit container_full (obj : Gtk.scrolled_window obj)
+ method hadjustment =
+ new GData.adjustment (ScrolledWindow.get_hadjustment obj)
+ method vadjustment =
+ new GData.adjustment (ScrolledWindow.get_vadjustment obj)
+ method set_hadjustment adj =
+ ScrolledWindow.set_hadjustment obj (GData.as_adjustment adj)
+ method set_vadjustment adj =
+ ScrolledWindow.set_vadjustment obj (GData.as_adjustment adj)
+ method set_hpolicy hpolicy = ScrolledWindow.set_policy' obj ~hpolicy
+ method set_vpolicy vpolicy = ScrolledWindow.set_policy' obj ~vpolicy
+ method set_placement = ScrolledWindow.set_placement obj
+ method add_with_viewport w =
+ ScrolledWindow.add_with_viewport obj (as_widget w)
+end
+
+let scrolled_window ?hadjustment ?vadjustment ?hpolicy ?vpolicy
+ ?placement ?border_width ?width ?height ?packing ?show () =
+ let w =
+ ScrolledWindow.create ()
+ ?hadjustment:(may_map ~f:GData.as_adjustment hadjustment)
+ ?vadjustment:(may_map ~f:GData.as_adjustment vadjustment) in
+ ScrolledWindow.set w ?hpolicy ?vpolicy ?placement;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new scrolled_window w) ~packing ~show
+
+class event_box obj = object
+ inherit container_full (obj : Gtk.event_box obj)
+ method event = new GObj.event_ops obj
+end
+
+let event_box ?border_width ?width ?height ?packing ?show () =
+ let w = EventBox.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new event_box w) ~packing ~show
+
+class handle_box_signals obj = object
+ inherit container_signals obj
+ method child_attached ~callback =
+ GtkSignal.connect ~sgn:HandleBox.Signals.child_attached obj ~after
+ ~callback:(fun obj -> callback (new widget obj))
+ method child_detached ~callback =
+ GtkSignal.connect ~sgn:HandleBox.Signals.child_detached obj ~after
+ ~callback:(fun obj -> callback (new widget obj))
+end
+
+class handle_box obj = object
+ inherit container (obj : Gtk.handle_box obj)
+ method set_shadow_type = HandleBox.set_shadow_type obj
+ method set_handle_position = HandleBox.set_handle_position obj
+ method set_snap_edge = HandleBox.set_snap_edge obj
+ method connect = new handle_box_signals obj
+ method event = new GObj.event_ops obj
+end
+
+let handle_box ?border_width ?width ?height ?packing ?show () =
+ let w = HandleBox.create () in
+ let () = Container.set w ?border_width ?width ?height in
+ pack_return (new handle_box w) ~packing ~show
+
+class frame_skel obj = object
+ inherit container obj
+ method set_label = Frame.set_label obj
+ method set_label_align ?x ?y () = Frame.set_label_align' obj ?x ?y
+ method set_shadow_type = Frame.set_shadow_type obj
+end
+
+class frame obj = object
+ inherit frame_skel (Frame.coerce obj)
+ method connect = new container_signals obj
+end
+
+let frame ?(label="") ?label_xalign ?label_yalign ?shadow_type
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Frame.create label in
+ Frame.set w ?label_xalign ?label_yalign ?shadow_type;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new frame w) ~packing ~show
+
+class aspect_frame obj = object
+ inherit frame_skel (obj : Gtk.aspect_frame obj)
+ method connect = new container_signals obj
+ method set_alignment ?x ?y () = AspectFrame.set obj ?xalign:x ?yalign:y
+ method set_ratio ratio = AspectFrame.set obj ~ratio
+ method set_obey_child obey_child = AspectFrame.set obj ~obey_child
+end
+
+let aspect_frame ?label ?xalign ?yalign ?ratio ?obey_child
+ ?label_xalign ?label_yalign ?shadow_type
+ ?border_width ?width ?height ?packing ?show () =
+ let w =
+ AspectFrame.create ?label ?xalign ?yalign ?ratio ?obey_child () in
+ Frame.set w ?label_xalign ?label_yalign ?shadow_type;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new aspect_frame w) ~packing ~show
+
+class viewport obj = object
+ inherit container_full (obj : Gtk.viewport obj)
+ method event = new event_ops obj
+ method set_hadjustment adj =
+ Viewport.set_hadjustment obj (GData.as_adjustment adj)
+ method set_vadjustment adj =
+ Viewport.set_vadjustment obj (GData.as_adjustment adj)
+ method set_shadow_type = Viewport.set_shadow_type obj
+ method hadjustment = new GData.adjustment (Viewport.get_hadjustment obj)
+ method vadjustment = new GData.adjustment (Viewport.get_vadjustment obj)
+end
+
+let viewport ?hadjustment ?vadjustment ?shadow_type
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Viewport.create ()
+ ?hadjustment:(may_map ~f:GData.as_adjustment hadjustment)
+ ?vadjustment:(may_map ~f:GData.as_adjustment vadjustment) in
+ may shadow_type ~f:(Viewport.set_shadow_type w);
+ Container.set w ?border_width ?width ?height;
+ pack_return (new viewport w) ~packing ~show
+
+class alignment obj = object
+ inherit container_full (obj : Gtk.alignment obj)
+ method set_alignment ?x ?y () = Alignment.set ?x ?y obj
+ method set_scale ?x ?y () = Alignment.set ?xscale:x ?yscale:y obj
+end
+
+let alignment ?x ?y ?xscale ?yscale
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Alignment.create ?x ?y ?xscale ?yscale () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new alignment w) ~packing ~show
+
+let alignment_cast w = new alignment (Alignment.cast w#as_widget)
+
+class socket obj = object (self)
+ inherit container_full (obj : Gtk.socket obj)
+ method steal = Socket.steal obj
+ method xwindow =
+ self#misc#realize ();
+ Gdk.Window.get_xwindow self#misc#window
+end
+
+let socket ?border_width ?width ?height ?packing ?show () =
+ let w = Socket.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new socket w) ?packing ?show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class scrolled_window : Gtk.scrolled_window obj ->
+ object
+ inherit container_full
+ val obj : Gtk.scrolled_window obj
+ method add_with_viewport : widget -> unit
+ method hadjustment : GData.adjustment
+ method set_hadjustment : GData.adjustment -> unit
+ method set_hpolicy : Tags.policy_type -> unit
+ method set_placement : Tags.corner_type -> unit
+ method set_vadjustment : GData.adjustment -> unit
+ method set_vpolicy : Tags.policy_type -> unit
+ method vadjustment : GData.adjustment
+ end
+val scrolled_window :
+ ?hadjustment:GData.adjustment ->
+ ?vadjustment:GData.adjustment ->
+ ?hpolicy:Tags.policy_type ->
+ ?vpolicy:Tags.policy_type ->
+ ?placement:Tags.corner_type ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> scrolled_window
+
+class event_box : Gtk.event_box obj ->
+ object
+ inherit container_full
+ val obj : Gtk.event_box obj
+ method event : event_ops
+ end
+val event_box :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> event_box
+
+class handle_box_signals : 'a obj ->
+ object
+ inherit container_signals
+ constraint 'a = [>`handlebox|`container|`widget]
+ val obj : 'a obj
+ method child_attached : callback:(widget -> unit) -> GtkSignal.id
+ method child_detached : callback:(widget -> unit) -> GtkSignal.id
+ end
+
+class handle_box : Gtk.handle_box obj ->
+ object
+ inherit container
+ val obj : Gtk.handle_box obj
+ method event : event_ops
+ method connect : handle_box_signals
+ method set_handle_position : Tags.position -> unit
+ method set_shadow_type : Tags.shadow_type -> unit
+ method set_snap_edge : Tags.position -> unit
+ end
+val handle_box :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> handle_box
+
+class frame_skel : 'a obj ->
+ object
+ inherit container
+ constraint 'a = [>`frame|`container|`widget]
+ val obj : 'a obj
+ method set_label : string -> unit
+ method set_label_align : ?x:clampf -> ?y:clampf -> unit -> unit
+ method set_shadow_type : Tags.shadow_type -> unit
+ end
+class frame : [>`frame] obj ->
+ object
+ inherit frame_skel
+ val obj : Gtk.frame obj
+ method connect : GContainer.container_signals
+ end
+val frame :
+ ?label:string ->
+ ?label_xalign:clampf ->
+ ?label_yalign:clampf ->
+ ?shadow_type:Tags.shadow_type ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> frame
+
+class aspect_frame : Gtk.aspect_frame obj ->
+ object
+ inherit frame
+ val obj : Gtk.aspect_frame obj
+ method set_alignment : ?x:clampf -> ?y:clampf -> unit -> unit
+ method set_obey_child : bool -> unit
+ method set_ratio : clampf -> unit
+ end
+val aspect_frame :
+ ?label:string ->
+ ?xalign:clampf ->
+ ?yalign:clampf ->
+ ?ratio:float ->
+ ?obey_child:bool ->
+ ?label_xalign:clampf ->
+ ?label_yalign:clampf ->
+ ?shadow_type:Tags.shadow_type ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> aspect_frame
+
+class viewport : Gtk.viewport obj ->
+ object
+ inherit container_full
+ val obj : Gtk.viewport obj
+ method event : event_ops
+ method hadjustment : GData.adjustment
+ method set_hadjustment : GData.adjustment -> unit
+ method set_shadow_type : Gtk.Tags.shadow_type -> unit
+ method set_vadjustment : GData.adjustment -> unit
+ method vadjustment : GData.adjustment
+ end
+val viewport :
+ ?hadjustment:GData.adjustment ->
+ ?vadjustment:GData.adjustment ->
+ ?shadow_type:Tags.shadow_type ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> viewport
+
+class alignment : Gtk.alignment obj ->
+ object
+ inherit container_full
+ val obj : Gtk.alignment obj
+ method set_alignment : ?x:Gtk.clampf -> ?y:Gtk.clampf -> unit -> unit
+ method set_scale : ?x:Gtk.clampf -> ?y:Gtk.clampf -> unit -> unit
+ end
+val alignment :
+ ?x:Gtk.clampf ->
+ ?y:Gtk.clampf ->
+ ?xscale:Gtk.clampf ->
+ ?yscale:Gtk.clampf ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> alignment
+val alignment_cast : < as_widget : 'a obj; .. > -> alignment
+
+class socket : Gtk.socket obj ->
+ object
+ inherit container_full
+ val obj : Gtk.socket obj
+ method steal : Gdk.xid -> unit
+ method xwindow : Gdk.xid
+ end
+
+val socket :
+ ?border_width:int -> ?width:int -> ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> socket
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkButton
+open GObj
+open GContainer
+
+class button_skel obj = object (self)
+ inherit container obj
+ method clicked () = Button.clicked obj
+ method grab_default () =
+ Widget.set_can_default obj true;
+ Widget.grab_default obj
+end
+
+class button_signals obj = object
+ inherit container_signals obj
+ method clicked = GtkSignal.connect ~sgn:Button.Signals.clicked ~after obj
+ method pressed = GtkSignal.connect ~sgn:Button.Signals.pressed ~after obj
+ method released = GtkSignal.connect ~sgn:Button.Signals.released ~after obj
+ method enter = GtkSignal.connect ~sgn:Button.Signals.enter ~after obj
+ method leave = GtkSignal.connect ~sgn:Button.Signals.leave ~after obj
+end
+
+class button obj = object
+ inherit button_skel (Button.coerce obj)
+ method connect = new button_signals obj
+ method event = new GObj.event_ops obj
+end
+
+let button ?label ?border_width ?width ?height ?packing ?show () =
+ let w = Button.create ?label () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new button w) ~packing ~show
+
+class toggle_button_signals obj = object
+ inherit button_signals obj
+ method toggled =
+ GtkSignal.connect ~sgn:ToggleButton.Signals.toggled obj ~after
+end
+
+class toggle_button obj = object
+ inherit button_skel obj
+ method connect = new toggle_button_signals obj
+ method active = ToggleButton.get_active obj
+ method set_active = ToggleButton.set_active obj
+ method set_draw_indicator = ToggleButton.set_mode obj
+end
+
+let toggle_button ?label ?active ?draw_indicator
+ ?border_width ?width ?height ?packing ?show () =
+ let w = ToggleButton.create_toggle ?label () in
+ ToggleButton.set w ?active ?draw_indicator;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new toggle_button w) ~packing ~show
+
+let check_button ?label ?active ?draw_indicator
+ ?border_width ?width ?height ?packing ?show () =
+ let w = ToggleButton.create_check ?label () in
+ ToggleButton.set w ?active ?draw_indicator;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new toggle_button w) ~packing ~show
+
+class radio_button obj = object
+ inherit toggle_button (obj : Gtk.radio_button obj)
+ method set_group = RadioButton.set_group obj
+ method group = Some obj
+end
+
+let radio_button ?group ?label ?active ?draw_indicator
+ ?border_width ?width ?height ?packing ?show () =
+ let w = RadioButton.create ?group ?label () in
+ ToggleButton.set w ?active ?draw_indicator;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new radio_button w) ~packing ~show
+
+class toolbar obj = object
+ inherit container_full (obj : Gtk.toolbar obj)
+ method insert_widget ?tooltip ?tooltip_private ?pos w =
+ Toolbar.insert_widget obj (as_widget w) ?tooltip ?tooltip_private ?pos
+
+ method insert_button ?text ?tooltip ?tooltip_private ?icon
+ ?pos ?callback () =
+ let icon = may_map icon ~f:as_widget in
+ new button
+ (Toolbar.insert_button obj ~kind:`BUTTON ?icon ?text
+ ?tooltip ?tooltip_private ?pos ?callback ())
+
+ method insert_toggle_button ?text ?tooltip ?tooltip_private ?icon
+ ?pos ?callback () =
+ let icon = may_map icon ~f:as_widget in
+ new toggle_button
+ (ToggleButton.cast
+ (Toolbar.insert_button obj ~kind:`TOGGLEBUTTON ?icon ?text
+ ?tooltip ?tooltip_private ?pos ?callback ()))
+
+ method insert_radio_button ?text ?tooltip ?tooltip_private ?icon
+ ?pos ?callback () =
+ let icon = may_map icon ~f:as_widget in
+ new radio_button
+ (RadioButton.cast
+ (Toolbar.insert_button obj ~kind:`RADIOBUTTON ?icon ?text
+ ?tooltip ?tooltip_private ?pos ?callback ()))
+
+ method insert_space = Toolbar.insert_space obj
+
+ method set_orientation = Toolbar.set_orientation obj
+ method set_style = Toolbar.set_style obj
+ method set_space_size = Toolbar.set_space_size obj
+ method set_space_style = Toolbar.set_space_style obj
+ method set_tooltips = Toolbar.set_tooltips obj
+ method set_button_relief = Toolbar.set_button_relief obj
+ method button_relief = Toolbar.get_button_relief obj
+end
+
+let toolbar ?(orientation=`HORIZONTAL) ?style
+ ?space_size ?space_style ?tooltips ?button_relief
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Toolbar.create orientation ?style () in
+ Toolbar.set w ?space_size ?space_style ?tooltips ?button_relief;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new toolbar w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class button_skel :
+ 'a obj ->
+ object
+ inherit container
+ constraint 'a = [>`widget|`button|`container]
+ val obj : 'a obj
+ method clicked : unit -> unit
+ method grab_default : unit -> unit
+ end
+class button_signals :
+ 'b obj ->
+ object ('a)
+ inherit container_signals
+ constraint 'b = [>`button|`container|`widget]
+ val obj : 'b obj
+ method clicked : callback:(unit -> unit) -> GtkSignal.id
+ method enter : callback:(unit -> unit) -> GtkSignal.id
+ method leave : callback:(unit -> unit) -> GtkSignal.id
+ method pressed : callback:(unit -> unit) -> GtkSignal.id
+ method released : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class button :
+ [>`button] obj ->
+ object
+ inherit button_skel
+ val obj : Gtk.button obj
+ method event : event_ops
+ method connect : button_signals
+ end
+val button :
+ ?label:string ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> button
+
+class toggle_button_signals :
+ 'b obj ->
+ object ('a)
+ inherit button_signals
+ constraint 'b = [>`toggle|`button|`container|`widget]
+ val obj : 'b obj
+ method toggled : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class toggle_button :
+ 'a obj ->
+ object
+ inherit button_skel
+ constraint 'a = [>`toggle|`button|`container|`widget]
+ val obj : 'a obj
+ method active : bool
+ method connect : toggle_button_signals
+ method set_active : bool -> unit
+ method set_draw_indicator : bool -> unit
+ end
+val toggle_button :
+ ?label:string ->
+ ?active:bool ->
+ ?draw_indicator:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> toggle_button
+val check_button :
+ ?label:string ->
+ ?active:bool ->
+ ?draw_indicator:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> toggle_button
+
+class radio_button :
+ Gtk.radio_button obj ->
+ object
+ inherit toggle_button
+ val obj : Gtk.radio_button obj
+ method group : Gtk.radio_button group
+ method set_group : Gtk.radio_button group -> unit
+ end
+val radio_button :
+ ?group:Gtk.radio_button group ->
+ ?label:string ->
+ ?active:bool ->
+ ?draw_indicator:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> radio_button
+
+class toolbar :
+ Gtk.toolbar obj ->
+ object
+ inherit container_full
+ val obj : Gtk.toolbar obj
+ method button_relief : Tags.relief_style
+ method insert_button :
+ ?text:string ->
+ ?tooltip:string ->
+ ?tooltip_private:string ->
+ ?icon:widget ->
+ ?pos:int -> ?callback:(unit -> unit) -> unit -> button
+ method insert_radio_button :
+ ?text:string ->
+ ?tooltip:string ->
+ ?tooltip_private:string ->
+ ?icon:widget ->
+ ?pos:int -> ?callback:(unit -> unit) -> unit -> radio_button
+ method insert_space : ?pos:int -> unit -> unit
+ method insert_toggle_button :
+ ?text:string ->
+ ?tooltip:string ->
+ ?tooltip_private:string ->
+ ?icon:widget ->
+ ?pos:int -> ?callback:(unit -> unit) -> unit -> toggle_button
+ method insert_widget :
+ ?tooltip:string ->
+ ?tooltip_private:string -> ?pos:int -> widget -> unit
+ method set_button_relief : Tags.relief_style -> unit
+ method set_orientation : Tags.orientation -> unit
+ method set_space_size : int -> unit
+ method set_space_style : [`EMPTY|`LINE] -> unit
+ method set_style : Tags.toolbar_style -> unit
+ method set_tooltips : bool -> unit
+ end
+val toolbar :
+ ?orientation:Tags.orientation ->
+ ?style:Tags.toolbar_style ->
+ ?space_size:int ->
+ ?space_style:[`EMPTY|`LINE] ->
+ ?tooltips:bool ->
+ ?button_relief:Tags.relief_style ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> toolbar
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GObj
+open GData
+
+class focus obj = object
+ val obj = obj
+ method circulate = Container.focus obj
+ method set (child : widget option) =
+ let child = may_map child ~f:(fun x -> x#as_widget) in
+ Container.set_focus_child obj (Gpointer.optboxed child)
+ method set_hadjustment adj =
+ Container.set_focus_hadjustment obj
+ (Gpointer.optboxed (may_map adj ~f:as_adjustment))
+ method set_vadjustment adj =
+ Container.set_focus_vadjustment obj
+ (Gpointer.optboxed (may_map adj ~f:as_adjustment))
+end
+
+class container obj = object (self)
+ inherit widget obj
+ method add w =
+ (* Hack to avoid creating a bin class *)
+ if GtkBase.Object.is_a obj "GtkBin" && Container.children obj <> [] then
+ raise (Gtk.Error "GContainer.container#add: already full");
+ Container.add obj (as_widget w)
+ method remove w = Container.remove obj (as_widget w)
+ method children = List.map ~f:(new widget) (Container.children obj)
+ method set_border_width = Container.set_border_width obj
+ method focus = new focus obj
+end
+
+class container_signals obj = object
+ inherit widget_signals obj
+ method add ~callback =
+ GtkSignal.connect ~sgn:Container.Signals.add obj ~after
+ ~callback:(fun w -> callback (new widget w))
+ method remove ~callback =
+ GtkSignal.connect ~sgn:Container.Signals.remove obj ~after
+ ~callback:(fun w -> callback (new widget w))
+end
+
+class container_full obj = object
+ inherit container obj
+ method connect = new container_signals obj
+end
+
+let cast_container (w : widget) =
+ new container_full (GtkBase.Container.cast w#as_widget)
+
+class virtual ['a] item_container obj = object (self)
+ inherit widget obj
+ method add (w : 'a) =
+ Container.add obj w#as_item
+ method remove (w : 'a) =
+ Container.remove obj w#as_item
+ method private virtual wrap : Gtk.widget obj -> 'a
+ method children : 'a list =
+ List.map ~f:self#wrap (Container.children obj)
+ method set_border_width = Container.set_border_width obj
+ method focus = new focus obj
+ method virtual insert : 'a -> pos:int -> unit
+ method append (w : 'a) = self#insert w ~pos:(-1)
+ method prepend (w : 'a) = self#insert w ~pos:0
+end
+
+class item_signals obj = object
+ inherit container_signals obj
+ method select = GtkSignal.connect ~sgn:Item.Signals.select obj ~after
+ method deselect = GtkSignal.connect ~sgn:Item.Signals.deselect obj ~after
+ method toggle = GtkSignal.connect ~sgn:Item.Signals.toggle obj ~after
+end
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+class focus :
+ 'a obj ->
+ object
+ constraint 'a = [>`container]
+ val obj : 'a obj
+ method circulate : Tags.direction_type -> bool
+ method set : widget option -> unit
+ method set_hadjustment : GData.adjustment option -> unit
+ method set_vadjustment : GData.adjustment option -> unit
+ end
+
+class container :
+ 'a obj ->
+ object
+ inherit widget
+ constraint 'a = [>`container|`widget]
+ val obj : 'a obj
+ method add : widget -> unit
+ method children : widget list
+ method remove : widget -> unit
+ method focus : focus
+ method set_border_width : int -> unit
+ end
+
+class container_signals :
+ 'a obj ->
+ object
+ inherit widget_signals
+ constraint 'a = [>`container|`widget]
+ val obj : 'a obj
+ method add : callback:(widget -> unit) -> GtkSignal.id
+ method remove : callback:(widget -> unit) -> GtkSignal.id
+ end
+
+class container_full :
+ 'a obj ->
+ object
+ inherit container
+ constraint 'a = [>`container|`widget]
+ val obj : 'a obj
+ method connect : container_signals
+ end
+
+val cast_container : widget -> container_full
+(* may raise [Gtk.Cannot_cast "GtkContainer"] *)
+
+class virtual ['a] item_container :
+ 'c obj ->
+ object
+ constraint 'a = < as_item : [>`widget] obj; .. >
+ constraint 'c = [>`container|`widget]
+ inherit widget
+ val obj : 'c obj
+ method add : 'a -> unit
+ method append : 'a -> unit
+ method children : 'a list
+ method virtual insert : 'a -> pos:int -> unit
+ method prepend : 'a -> unit
+ method remove : 'a -> unit
+ method focus : focus
+ method set_border_width : int -> unit
+ method private virtual wrap : Gtk.widget obj -> 'a
+ end
+
+class item_signals :
+ 'a obj ->
+ object
+ inherit container_signals
+ constraint 'a = [>`container|`item|`widget]
+ val obj : 'a obj
+ method deselect : callback:(unit -> unit) -> GtkSignal.id
+ method select : callback:(unit -> unit) -> GtkSignal.id
+ method toggle : callback:(unit -> unit) -> GtkSignal.id
+ end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkData
+open GObj
+
+class data_signals obj = object
+ inherit gtkobj_signals obj
+ method disconnect_data =
+ GtkSignal.connect ~sgn:Data.Signals.disconnect obj ~after
+end
+
+class adjustment_signals obj = object
+ inherit data_signals obj
+ method changed = GtkSignal.connect ~sgn:Adjustment.Signals.changed obj ~after
+ method value_changed =
+ GtkSignal.connect ~sgn:Adjustment.Signals.value_changed obj ~after
+end
+
+class adjustment obj = object
+ inherit gtkobj obj
+ method as_adjustment : Gtk.adjustment obj = obj
+ method connect = new adjustment_signals obj
+ method set_value = Adjustment.set_value obj
+ method clamp_page = Adjustment.clamp_page obj
+ method lower = Adjustment.get_lower obj
+ method upper = Adjustment.get_upper obj
+ method value = Adjustment.get_value obj
+ method step_increment = Adjustment.get_step_increment obj
+ method page_increment = Adjustment.get_page_increment obj
+ method page_size = Adjustment.get_page_size obj
+end
+
+let adjustment ?(value=0.) ?(lower=0.) ?(upper=100.)
+ ?(step_incr=1.) ?(page_incr=10.) ?(page_size=10.) () =
+ let w =
+ Adjustment.create ~value ~lower ~upper ~step_incr ~page_incr ~page_size in
+ new adjustment w
+
+let as_adjustment (adj : adjustment) = adj#as_adjustment
+
+class tooltips obj = object
+ inherit gtkobj (obj : Gtk.tooltips obj)
+ method as_tooltips = obj
+ method connect = new data_signals obj
+ method enable () = Tooltips.enable obj
+ method disable () = Tooltips.disable obj
+ method set_tip ?text ?privat w =
+ Tooltips.set_tip obj (as_widget w) ?text ?privat
+ method set_delay = Tooltips.set_delay obj
+end
+
+let tooltips ?delay () =
+ let tt = Tooltips.create () in
+ Tooltips.set tt ?delay;
+ new tooltips tt
+
+
+
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+class data_signals :
+ 'a obj ->
+ object
+ inherit GObj.gtkobj_signals
+ constraint 'a = [>`data]
+ val obj : 'a obj
+ method disconnect_data : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class adjustment_signals :
+ 'a obj ->
+ object
+ inherit data_signals
+ constraint 'a = [>`adjustment|`data]
+ val obj : 'a obj
+ method changed : callback:(unit -> unit) -> GtkSignal.id
+ method value_changed : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class adjustment : Gtk.adjustment obj ->
+ object
+ inherit GObj.gtkobj
+ val obj : Gtk.adjustment obj
+ method as_adjustment : Gtk.adjustment obj
+ method clamp_page : lower:float -> upper:float -> unit
+ method connect : adjustment_signals
+ method set_value : float -> unit
+ method lower : float
+ method upper : float
+ method value : float
+ method step_increment : float
+ method page_increment : float
+ method page_size : float
+ end
+val adjustment :
+ ?value:float ->
+ ?lower:float ->
+ ?upper:float ->
+ ?step_incr:float ->
+ ?page_incr:float -> ?page_size:float -> unit -> adjustment
+
+val as_adjustment : adjustment -> Gtk.adjustment obj
+
+class tooltips :
+ Gtk.tooltips obj ->
+ object
+ inherit GObj.gtkobj
+ val obj : Gtk.tooltips obj
+ method as_tooltips : Gtk.tooltips obj
+ method connect : data_signals
+ method disable : unit -> unit
+ method enable : unit -> unit
+ method set_delay : int -> unit
+ method set_tip : ?text:string -> ?privat:string -> GObj.widget -> unit
+ end
+val tooltips : ?delay:int -> unit -> tooltips
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gdk
+
+type color = [
+ | `COLOR of Color.t
+ | `WHITE
+ | `BLACK
+ | `NAME of string
+ | `RGB of int * int * int
+]
+
+let default_colormap = GtkBase.Widget.get_default_colormap
+
+let color ?(colormap = default_colormap ()) (c : color) =
+ match c with
+ | `COLOR col -> col
+ | #Gdk.Color.spec as def -> Color.alloc ~colormap def
+
+type optcolor = [
+ | `COLOR of Color.t
+ | `WHITE
+ | `BLACK
+ | `NAME of string
+ | `RGB of int * int * int
+ | `DEFAULT
+]
+
+let optcolor ?colormap (c : optcolor) =
+ match c with
+ | `DEFAULT -> None
+ | #color as c -> Some (color ?colormap c)
+
+class ['a] drawable ?(colormap = default_colormap ()) w =
+object (self)
+ val colormap = colormap
+ val gc = GC.create w
+ val w : 'a Gdk.drawable = w
+ method color = color ~colormap
+ method set_foreground col = GC.set_foreground gc (self#color col)
+ method set_background col = GC.set_background gc (self#color col)
+ method gc_values = GC.get_values gc
+ method set_clip_region region = GC.set_clip_region gc region
+ method set_line_attributes ?width ?style ?cap ?join () =
+ let v = GC.get_values gc in
+ GC.set_line_attributes gc
+ ~width:(default v.GC.line_width ~opt:width)
+ ~style:(default v.GC.line_style ~opt:style)
+ ~cap:(default v.GC.cap_style ~opt:cap)
+ ~join:(default v.GC.join_style ~opt:join)
+ method point = Draw.point w gc
+ method line = Draw.line w gc
+ method rectangle = Draw.rectangle w gc
+ method arc = Draw.arc w gc
+ method polygon ?filled l = Draw.polygon w gc ?filled l
+ method string s = Draw.string w gc ~string:s
+ method image ~width ~height ?(xsrc=0) ?(ysrc=0) ?(xdest=0) ?(ydest=0) image =
+ Draw.image w gc ~image ~width ~height ~xsrc ~ysrc ~xdest ~ydest
+end
+
+class pixmap ?colormap ?mask pm = object
+ inherit [[`pixmap]] drawable ?colormap pm as pixmap
+ val bitmap = may_map mask ~f:
+ begin fun x ->
+ let mask = new drawable x in
+ mask#set_foreground `WHITE;
+ mask
+ end
+ val mask : Gdk.bitmap option = mask
+ method pixmap = w
+ method mask = mask
+ method set_line_attributes ?width ?style ?cap ?join () =
+ pixmap#set_line_attributes ?width ?style ?cap ?join ();
+ may bitmap ~f:(fun m -> m#set_line_attributes ?width ?style ?cap ?join ())
+ method point ~x ~y =
+ pixmap#point ~x ~y;
+ may bitmap ~f:(fun m -> m#point ~x ~y)
+ method line ~x ~y ~x:x' ~y:y' =
+ pixmap#line ~x ~y ~x:x' ~y:y';
+ may bitmap ~f:(fun m -> m#line ~x ~y ~x:x' ~y:y')
+ method rectangle ~x ~y ~width ~height ?filled () =
+ pixmap#rectangle ~x ~y ~width ~height ?filled ();
+ may bitmap ~f:(fun m -> m#rectangle ~x ~y ~width ~height ?filled ())
+ method arc ~x ~y ~width ~height ?filled ?start ?angle () =
+ pixmap#arc ~x ~y ~width ~height ?filled ?start ?angle ();
+ may bitmap
+ ~f:(fun m -> m#arc ~x ~y ~width ~height ?filled ?start ?angle ());
+ method polygon ?filled l =
+ pixmap#polygon ?filled l;
+ may bitmap ~f:(fun m -> m#polygon ?filled l)
+ method string s ~font ~x ~y =
+ pixmap#string s ~font ~x ~y;
+ may bitmap ~f:(fun m -> m#string s ~font ~x ~y)
+end
+
+class type misc_ops = object
+ method allocation : Gtk.rectangle
+ method colormap : colormap
+ method draw : Rectangle.t option -> unit
+ method hide : unit -> unit
+ method hide_all : unit -> unit
+ method intersect : Rectangle.t -> Rectangle.t option
+ method pointer : int * int
+ method realize : unit -> unit
+ method set_app_paintable : bool -> unit
+ method set_geometry :
+ ?x:int -> ?y:int -> ?width:int -> ?height:int -> unit -> unit
+ method show : unit -> unit
+ method unmap : unit -> unit
+ method unparent : unit -> unit
+ method unrealize : unit -> unit
+ method visible : bool
+ method visual : visual
+ method visual_depth : int
+ method window : window
+end
+
+let pixmap ~(window : < misc : #misc_ops; .. >)
+ ~width ~height ?(mask=false) () =
+ window#misc#realize ();
+ let window =
+ try window#misc#window
+ with Gpointer.Null -> failwith "GDraw.pixmap : no window"
+ and depth = window#misc#visual_depth
+ and colormap = window#misc#colormap in
+ let mask =
+ if not mask then None else
+ let bm = Bitmap.create window ~width ~height in
+ let mask = new drawable bm in
+ mask#set_foreground `BLACK;
+ mask#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+ Some bm
+ in
+ new pixmap (Pixmap.create window ~width ~height ~depth) ~colormap ?mask
+
+let pixmap_from_xpm ~window ~file ?colormap ?transparent () =
+ window#misc#realize ();
+ let window =
+ try window#misc#window
+ with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm : no window" in
+ let pm, mask =
+ try Pixmap.create_from_xpm window ~file ?colormap
+ ?transparent:(may_map transparent ~f:(fun c -> color c))
+ with Gpointer.Null -> invalid_arg ("GDraw.pixmap_from_xpm : " ^ file) in
+ new pixmap pm ?colormap ~mask
+
+let pixmap_from_xpm_d ~window ~data ?colormap ?transparent () =
+ window#misc#realize ();
+ let window =
+ try window#misc#window
+ with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm_d : no window" in
+ let pm, mask =
+ Pixmap.create_from_xpm_d window ~data ?colormap
+ ?transparent:(may_map transparent ~f:(fun c -> color c)) in
+ new pixmap pm ?colormap ~mask
+
+class drag_context context = object
+ val context = context
+ method status ?(time=0) act = DnD.drag_status context act ~time
+ method suggested_action = DnD.drag_context_suggested_action context
+ method targets = DnD.drag_context_targets context
+end
--- /dev/null
+(* $Id$ *)
+
+open Gdk
+
+type color =
+ [ `COLOR of Color.t
+ | `WHITE
+ | `BLACK
+ | `NAME of string
+ | `RGB of int * int * int]
+
+val color : ?colormap:colormap -> color -> Color.t
+
+type optcolor =
+ [ `COLOR of Color.t
+ | `WHITE
+ | `BLACK
+ | `NAME of string
+ | `RGB of int * int * int
+ | `DEFAULT ]
+
+val optcolor : ?colormap:colormap -> optcolor -> Color.t option
+
+class ['a] drawable : ?colormap:colormap -> 'a Gdk.drawable ->
+ object
+ val gc : gc
+ val w : 'a Gdk.drawable
+ method arc :
+ x:int ->
+ y:int ->
+ width:int ->
+ height:int ->
+ ?filled:bool -> ?start:float -> ?angle:float -> unit -> unit
+ method color : color -> Color.t
+ method gc_values : GC.values
+ method image :
+ width:int ->
+ height:int ->
+ ?xsrc:int -> ?ysrc:int -> ?xdest:int -> ?ydest:int -> image -> unit
+ method line : x:int -> y:int -> x:int -> y:int -> unit
+ method point : x:int -> y:int -> unit
+ method polygon : ?filled:bool -> (int * int) list -> unit
+ method rectangle :
+ x:int ->
+ y:int -> width:int -> height:int -> ?filled:bool -> unit -> unit
+ method set_background : color -> unit
+ method set_foreground : color -> unit
+ method set_clip_region : region -> unit
+ method set_line_attributes :
+ ?width:int ->
+ ?style:GC.gdkLineStyle ->
+ ?cap:GC.gdkCapStyle -> ?join:GC.gdkJoinStyle -> unit -> unit
+ method string : string -> font:font -> x:int -> y:int -> unit
+ end
+
+class pixmap :
+ ?colormap:colormap -> ?mask:bitmap -> [ `pixmap] Gdk.drawable ->
+ object
+ inherit [[`pixmap]] drawable
+ val bitmap : [ `bitmap] drawable option
+ val mask : bitmap option
+ method mask : bitmap option
+ method pixmap : Gdk.pixmap
+ end
+
+class type misc_ops =
+ object
+ method allocation : Gtk.rectangle
+ method colormap : colormap
+ method draw : Rectangle.t option -> unit
+ method hide : unit -> unit
+ method hide_all : unit -> unit
+ method intersect : Rectangle.t -> Rectangle.t option
+ method pointer : int * int
+ method realize : unit -> unit
+ method set_app_paintable : bool -> unit
+ method set_geometry :
+ ?x:int -> ?y:int -> ?width:int -> ?height:int -> unit -> unit
+ method show : unit -> unit
+ method unmap : unit -> unit
+ method unparent : unit -> unit
+ method unrealize : unit -> unit
+ method visible : bool
+ method visual : visual
+ method visual_depth : int
+ method window : window
+ end
+
+val pixmap :
+ window:< misc : #misc_ops; .. > ->
+ width:int -> height:int -> ?mask:bool -> unit -> pixmap
+val pixmap_from_xpm :
+ window:< misc : #misc_ops; .. > ->
+ file:string ->
+ ?colormap:colormap -> ?transparent:color -> unit -> pixmap
+val pixmap_from_xpm_d :
+ window:< misc : #misc_ops; .. > ->
+ data:string array ->
+ ?colormap:colormap -> ?transparent:color -> unit -> pixmap
+
+class drag_context : Gdk.drag_context ->
+ object
+ val context : Gdk.drag_context
+ method status : ?time:int -> Tags.drag_action list -> unit
+ method suggested_action : Tags.drag_action
+ method targets : atom list
+ end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkEdit
+open GObj
+
+class editable_signals obj = object
+ inherit widget_signals obj
+ method activate = GtkSignal.connect ~sgn:Editable.Signals.activate obj ~after
+ method changed = GtkSignal.connect ~sgn:Editable.Signals.changed obj ~after
+ method insert_text =
+ GtkSignal.connect ~sgn:Editable.Signals.insert_text obj ~after
+ method delete_text =
+ GtkSignal.connect ~sgn:Editable.Signals.delete_text obj ~after
+end
+
+class editable obj = object
+ inherit widget obj
+ method connect = new editable_signals obj
+ method select_region = Editable.select_region obj
+ method insert_text = Editable.insert_text obj
+ method delete_text = Editable.delete_text obj
+ method get_chars = Editable.get_chars obj
+ method cut_clipboard () = Editable.cut_clipboard obj
+ method copy_clipboard () = Editable.copy_clipboard obj
+ method paste_clipboard () = Editable.paste_clipboard obj
+ method delete_selection () = Editable.delete_selection obj
+ method set_position = Editable.set_position obj
+ method position = Editable.get_position obj
+ method set_editable = Editable.set_editable obj
+ method selection =
+ if Editable.has_selection obj then
+ Some (Editable.selection_start_pos obj, Editable.selection_end_pos obj)
+ else None
+end
+
+class entry obj = object
+ inherit editable obj
+ method event = new GObj.event_ops obj
+ method set_text = Entry.set_text obj
+ method append_text = Entry.append_text obj
+ method prepend_text = Entry.prepend_text obj
+ method set_visibility = Entry.set_visibility obj
+ method set_max_length = Entry.set_max_length obj
+ method text = Entry.get_text obj
+ method text_length = Entry.text_length obj
+end
+
+let set_editable ?editable ?(width = -2) ?(height = -2) w =
+ may editable ~f:(Editable.set_editable w);
+ if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
+
+let entry ?max_length ?text ?visibility ?editable
+ ?width ?height ?packing ?show () =
+ let w = Entry.create ?max_length () in
+ Entry.set w ?text ?visibility;
+ set_editable w ?editable ?width ?height;
+ pack_return (new entry w) ~packing ~show
+
+class spin_button obj = object
+ inherit entry (obj : Gtk.spin_button obj)
+ method adjustment = new GData.adjustment (SpinButton.get_adjustment obj)
+ method value = SpinButton.get_value obj
+ method value_as_int = SpinButton.get_value_as_int obj
+ method spin = SpinButton.spin obj
+ method update = SpinButton.update obj
+ method set_adjustment adj =
+ SpinButton.set_adjustment obj (GData.as_adjustment adj)
+ method set_digits = SpinButton.set_digits obj
+ method set_value = SpinButton.set_value obj
+ method set_update_policy = SpinButton.set_update_policy obj
+ method set_numeric = SpinButton.set_numeric obj
+ method set_wrap = SpinButton.set_wrap obj
+ method set_shadow_type = SpinButton.set_shadow_type obj
+ method set_snap_to_ticks = SpinButton.set_snap_to_ticks obj
+end
+
+let spin_button ?adjustment ?rate ?digits ?value ?update_policy
+ ?numeric ?wrap ?shadow_type ?snap_to_ticks
+ ?width ?height ?packing ?show () =
+ let w = SpinButton.create ?rate ?digits
+ ?adjustment:(may_map ~f:GData.as_adjustment adjustment) () in
+ SpinButton.set w ?value ?update_policy
+ ?numeric ?wrap ?shadow_type ?snap_to_ticks;
+ set_editable w ?width ?height;
+ pack_return (new spin_button w) ~packing ~show
+
+class combo obj = object
+ inherit GObj.widget (obj : Gtk.combo obj)
+ method entry = new entry (Combo.entry obj)
+ method list = new GList.liste (Combo.list obj)
+ method set_popdown_strings = Combo.set_popdown_strings obj
+ method set_use_arrows = Combo.set_use_arrows' obj
+ method set_case_sensitive = Combo.set_case_sensitive obj
+ method set_value_in_list = Combo.set_value_in_list obj
+ method disable_activate () = Combo.disable_activate obj
+ method set_item_string (item : GList.list_item) =
+ Combo.set_item_string obj item#as_item
+end
+
+let combo ?popdown_strings ?use_arrows
+ ?case_sensitive ?value_in_list ?ok_if_empty
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Combo.create () in
+ Combo.set w ?popdown_strings ?use_arrows
+ ?case_sensitive ?value_in_list ?ok_if_empty;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new combo w) ~packing ~show
+
+class text obj = object (self)
+ inherit editable (obj : Gtk.text obj) as super
+ method get_chars ~start ~stop:e =
+ if start < 0 || e > Text.get_length obj || e < start then
+ invalid_arg "GEdit.text#get_chars";
+ super#get_chars ~start ~stop:e
+ method event = new GObj.event_ops obj
+ method set_point = Text.set_point obj
+ method set_hadjustment adj =
+ Text.set_adjustment obj ~horizontal:(GData.as_adjustment adj) ()
+ method set_vadjustment adj =
+ Text.set_adjustment obj ~vertical:(GData.as_adjustment adj) ()
+ method set_word_wrap = Text.set_word_wrap obj
+ method set_line_wrap = Text.set_line_wrap obj
+ method hadjustment = new GData.adjustment (Text.get_hadjustment obj)
+ method vadjustment = new GData.adjustment (Text.get_vadjustment obj)
+ method point = Text.get_point obj
+ method length = Text.get_length obj
+ method freeze () = Text.freeze obj
+ method thaw () = Text.thaw obj
+ method insert ?font ?foreground ?background text =
+ let colormap = try Some self#misc#colormap with _ -> None in
+ Text.insert obj text ?font
+ ?foreground:(may_map foreground ~f:(GDraw.color ?colormap))
+ ?background:(may_map background ~f:(GDraw.color ?colormap))
+end
+
+let text ?hadjustment ?vadjustment ?editable
+ ?word_wrap ?line_wrap ?width ?height ?packing ?show () =
+ let w = Text.create ()
+ ?hadjustment:(may_map ~f:GData.as_adjustment hadjustment)
+ ?vadjustment:(may_map ~f:GData.as_adjustment vadjustment) in
+ may word_wrap ~f:(Text.set_word_wrap w);
+ may line_wrap ~f:(Text.set_line_wrap w);
+ set_editable w ?editable ?width ?height;
+ pack_return (new text w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+class editable_signals : 'a obj ->
+ object
+ inherit widget_signals
+ constraint 'a = [>`editable|`widget]
+ val obj : 'a obj
+ method activate : callback:(unit -> unit) -> GtkSignal.id
+ method changed : callback:(unit -> unit) -> GtkSignal.id
+ method delete_text :
+ callback:(start:int -> stop:int -> unit) -> GtkSignal.id
+ method insert_text :
+ callback:(string -> pos:int -> unit) -> GtkSignal.id
+ end
+
+class editable : 'a obj ->
+ object
+ inherit widget
+ constraint 'a = [>`editable|`widget]
+ val obj : 'a obj
+ method connect : editable_signals
+ method copy_clipboard : unit -> unit
+ method cut_clipboard : unit -> unit
+ method delete_selection : unit -> unit
+ method delete_text : start:int -> stop:int -> unit
+ method get_chars : start:int -> stop:int -> string
+ method insert_text : string -> pos:int -> int
+ method paste_clipboard : unit -> unit
+ method position : int
+ method select_region : start:int -> stop:int -> unit
+ method selection : (int * int) option
+ method set_editable : bool -> unit
+ method set_position : int -> unit
+ end
+
+class entry : 'a obj ->
+ object
+ inherit editable
+ constraint 'a = [>`entry|`editable|`widget]
+ val obj : 'a obj
+ method event : event_ops
+ method append_text : string -> unit
+ method prepend_text : string -> unit
+ method set_max_length : int -> unit
+ method set_text : string -> unit
+ method set_visibility : bool -> unit
+ method text : string
+ method text_length : int
+ end
+val entry :
+ ?max_length:int ->
+ ?text:string ->
+ ?visibility:bool ->
+ ?editable:bool ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> entry
+
+class spin_button : Gtk.spin_button obj ->
+ object
+ inherit entry
+ val obj : Gtk.spin_button obj
+ method adjustment : GData.adjustment
+ method set_adjustment : GData.adjustment -> unit
+ method set_digits : int -> unit
+ method set_numeric : bool -> unit
+ method set_shadow_type : Tags.shadow_type -> unit
+ method set_snap_to_ticks : bool -> unit
+ method set_update_policy : [`ALWAYS|`IF_VALID] -> unit
+ method set_value : float -> unit
+ method set_wrap : bool -> unit
+ method spin : Tags.spin_type -> unit
+ method update : unit
+ method value : float
+ method value_as_int : int
+ end
+val spin_button :
+ ?adjustment:GData.adjustment ->
+ ?rate:float ->
+ ?digits:int ->
+ ?value:float ->
+ ?update_policy:[`ALWAYS|`IF_VALID] ->
+ ?numeric:bool ->
+ ?wrap:bool ->
+ ?shadow_type:Tags.shadow_type ->
+ ?snap_to_ticks:bool ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> spin_button
+
+class combo : Gtk.combo obj ->
+ object
+ inherit widget
+ val obj : Gtk.combo obj
+ method disable_activate : unit -> unit
+ method entry : entry
+ method list : GList.liste
+ method set_case_sensitive : bool -> unit
+ method set_item_string : GList.list_item -> string -> unit
+ method set_popdown_strings : string list -> unit
+ method set_use_arrows : [`NEVER|`DEFAULT|`ALWAYS] -> unit
+ method set_value_in_list :
+ ?required:bool -> ?ok_if_empty:bool -> unit -> unit
+ end
+val combo :
+ ?popdown_strings:string list ->
+ ?use_arrows:[`NEVER|`DEFAULT|`ALWAYS] ->
+ ?case_sensitive:bool ->
+ ?value_in_list:bool ->
+ ?ok_if_empty:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> combo
+
+class text : Gtk.text obj ->
+ object
+ inherit editable
+ val obj : Gtk.text obj
+ method event : event_ops
+ method freeze : unit -> unit
+ method hadjustment : GData.adjustment
+ method insert :
+ ?font:Gdk.font ->
+ ?foreground:GDraw.color -> ?background:GDraw.color -> string -> unit
+ method length : int
+ method point : int
+ method set_hadjustment : GData.adjustment -> unit
+ method set_point : int -> unit
+ method set_vadjustment : GData.adjustment -> unit
+ method set_word_wrap : bool -> unit
+ method set_line_wrap : bool -> unit
+ method thaw : unit -> unit
+ method vadjustment : GData.adjustment
+ end
+val text :
+ ?hadjustment:GData.adjustment ->
+ ?vadjustment:GData.adjustment ->
+ ?editable:bool ->
+ ?word_wrap:bool ->
+ ?line_wrap:bool ->
+ ?width:int ->
+ ?height:int -> ?packing:(widget -> unit) -> ?show:bool -> unit -> text
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GObj
+open GtkXmHTML
+
+class xmhtml obj = object (self)
+ inherit widget_full (obj : GtkXmHTML.xmhtml obj)
+ method event = new GObj.event_ops obj
+ method freeze = freeze obj
+ method thaw = thaw obj
+ method source = source obj
+ method set_fonts = set_font_familty obj
+ method set_fonts_fixed = set_font_familty_fixed obj
+ method set_anchor_buttons = set_anchor_buttons obj
+ method set_anchor_cursor = set_anchor_cursor obj
+ method set_anchor_underline = set_anchor_underline_type obj
+ method set_anchor_visited_underline = set_anchor_visited_underline_type obj
+ method set_anchor_target_underline = set_anchor_target_underline_type obj
+ method set_topline = set_topline obj
+ method topline = get_topline obj
+ method set_strict_checking = set_strict_checking obj
+ method set_bad_html_warnings = set_bad_html_warnings obj
+ method set_imagemap_draw = set_imagemap_draw obj
+end
+
+let xmhtml ?source ?border_width ?width ?height ?packing ?show () =
+ let w = create () in
+ Container.set w ?border_width ?width ?height;
+ may source ~f:(GtkXmHTML.source w);
+ pack_return (new xmhtml w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkList
+open GObj
+open GContainer
+
+class list_item obj = object
+ inherit container (obj : Gtk.list_item obj)
+ method event = new GObj.event_ops obj
+ method as_item = obj
+ method select () = Item.select obj
+ method deselect () = Item.deselect obj
+ method toggle () = Item.toggle obj
+ method connect = new item_signals obj
+end
+
+let list_item ?label ?border_width ?width ?height ?packing ?(show=true) () =
+ let w = ListItem.create ?label () in
+ Container.set w ?border_width ?width ?height;
+ let item = new list_item w in
+ may packing ~f:(fun f -> (f item : unit));
+ if show then item#misc#show ();
+ item
+
+class liste obj = object
+ inherit [list_item] item_container (obj : Gtk.liste obj)
+ method private wrap w = new list_item (ListItem.cast w)
+ method insert w = Liste.insert_item obj w#as_item
+ method clear_items = Liste.clear_items obj
+ method select_item = Liste.select_item obj
+ method unselect_item = Liste.unselect_item obj
+ method child_position (w : list_item) = Liste.child_position obj w#as_item
+end
+
+let liste ?selection_mode ?border_width ?width ?height
+ ?packing ?show () =
+ let w = Liste.create () in
+ may selection_mode ~f:(Liste.set_selection_mode w);
+ Container.set w ?border_width ?width ?height;
+ pack_return (new liste w) ~packing ~show
+
+(* Cell lists *)
+
+class clist_signals obj = object
+ inherit container_signals obj
+ method click_column =
+ GtkSignal.connect ~sgn:CList.Signals.click_column obj ~after
+ method select_row =
+ GtkSignal.connect ~sgn:CList.Signals.select_row obj ~after
+ method unselect_row =
+ GtkSignal.connect ~sgn:CList.Signals.unselect_row obj ~after
+ method scroll_vertical =
+ GtkSignal.connect ~sgn:CList.Signals.scroll_vertical obj ~after
+ method scroll_horizontal =
+ GtkSignal.connect ~sgn:CList.Signals.scroll_horizontal obj ~after
+end
+
+class ['a] clist obj = object (self)
+ inherit widget (obj : Gtk.clist obj)
+ method set_border_width = Container.set_border_width obj
+ method event = new GObj.event_ops obj
+ method connect = new clist_signals obj
+ method rows = CList.get_rows obj
+ method columns = CList.get_columns obj
+ method focus_row = CList.get_focus_row obj
+ method hadjustment = new GData.adjustment (CList.get_hadjustment obj)
+ method vadjustment = new GData.adjustment (CList.get_vadjustment obj)
+ method set_button_actions = CList.set_button_actions obj
+ method freeze () = CList.freeze obj
+ method thaw () = CList.thaw obj
+ method column_title = CList.get_column_title obj
+ method column_widget col =
+ new widget (CList.get_column_widget obj col)
+ method columns_autosize () = CList.columns_autosize obj
+ method optimal_column_width = CList.optimal_column_width obj
+ method moveto ?(row_align=0.) ?(col_align=0.) row col =
+ CList.moveto obj row col ~row_align ~col_align
+ method row_is_visible = CList.row_is_visible obj
+ method cell_type = CList.get_cell_type obj
+ method cell_text = CList.get_text obj
+ method cell_pixmap row col =
+ let pm, mask = CList.get_pixmap obj row col in
+ may_map pm ~f:(fun x -> new GDraw.pixmap ?mask x)
+ method cell_style row col =
+ try Some (new style (CList.get_cell_style obj row col))
+ with Gpointer.Null -> None
+ method row_selectable row = CList.get_selectable obj ~row
+ method row_style row =
+ try Some (new style (CList.get_row_style obj ~row))
+ with Gpointer.Null -> None
+ method set_shift = CList.set_shift obj
+ method insert ~row texts =
+ let texts = List.map texts ~f:(fun x -> Some x) in
+ CList.insert obj ~row texts
+ method append = self#insert ~row:self#rows
+ method prepend = self#insert ~row:0
+ method remove = CList.remove obj
+ method select = CList.select obj
+ method unselect = CList.unselect obj
+ method clear () = CList.clear obj
+ method get_row_column = CList.get_row_column obj
+ method select_all () = CList.select_all obj
+ method unselect_all () = CList.unselect_all obj
+ method swap_rows = CList.swap_rows obj
+ method row_move = CList.row_move obj
+ method sort () = CList.sort obj
+ method set_hadjustment adj =
+ CList.set_hadjustment obj (GData.as_adjustment adj)
+ method set_vadjustment adj =
+ CList.set_vadjustment obj (GData.as_adjustment adj)
+ method set_shadow_type = CList.set_shadow_type obj
+ method set_button_actions = CList.set_button_actions obj
+ method set_selection_mode = CList.set_selection_mode obj
+ method set_reorderable = CList.set_reorderable obj
+ method set_use_drag_icons = CList.set_use_drag_icons obj
+ method set_row_height = CList.set_row_height obj
+ method set_titles_show = CList.set_titles_show obj
+ method set_titles_active = CList.set_titles_active obj
+ method set_sort = CList.set_sort obj
+ method set_column ?widget =
+ CList.set_column obj ?widget:(may_map widget ~f:as_widget)
+ method set_row ?foreground ?background ?selectable ?style =
+ let color = may_map ~f:(fun c -> Gpointer.optboxed (GDraw.optcolor c))
+ and style = may_map ~f:(fun (st : style) -> st#as_style) style in
+ CList.set_row obj
+ ?foreground:(color foreground) ?background:(color background)
+ ?selectable ?style
+ method set_cell ?text ?pixmap ?spacing ?style =
+ let pixmap, mask =
+ match pixmap with None -> None, None
+ | Some (pm : GDraw.pixmap) -> Some pm#pixmap, pm#mask
+ and style = may_map ~f:(fun (st : style) -> st#as_style) style in
+ CList.set_cell obj ?text ?pixmap ?mask ?spacing ?style
+ method set_row_data n ~data =
+ CList.set_row_data obj ~row:n (Obj.repr (data : 'a))
+ method get_row_data n : 'a = Obj.obj (CList.get_row_data obj ~row:n)
+ method scroll_vertical =
+ CList.Signals.emit_scroll obj ~sgn:CList.Signals.scroll_vertical
+ method scroll_horizontal =
+ CList.Signals.emit_scroll obj ~sgn:CList.Signals.scroll_horizontal
+end
+
+let clist ?(columns=1) ?titles ?hadjustment ?vadjustment
+ ?shadow_type ?button_actions ?selection_mode
+ ?reorderable ?use_drag_icons ?row_height
+ ?titles_show ?titles_active ?auto_sort ?sort_column ?sort_type
+ ?border_width ?width ?height ?packing ?show () =
+ let w =
+ match titles with None -> CList.create ~cols:columns
+ | Some titles -> CList.create_with_titles (Array.of_list titles)
+ in
+ CList.set w
+ ?hadjustment:(may_map ~f:GData.as_adjustment hadjustment)
+ ?vadjustment:(may_map ~f:GData.as_adjustment vadjustment)
+ ?shadow_type ?button_actions ?selection_mode ?reorderable
+ ?use_drag_icons ?row_height ?titles_show ?titles_active;
+ CList.set_sort w ?auto:auto_sort ?column:sort_column ?dir:sort_type ();
+ Container.set w ?border_width ?width ?height;
+ pack_return (new clist w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class list_item : Gtk.list_item obj ->
+ object
+ inherit container
+ val obj : Gtk.list_item obj
+ method event : event_ops
+ method as_item : Gtk.list_item obj
+ method connect : item_signals
+ method deselect : unit -> unit
+ method select : unit -> unit
+ method toggle : unit -> unit
+ end
+val list_item :
+ ?label:string ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(list_item -> unit) -> ?show:bool -> unit -> list_item
+
+class liste : Gtk.liste obj ->
+ object
+ inherit [list_item] item_container
+ val obj : Gtk.liste obj
+ method child_position : list_item -> int
+ method clear_items : start:int -> stop:int -> unit
+ method insert : list_item -> pos:int -> unit
+ method select_item : pos:int -> unit
+ method unselect_item : pos:int -> unit
+ method private wrap : Gtk.widget obj -> list_item
+ end
+val liste :
+ ?selection_mode:Tags.selection_mode ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> liste
+
+class clist_signals : 'a obj ->
+ object
+ inherit container_signals
+ constraint 'a = [>`clist|`container|`widget]
+ val obj : 'a obj
+ method click_column : callback:(int -> unit) -> GtkSignal.id
+ method select_row :
+ callback:(row:int ->
+ column:int -> event:GdkEvent.Button.t option -> unit) ->
+ GtkSignal.id
+ method unselect_row :
+ callback:(row:int ->
+ column:int -> event:GdkEvent.Button.t option -> unit) ->
+ GtkSignal.id
+ method scroll_horizontal :
+ callback:(Tags.scroll_type -> pos:clampf -> unit) -> GtkSignal.id
+ method scroll_vertical :
+ callback:(Tags.scroll_type -> pos:clampf -> unit) -> GtkSignal.id
+ end
+
+class ['a] clist : Gtk.clist obj ->
+ object
+ inherit widget
+ val obj : Gtk.clist obj
+ method event : event_ops
+ method append : string list -> int
+ method cell_pixmap : int -> int -> GDraw.pixmap option
+ method cell_style : int -> int -> style option
+ method cell_text : int -> int -> string
+ method cell_type : int -> int -> Tags.cell_type
+ method clear : unit -> unit
+ method column_title : int -> string
+ method column_widget : int -> widget
+ method columns : int
+ method columns_autosize : unit -> unit
+ method connect : clist_signals
+ method focus_row : int
+ method freeze : unit -> unit
+ method get_row_column : x:int -> y:int -> int * int
+ method get_row_data : int -> 'a
+ method hadjustment : GData.adjustment
+ method insert : row:int -> string list -> int
+ method moveto :
+ ?row_align:clampf -> ?col_align:clampf -> int -> int -> unit
+ method optimal_column_width : int -> int
+ method prepend : string list -> int
+ method remove : row:int -> unit
+ method row_is_visible : int -> Tags.visibility
+ method row_move : int -> dst:int -> unit
+ method row_selectable : int -> bool
+ method row_style : int -> style option
+ method rows : int
+ method scroll_vertical : Tags.scroll_type -> pos:clampf -> unit
+ method scroll_horizontal : Tags.scroll_type -> pos:clampf -> unit
+ method select : int -> int -> unit
+ method select_all : unit -> unit
+ method set_border_width : int -> unit
+ method set_button_actions : int -> Tags.button_action list -> unit
+ method set_cell :
+ ?text:string ->
+ ?pixmap:GDraw.pixmap ->
+ ?spacing:int -> ?style:style -> int -> int -> unit
+ method set_column :
+ ?widget:widget ->
+ ?title:string ->
+ ?title_active:bool ->
+ ?justification:Tags.justification ->
+ ?visibility:bool ->
+ ?resizeable:bool ->
+ ?auto_resize:bool ->
+ ?width:int -> ?min_width:int -> ?max_width:int -> int -> unit
+ method set_hadjustment : GData.adjustment -> unit
+ method set_reorderable : bool -> unit
+ method set_row :
+ ?foreground:GDraw.optcolor ->
+ ?background:GDraw.optcolor ->
+ ?selectable:bool ->
+ ?style:style -> int -> unit
+ method set_row_data : int -> data:'a -> unit
+ method set_row_height : int -> unit
+ method set_selection_mode : Tags.selection_mode -> unit
+ method set_shadow_type : Tags.shadow_type -> unit
+ method set_shift : int -> int -> vertical:int -> horizontal:int -> unit
+ method set_sort :
+ ?auto:bool -> ?column:int -> ?dir:Tags.sort_type -> unit -> unit
+ method set_titles_active : bool -> unit
+ method set_titles_show : bool -> unit
+ method set_use_drag_icons : bool -> unit
+ method set_vadjustment : GData.adjustment -> unit
+ method sort : unit -> unit
+ method swap_rows : int -> int -> unit
+ method thaw : unit -> unit
+ method unselect : int -> int -> unit
+ method unselect_all : unit -> unit
+ method vadjustment : GData.adjustment
+ end
+val clist :
+ ?columns:int ->
+ ?titles:string list ->
+ ?hadjustment:GData.adjustment ->
+ ?vadjustment:GData.adjustment ->
+ ?shadow_type:Tags.shadow_type ->
+ ?button_actions:(int * Tags.button_action list) list ->
+ ?selection_mode:Tags.selection_mode ->
+ ?reorderable:bool ->
+ ?use_drag_icons:bool ->
+ ?row_height:int ->
+ ?titles_show:bool ->
+ ?titles_active:bool ->
+ ?auto_sort:bool ->
+ ?sort_column:int ->
+ ?sort_type:Tags.sort_type ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> 'a clist
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GtkMain
+open GObj
+
+module Main : sig
+ val init : unit -> string (* returns the locale name *)
+ val main : unit -> unit
+ val quit : unit -> unit
+ val version : int * int * int
+ val flush : unit -> unit
+end = Main
+
+module Grab = struct
+ open Grab
+ let add (w : #widget) = add w#as_widget
+ let remove (w : #widget) = remove w#as_widget
+ let get_current () = new widget (get_current ())
+end
+
+module Timeout : sig
+ type id
+ val add : ms:int -> callback:(unit -> bool) -> id
+ val remove : id -> unit
+end = Timeout
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkData
+open GtkBase
+open GtkMenu
+open GObj
+open GContainer
+
+(* Menu type *)
+
+class menu_shell_signals obj = object
+ inherit container_signals obj
+ method deactivate =
+ GtkSignal.connect ~sgn:MenuShell.Signals.deactivate obj ~after
+end
+
+class type virtual ['a] pre_menu = object
+ inherit ['a] item_container
+ method as_menu : Gtk.menu Gtk.obj
+ method deactivate : unit -> unit
+ method connect : menu_shell_signals
+ method event : event_ops
+ method popup : button:int -> time:int -> unit
+ method popdown : unit -> unit
+ method set_accel_group : accel_group -> unit
+end
+
+(* Menu items *)
+
+class menu_item_signals obj = object
+ inherit item_signals obj
+ method activate = GtkSignal.connect ~sgn:MenuItem.Signals.activate obj
+end
+
+
+class ['a] pre_menu_item_skel obj = object
+ inherit container obj
+ method as_item = MenuItem.coerce obj
+ method set_submenu (w : 'a pre_menu) = MenuItem.set_submenu obj w#as_menu
+ method remove_submenu () = MenuItem.remove_submenu obj
+ method configure = MenuItem.configure obj
+ method activate () = MenuItem.activate obj
+ method right_justify () = MenuItem.right_justify obj
+ method add_accelerator ~group ?modi:m ?flags key=
+ Widget.add_accelerator obj ~sgn:MenuItem.Signals.activate group ?flags
+ ?modi:m ~key
+end
+
+class menu_item obj = object
+ inherit [menu_item] pre_menu_item_skel obj
+ method connect = new menu_item_signals obj
+ method event = new GObj.event_ops obj
+end
+
+class menu_item_skel = [menu_item] pre_menu_item_skel
+
+let pack_item self ~packing ~show =
+ may packing ~f:(fun f -> (f (self :> menu_item) : unit));
+ if show <> Some false then self#misc#show ();
+ self
+
+let menu_item ?label ?border_width ?width ?height ?packing ?show () =
+ let w = MenuItem.create ?label () in
+ Container.set w ?border_width ?width ?height;
+ pack_item (new menu_item w) ?packing ?show
+
+let tearoff_item ?border_width ?width ?height ?packing ?show () =
+ let w = MenuItem.tearoff_create () in
+ Container.set w ?border_width ?width ?height;
+ pack_item (new menu_item w) ?packing ?show
+
+class check_menu_item_signals obj = object
+ inherit menu_item_signals obj
+ method toggled =
+ GtkSignal.connect ~sgn:CheckMenuItem.Signals.toggled obj ~after
+end
+
+class check_menu_item obj = object
+ inherit menu_item_skel obj
+ method set_active = CheckMenuItem.set_active obj
+ method set_show_toggle = CheckMenuItem.set_show_toggle obj
+ method active = CheckMenuItem.get_active obj
+ method toggled () = CheckMenuItem.toggled obj
+ method connect = new check_menu_item_signals obj
+ method event = new GObj.event_ops obj
+end
+
+let check_menu_item ?label ?active ?show_toggle
+ ?border_width ?width ?height ?packing ?show () =
+ let w = CheckMenuItem.create ?label () in
+ CheckMenuItem.set w ?active ?show_toggle;
+ Container.set w ?border_width ?width ?height;
+ pack_item (new check_menu_item w) ?packing ?show
+
+class radio_menu_item obj = object
+ inherit check_menu_item (obj : Gtk.radio_menu_item obj)
+ method group = Some obj
+ method set_group = RadioMenuItem.set_group obj
+end
+
+let radio_menu_item ?group ?label ?active ?show_toggle
+ ?border_width ?width ?height ?packing ?show () =
+ let w = RadioMenuItem.create ?group ?label () in
+ CheckMenuItem.set w ?active ?show_toggle;
+ Container.set w ?border_width ?width ?height;
+ pack_item (new radio_menu_item w) ?packing ?show
+
+(* Menus *)
+
+class menu_shell obj = object
+ inherit [menu_item] item_container obj
+ method private wrap w = new menu_item (MenuItem.cast w)
+ method insert w = MenuShell.insert obj w#as_item
+ method deactivate () = MenuShell.deactivate obj
+ method connect = new menu_shell_signals obj
+ method event = new GObj.event_ops obj
+end
+
+class menu obj = object
+ inherit menu_shell obj
+ method popup = Menu.popup obj
+ method popdown () = Menu.popdown obj
+ method as_menu : Gtk.menu obj = obj
+ method set_accel_group = Menu.set_accel_group obj
+end
+
+let menu ?border_width ?packing ?show () =
+ let w = Menu.create () in
+ may border_width ~f:(Container.set_border_width w);
+ let self = new menu w in
+ may packing ~f:(fun f -> (f (self :> menu) : unit));
+ if show <> Some false then self#misc#show ();
+ self
+
+(* Option Menu (GtkButton?) *)
+
+class option_menu obj = object
+ inherit GButton.button_skel obj
+ method connect = new GButton.button_signals obj
+ method event = new GObj.event_ops obj
+ method set_menu (menu : menu) = OptionMenu.set_menu obj menu#as_menu
+ method get_menu = new menu (OptionMenu.get_menu obj)
+ method remove_menu () = OptionMenu.remove_menu obj
+ method set_history = OptionMenu.set_history obj
+end
+
+let option_menu ?border_width ?width ?height ?packing ?show () =
+ let w = OptionMenu.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new option_menu w) ~packing ~show
+
+(* Menu Bar *)
+
+let menu_bar ?border_width ?width ?height ?packing ?show () =
+ let w = MenuBar.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new menu_shell w) ~packing ~show
+
+(* Menu Factory *)
+
+class ['a] factory
+ ?(accel_group=AccelGroup.create ())
+ ?(accel_modi=[`CONTROL])
+ ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
+ object (self)
+ val menu_shell : #menu_shell = menu_shell
+ val group = accel_group
+ val m = accel_modi
+ val flags = accel_flags
+ method menu = menu_shell
+ method accel_group = group
+ method private bind ?key ?callback (item : menu_item) =
+ menu_shell#append item;
+ may key ~f:(item#add_accelerator ~group ~modi:m ~flags);
+ may callback ~f:(fun callback -> item#connect#activate ~callback)
+ method add_item ?key ?callback ?submenu label =
+ let item = menu_item ~label () in
+ self#bind item ?key ?callback;
+ may (submenu : menu option) ~f:item#set_submenu;
+ item
+ method add_check_item ?active ?key ?callback label =
+ let item = check_menu_item ~label ?active () in
+ self#bind (item :> menu_item) ?key
+ ?callback:(may_map callback ~f:(fun f () -> f item#active));
+ item
+ method add_radio_item ?group ?active ?key ?callback label =
+ let item = radio_menu_item ~label ?group ?active () in
+ self#bind (item :> menu_item) ?key
+ ?callback:(may_map callback ~f:(fun f () -> f item#active));
+ item
+ method add_separator () = menu_item ~packing:menu_shell#append ()
+ method add_submenu ?key label =
+ let item = menu_item ~label () in
+ self#bind item ?key;
+ menu ~packing:item#set_submenu ();
+ method add_tearoff () = tearoff_item ~packing:menu_shell#append ()
+end
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class menu_shell_signals : 'b obj ->
+ object ('a)
+ inherit container_signals
+ constraint 'b = [>`menushell|`container|`widget]
+ val obj : 'b obj
+ method deactivate : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class menu_item_signals : 'b obj ->
+ object ('a)
+ inherit item_signals
+ constraint 'b = [>`menuitem|`container|`item|`widget]
+ val obj : 'b obj
+ method activate : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class menu_item_skel :
+ 'a obj ->
+ object
+ inherit container
+ constraint 'a = [>`widget|`container|`menuitem]
+ val obj : 'a obj
+ method activate : unit -> unit
+ method add_accelerator :
+ group:accel_group ->
+ ?modi:Gdk.Tags.modifier list ->
+ ?flags:Tags.accel_flag list -> Gdk.keysym -> unit
+ method as_item : Gtk.menu_item obj
+ method configure : show_toggle:bool -> show_indicator:bool -> unit
+ method remove_submenu : unit -> unit
+ method right_justify : unit -> unit
+ method set_submenu : menu -> unit
+ end
+and menu_item : 'a obj ->
+ object
+ inherit menu_item_skel
+ constraint 'a = [>`widget|`container|`item|`menuitem]
+ val obj : 'a obj
+ method event : event_ops
+ method connect : menu_item_signals
+ end
+and menu : Gtk.menu obj ->
+ object
+ inherit [menu_item] item_container
+ val obj : Gtk.menu obj
+ method add : menu_item -> unit
+ method event : event_ops
+ method append : menu_item -> unit
+ method as_menu : Gtk.menu obj
+ method children : menu_item list
+ method connect : menu_shell_signals
+ method deactivate : unit -> unit
+ method insert : menu_item -> pos:int -> unit
+ method popdown : unit -> unit
+ method popup : button:int -> time:int -> unit
+ method prepend : menu_item -> unit
+ method remove : menu_item -> unit
+ method set_accel_group : accel_group -> unit
+ method set_border_width : int -> unit
+ method private wrap : Gtk.widget obj -> menu_item
+ end
+
+val menu :
+ ?border_width:int -> ?packing:(menu -> unit) -> ?show:bool -> unit -> menu
+val menu_item :
+ ?label:string ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(menu_item -> unit) -> ?show:bool -> unit -> menu_item
+val tearoff_item :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(menu_item -> unit) -> ?show:bool -> unit -> menu_item
+
+class check_menu_item_signals : 'a obj ->
+ object
+ inherit menu_item_signals
+ constraint 'a = [>`checkmenuitem|`container|`item|`menuitem|`widget]
+ val obj : 'a obj
+ method toggled : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class check_menu_item : 'a obj ->
+ object
+ inherit menu_item_skel
+ constraint 'a = [>`widget|`checkmenuitem|`container|`item|`menuitem]
+ val obj : 'a obj
+ method active : bool
+ method event : event_ops
+ method connect : check_menu_item_signals
+ method set_active : bool -> unit
+ method set_show_toggle : bool -> unit
+ method toggled : unit -> unit
+ end
+val check_menu_item :
+ ?label:string ->
+ ?active:bool ->
+ ?show_toggle:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(menu_item -> unit) -> ?show:bool -> unit -> check_menu_item
+
+class radio_menu_item : Gtk.radio_menu_item obj ->
+ object
+ inherit check_menu_item
+ val obj : Gtk.radio_menu_item obj
+ method group : Gtk.radio_menu_item group
+ method set_group : Gtk.radio_menu_item group -> unit
+ end
+val radio_menu_item :
+ ?group:Gtk.radio_menu_item group ->
+ ?label:string ->
+ ?active:bool ->
+ ?show_toggle:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(menu_item -> unit) -> ?show:bool -> unit -> radio_menu_item
+
+class menu_shell : 'a obj ->
+ object
+ inherit [menu_item] item_container
+ constraint 'a = [>`widget|`container|`menushell]
+ val obj : 'a obj
+ method event : event_ops
+ method deactivate : unit -> unit
+ method connect : menu_shell_signals
+ method insert : menu_item -> pos:int -> unit
+ method private wrap : Gtk.widget obj -> menu_item
+ end
+
+val menu_bar :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> menu_shell
+
+class option_menu : 'a obj ->
+ object
+ inherit GButton.button_skel
+ constraint 'a = [>`optionmenu|`button|`container|`widget]
+ val obj : 'a obj
+ method event : event_ops
+ method connect : GButton.button_signals
+ method get_menu : menu
+ method remove_menu : unit -> unit
+ method set_history : int -> unit
+ method set_menu : menu -> unit
+ end
+val option_menu :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> option_menu
+
+class ['a] factory :
+ ?accel_group:accel_group ->
+ ?accel_modi:Gdk.Tags.modifier list ->
+ ?accel_flags:Tags.accel_flag list ->
+ 'a ->
+ object
+ constraint 'a = #menu_shell
+ val flags : Tags.accel_flag list
+ val group : accel_group
+ val m : Gdk.Tags.modifier list
+ val menu_shell : 'a
+ method accel_group : accel_group
+ method add_check_item :
+ ?active:bool ->
+ ?key:Gdk.keysym ->
+ ?callback:(bool -> unit) -> string -> check_menu_item
+ method add_item :
+ ?key:Gdk.keysym ->
+ ?callback:(unit -> unit) ->
+ ?submenu:menu -> string -> menu_item
+ method add_radio_item :
+ ?group:Gtk.radio_menu_item group ->
+ ?active:bool ->
+ ?key:Gdk.keysym ->
+ ?callback:(bool -> unit) -> string -> radio_menu_item
+ method add_separator : unit -> menu_item
+ method add_submenu : ?key:Gdk.keysym -> string -> menu
+ method add_tearoff : unit -> menu_item
+ method private bind :
+ ?key:Gdk.keysym -> ?callback:(unit -> unit) -> menu_item -> unit
+ method menu : 'a
+ end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkMisc
+open GObj
+
+let separator dir ?(width = -2) ?(height = -2) ?packing ?show () =
+ let w = Separator.create dir in
+ if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
+ pack_return (new widget_full w) ~packing ~show
+
+class statusbar_context obj ctx = object (self)
+ val obj : statusbar obj = obj
+ val context : Gtk.statusbar_context = ctx
+ method context = context
+ method push text = Statusbar.push obj context ~text
+ method pop () = Statusbar.pop obj context
+ method remove = Statusbar.remove obj context
+ method flash ?(delay=1000) text =
+ let msg = self#push text in
+ GtkMain.Timeout.add ~ms:delay ~callback:(fun () -> self#remove msg; false);
+ ()
+end
+
+class statusbar obj = object
+ inherit GContainer.container_full (obj : Gtk.statusbar obj)
+ method new_context ~name =
+ new statusbar_context obj (Statusbar.get_context obj name)
+end
+
+let statusbar ?border_width ?width ?height ?packing ?show () =
+ let w = Statusbar.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new statusbar w) ~packing ~show
+
+class calendar_signals obj = object
+ inherit widget_signals obj
+ method month_changed =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.month_changed ~after
+ method day_selected =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.day_selected ~after
+ method day_selected_double_click =
+ GtkSignal.connect obj
+ ~sgn:Calendar.Signals.day_selected_double_click ~after
+ method prev_month =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.prev_month ~after
+ method next_month =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.next_month ~after
+ method prev_year =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.prev_year ~after
+ method next_year =
+ GtkSignal.connect obj ~sgn:Calendar.Signals.next_year ~after
+end
+
+class calendar obj = object
+ inherit widget (obj : Gtk.calendar obj)
+ method event = new GObj.event_ops obj
+ method connect = new calendar_signals obj
+ method select_month = Calendar.select_month obj
+ method select_day = Calendar.select_day obj
+ method mark_day = Calendar.mark_day obj
+ method unmark_day = Calendar.unmark_day obj
+ method clear_marks = Calendar.clear_marks obj
+ method display_options = Calendar.display_options obj
+ method date = Calendar.get_date obj
+ method freeze () = Calendar.freeze obj
+ method thaw () = Calendar.thaw obj
+end
+
+let calendar ?options ?(width = -2) ?(height = -2) ?packing ?show () =
+ let w = Calendar.create () in
+ if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
+ may options ~f:(Calendar.display_options w);
+ pack_return (new calendar w) ~packing ~show
+
+class drawing_area obj = object
+ inherit widget_full (obj : Gtk.drawing_area obj)
+ method event = new GObj.event_ops obj
+ method set_size = DrawingArea.size obj
+end
+
+let drawing_area ?(width=0) ?(height=0) ?packing ?show () =
+ let w = DrawingArea.create () in
+ if width <> 0 || height <> 0 then DrawingArea.size w ~width ~height;
+ pack_return (new drawing_area w) ~packing ~show
+
+class misc obj = object
+ inherit widget obj
+ method set_alignment = Misc.set_alignment obj
+ method set_padding = Misc.set_padding obj
+end
+
+class arrow obj = object
+ inherit misc obj
+ method set_arrow kind ~shadow = Arrow.set obj ~kind ~shadow
+end
+
+let arrow ~kind ~shadow
+ ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
+ let w = Arrow.create ~kind ~shadow in
+ Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
+ pack_return (new arrow w) ~packing ~show
+
+class image obj = object
+ inherit misc obj
+ method set_image ?mask image = Image.set obj image ?mask
+end
+
+let image image ?mask
+ ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
+ let w = Image.create image ?mask in
+ Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
+ pack_return (new image w) ~packing ~show
+
+class label_skel obj = object
+ inherit misc obj
+ method set_text = Label.set_text obj
+ method set_justify = Label.set_justify obj
+ method set_pattern = Label.set_pattern obj
+ method set_line_wrap = Label.set_line_wrap obj
+ method text = Label.get_text obj
+end
+
+class label obj = object
+ inherit label_skel (Label.coerce obj)
+ method connect = new widget_signals obj
+end
+
+let label ?(text="") ?justify ?line_wrap ?pattern
+ ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
+ let w = Label.create text in
+ Label.set w ?justify ?line_wrap ?pattern;
+ Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
+ pack_return (new label w) ~packing ~show
+
+let label_cast w = new label (Label.cast w#as_widget)
+
+class tips_query_signals obj = object
+ inherit widget_signals obj
+ method widget_entered ~callback =
+ GtkSignal.connect ~sgn:TipsQuery.Signals.widget_entered obj ~after
+ ~callback:(function None -> callback None
+ | Some w -> callback (Some (new widget w)))
+ method widget_selected ~callback =
+ GtkSignal.connect ~sgn:TipsQuery.Signals.widget_selected obj ~after
+ ~callback:(function None -> callback None
+ | Some w -> callback (Some (new widget w)))
+end
+
+class tips_query obj = object
+ inherit label_skel (obj : Gtk.tips_query obj)
+ method start () = TipsQuery.start obj
+ method stop () = TipsQuery.stop obj
+ method set_caller (w : widget) = TipsQuery.set_caller obj w#as_widget
+ method set_emit_always = TipsQuery.set_emit_always obj
+ method set_label_inactive inactive = TipsQuery.set_labels obj ~inactive
+ method set_label_no_tip no_tip = TipsQuery.set_labels obj ~no_tip
+ method connect = new tips_query_signals obj
+end
+
+let tips_query ?caller ?emit_always ?label_inactive ?label_no_tip
+ ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
+ let w = TipsQuery.create () in
+ let caller = may_map caller ~f:(fun (w : #widget) -> w#as_widget) in
+ TipsQuery.set w ?caller ?emit_always ?label_inactive ?label_no_tip;
+ Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
+ pack_return (new tips_query w) ~packing ~show
+
+class color_selection obj = object
+ inherit GObj.widget_full (obj : Gtk.color_selection obj)
+ method set_update_policy = ColorSelection.set_update_policy obj
+ method set_opacity = ColorSelection.set_opacity obj
+ method set_color ~red ~green ~blue ?opacity () =
+ ColorSelection.set_color obj ~red ~green ~blue ?opacity
+ method get_color = ColorSelection.get_color obj
+end
+
+let color_selection ?border_width ?width ?height ?packing ?show () =
+ let w = ColorSelection.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new color_selection w) ~packing ~show
+
+class pixmap obj = object
+ inherit misc (obj : Gtk.pixmap obj)
+ method connect = new widget_signals obj
+ method set_pixmap (pm : GDraw.pixmap) =
+ Pixmap.set obj ~pixmap:pm#pixmap ?mask:pm#mask
+ method pixmap =
+ new GDraw.pixmap (Pixmap.pixmap obj)
+ ?mask:(try Some(Pixmap.mask obj) with Gpointer.Null -> None)
+end
+
+let pixmap (pm : #GDraw.pixmap) ?xalign ?yalign ?xpad ?ypad
+ ?(width = -2) ?(height = -2) ?packing ?show () =
+ let w = Pixmap.create pm#pixmap ?mask:pm#mask in
+ Misc.set w ?xalign ?yalign ?xpad ?ypad;
+ if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
+ pack_return (new pixmap w) ~packing ~show
+
+class font_selection obj = object
+ inherit widget_full (obj : Gtk.font_selection obj)
+ method notebook = new GPack.notebook obj
+ method event = new event_ops obj
+ method font = FontSelection.get_font obj
+ method font_name = FontSelection.get_font_name obj
+ method set_font_name = FontSelection.set_font_name obj
+ method preview_text = FontSelection.get_preview_text obj
+ method set_preview_text = FontSelection.set_preview_text obj
+ method set_filter = FontSelection.set_filter obj
+end
+
+let font_selection ?border_width ?width ?height ?packing ?show () =
+ let w = FontSelection.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new font_selection w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+val separator :
+ Tags.orientation ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> widget_full
+
+class statusbar_context :
+ Gtk.statusbar obj -> Gtk.statusbar_context ->
+ object
+ val context : Gtk.statusbar_context
+ val obj : Gtk.statusbar obj
+ method context : Gtk.statusbar_context
+ method flash : ?delay:int -> string -> unit
+ method pop : unit -> unit
+ method push : string -> statusbar_message
+ method remove : statusbar_message -> unit
+ end
+
+class statusbar : Gtk.statusbar obj ->
+ object
+ inherit container_full
+ val obj : Gtk.statusbar obj
+ method new_context : name:string -> statusbar_context
+ end
+val statusbar :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> statusbar
+
+class calendar_signals : 'a obj ->
+ object
+ inherit widget_signals
+ constraint 'a = [>`calendar|`widget]
+ val obj : 'a obj
+ method day_selected : callback:(unit -> unit) -> GtkSignal.id
+ method day_selected_double_click :
+ callback:(unit -> unit) -> GtkSignal.id
+ method month_changed : callback:(unit -> unit) -> GtkSignal.id
+ method next_month : callback:(unit -> unit) -> GtkSignal.id
+ method next_year : callback:(unit -> unit) -> GtkSignal.id
+ method prev_month : callback:(unit -> unit) -> GtkSignal.id
+ method prev_year : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class calendar : Gtk.calendar obj ->
+ object
+ inherit widget
+ val obj : Gtk.calendar obj
+ method event : event_ops
+ method clear_marks : unit
+ method connect : calendar_signals
+ method date : int * int * int
+ method display_options : Tags.calendar_display_options list -> unit
+ method freeze : unit -> unit
+ method mark_day : int -> unit
+ method select_day : int -> unit
+ method select_month : month:int -> year:int -> unit
+ method thaw : unit -> unit
+ method unmark_day : int -> unit
+ end
+val calendar :
+ ?options:Tags.calendar_display_options list ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> calendar
+
+class drawing_area : Gtk.drawing_area obj ->
+ object
+ inherit widget_full
+ val obj : Gtk.drawing_area obj
+ method event : event_ops
+ method set_size : width:int -> height:int -> unit
+ end
+val drawing_area :
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> drawing_area
+
+class misc : 'a obj ->
+ object
+ inherit widget
+ constraint 'a = [>`misc|`widget]
+ val obj : 'a obj
+ method set_alignment : ?x:float -> ?y:float -> unit -> unit
+ method set_padding : ?x:int -> ?y:int -> unit -> unit
+ end
+
+class arrow : 'a obj ->
+ object
+ inherit misc
+ constraint 'a = [>`arrow|`misc|`widget]
+ val obj : 'a obj
+ method set_arrow : Tags.arrow_type -> shadow:Tags.shadow_type -> unit
+ end
+
+val arrow :
+ kind:Tags.arrow_type ->
+ shadow:Tags.shadow_type ->
+ ?xalign:float ->
+ ?yalign:float ->
+ ?xpad:int ->
+ ?ypad:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> arrow
+
+class image : 'a obj ->
+ object
+ inherit misc
+ constraint 'a = [>`image|`misc|`widget]
+ val obj : 'a obj
+ method set_image : ?mask:Gdk.bitmap -> Gdk.image -> unit
+ end
+
+val image :
+ Gdk.image ->
+ ?mask:Gdk.bitmap ->
+ ?xalign:float ->
+ ?yalign:float ->
+ ?xpad:int ->
+ ?ypad:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> image
+
+class label_skel : 'a obj ->
+ object
+ inherit misc
+ constraint 'a = [>`label|`misc|`widget]
+ val obj : 'a obj
+ method set_justify : Tags.justification -> unit
+ method set_line_wrap : bool -> unit
+ method set_pattern : string -> unit
+ method set_text : string -> unit
+ method text : string
+ end
+
+class label : [>`label] obj ->
+ object
+ inherit label_skel
+ val obj : Gtk.label obj
+ method connect : widget_signals
+ end
+val label :
+ ?text:string ->
+ ?justify:Tags.justification ->
+ ?line_wrap:bool ->
+ ?pattern:string ->
+ ?xalign:float ->
+ ?yalign:float ->
+ ?xpad:int ->
+ ?ypad:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> label
+val label_cast : < as_widget : 'a obj ; .. > -> label
+
+class tips_query_signals : 'a obj ->
+ object
+ inherit widget_signals
+ constraint 'a = [>`tipsquery|`widget]
+ val obj : 'a obj
+ method widget_entered :
+ callback:(widget option ->
+ text:string option -> privat:string option -> unit) ->
+ GtkSignal.id
+ method widget_selected :
+ callback:(widget option -> text:string option ->
+ privat:string option -> GdkEvent.Button.t option -> bool) ->
+ GtkSignal.id
+ end
+
+class tips_query : Gtk.tips_query obj ->
+ object
+ inherit label_skel
+ val obj : Gtk.tips_query obj
+ method connect : tips_query_signals
+ method set_caller : widget -> unit
+ method set_emit_always : bool -> unit
+ method set_label_inactive : string -> unit
+ method set_label_no_tip : string -> unit
+ method start : unit -> unit
+ method stop : unit -> unit
+ end
+val tips_query :
+ ?caller:#widget ->
+ ?emit_always:bool ->
+ ?label_inactive:string ->
+ ?label_no_tip:string ->
+ ?xalign:float ->
+ ?yalign:float ->
+ ?xpad:int ->
+ ?ypad:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> tips_query
+
+class pixmap : Gtk.pixmap Gtk.obj ->
+ object
+ inherit misc
+ val obj : Gtk.pixmap Gtk.obj
+ method connect : GObj.widget_signals
+ method pixmap : GDraw.pixmap
+ method set_pixmap : GDraw.pixmap -> unit
+ end
+val pixmap :
+ #GDraw.pixmap ->
+ ?xalign:float ->
+ ?yalign:float ->
+ ?xpad:int ->
+ ?ypad:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> pixmap
+
+class color_selection : Gtk.color_selection obj ->
+ object
+ inherit widget_full
+ val obj : Gtk.color_selection obj
+ method get_color : Gtk.color
+ method set_color :
+ red:float -> green:float -> blue:float -> ?opacity:float -> unit -> unit
+ method set_opacity : bool -> unit
+ method set_update_policy : Tags.update_type -> unit
+ end
+val color_selection :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> color_selection
+
+class font_selection : Gtk.font_selection obj ->
+ object
+ inherit widget_full
+ val obj : Gtk.font_selection obj
+ method event : event_ops
+ method notebook : GPack.notebook
+ method font : Gdk.font option
+ method font_name : string option
+ method preview_text : string
+ method set_filter :
+ ?kind:Tags.font_type list ->
+ ?foundry:string list ->
+ ?weight:string list ->
+ ?slant:string list ->
+ ?setwidth:string list ->
+ ?spacing:string list ->
+ ?charset:string list -> Tags.font_filter_type -> unit
+ method set_font_name : string -> unit
+ method set_preview_text : string -> unit
+ end
+val font_selection :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> font_selection
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkData
+open GtkBase
+
+(* Object *)
+
+class gtkobj obj = object
+ val obj = obj
+ method destroy () = Object.destroy obj
+ method get_id = Object.get_id obj
+end
+
+class gtkobj_misc obj = object
+ val obj = obj
+ method get_type = Type.name (Object.get_type obj)
+ method disconnect = GtkSignal.disconnect obj
+ method handler_block = GtkSignal.handler_block obj
+ method handler_unblock = GtkSignal.handler_unblock obj
+end
+
+class gtkobj_signals ?(after=false) obj = object
+ val obj = obj
+ val after = after
+ method after = {< after = true >}
+ method destroy = GtkSignal.connect ~sgn:Object.Signals.destroy obj
+end
+
+(* Widget *)
+
+class event_signals ?(after=false) obj = object
+ val obj = Widget.coerce obj
+ val after = after
+ method after = {< after = true >}
+ method any = GtkSignal.connect ~sgn:Widget.Signals.Event.any ~after obj
+ method button_press =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.button_press ~after obj
+ method button_release =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.button_release ~after obj
+ method configure =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.configure ~after obj
+ method delete =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.delete ~after obj
+ method destroy =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.destroy ~after obj
+ method enter_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.enter_notify ~after obj
+ method expose =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.expose ~after obj
+ method focus_in =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.focus_in ~after obj
+ method focus_out =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.focus_out ~after obj
+ method key_press =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.key_press ~after obj
+ method key_release =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.key_release ~after obj
+ method leave_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.leave_notify ~after obj
+ method map = GtkSignal.connect ~sgn:Widget.Signals.Event.map ~after obj
+ method motion_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.motion_notify ~after obj
+ method property_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.property_notify ~after obj
+ method proximity_in =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_in ~after obj
+ method proximity_out =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.proximity_out ~after obj
+ method selection_clear =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_clear ~after obj
+ method selection_notify =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_notify ~after obj
+ method selection_request =
+ GtkSignal.connect ~sgn:Widget.Signals.Event.selection_request ~after obj
+ method unmap = GtkSignal.connect ~sgn:Widget.Signals.Event.unmap ~after obj
+end
+
+class event_ops obj = object
+ val obj = Widget.coerce obj
+ method add = Widget.add_events obj
+ method connect = new event_signals obj
+ method send : Gdk.Tags.event_type Gdk.event -> bool = Widget.event obj
+ method set_extensions = Widget.set_extension_events obj
+end
+
+class style st = object
+ val style = st
+ method as_style = style
+ method copy = {< style = Style.copy style >}
+ method bg state = Style.get_bg style ~state
+ method colormap = Style.get_colormap style
+ method font = Style.get_font style
+ method set_bg =
+ List.iter ~f:
+ (fun (state,c) -> Style.set_bg style ~state ~color:(GDraw.color c))
+ method set_font = Style.set_font style
+ method set_background = Style.set_background style
+end
+
+class selection_data (sel : Selection.t) = object
+ val sel = sel
+ method selection = Selection.selection sel
+ method target = Selection.target sel
+ method seltype = Selection.seltype sel
+ method format = Selection.format sel
+ method data = Selection.get_data sel
+ method set = Selection.set sel
+end
+
+class drag_signals ?(after=false) obj = object
+ val obj = Widget.coerce obj
+ val after = after
+ method after = {< after = true >}
+ method beginning ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_begin ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method ending ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_end ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method data_delete ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_delete ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method leave ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_leave ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method motion ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_motion ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method drop ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_drop ~after obj
+ ~callback:(fun context -> callback (new drag_context context))
+ method data_get ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_get ~after obj
+ ~callback:(fun context data -> callback (new drag_context context)
+ (new selection_data data))
+ method data_received ~callback =
+ GtkSignal.connect ~sgn:Widget.Signals.drag_data_received ~after obj
+ ~callback:(fun context ~x ~y data -> callback (new drag_context context)
+ ~x ~y (new selection_data data))
+
+end
+
+and drag_ops obj = object
+ val obj = Widget.coerce obj
+ method connect = new drag_signals obj
+ method dest_set ?(flags=[`ALL]) ?(actions=[]) targets =
+ DnD.dest_set obj ~flags ~actions ~targets:(Array.of_list targets)
+ method dest_unset () = DnD.dest_unset obj
+ method get_data ?(time=0) ~context:(context : drag_context) target =
+ DnD.get_data obj (context : < context : Gdk.drag_context; .. >)#context
+ ~target ~time
+ method highlight () = DnD.highlight obj
+ method unhighlight () = DnD.unhighlight obj
+ method source_set ?modi:m ?(actions=[]) targets =
+ DnD.source_set obj ?modi:m ~actions ~targets:(Array.of_list targets)
+ method source_set_icon ?(colormap = Gdk.Color.get_system_colormap ())
+ (pix : GDraw.pixmap) =
+ DnD.source_set_icon obj ~colormap pix#pixmap ?mask:pix#mask
+ method source_unset () = DnD.source_unset obj
+end
+
+and drag_context context = object
+ inherit GDraw.drag_context context
+ method context = context
+ method finish = DnD.finish context
+ method source_widget =
+ new widget (Object.unsafe_cast (DnD.get_source_widget context))
+ method set_icon_widget (w : widget) =
+ DnD.set_icon_widget context (w#as_widget)
+ method set_icon_pixmap ?(colormap = Gdk.Color.get_system_colormap ())
+ (pix : GDraw.pixmap) =
+ DnD.set_icon_pixmap context ~colormap pix#pixmap ?mask:pix#mask
+end
+
+and misc_signals ?after obj = object
+ inherit gtkobj_signals ?after obj
+ method draw ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.draw ~after ~callback:
+ begin fun rect ->
+ callback
+ { x = Gdk.Rectangle.x rect ; y = Gdk.Rectangle.y rect;
+ width = Gdk.Rectangle.width rect;
+ height = Gdk.Rectangle.height rect }
+ end
+ method show = GtkSignal.connect ~sgn:Widget.Signals.show ~after obj
+ method hide = GtkSignal.connect ~sgn:Widget.Signals.hide ~after obj
+ method map = GtkSignal.connect ~sgn:Widget.Signals.map ~after obj
+ method unmap = GtkSignal.connect ~sgn:Widget.Signals.unmap ~after obj
+ method realize = GtkSignal.connect ~sgn:Widget.Signals.realize ~after obj
+ method state_changed =
+ GtkSignal.connect ~sgn:Widget.Signals.state_changed ~after obj
+ method parent_set ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.parent_set ~after ~callback:
+ begin function
+ None -> callback None
+ | Some w -> callback (Some (new widget (Object.unsafe_cast w)))
+ end
+ method style_set ~callback =
+ GtkSignal.connect obj ~sgn:Widget.Signals.style_set ~after ~callback:
+ (fun opt -> callback (may opt ~f:(new style)))
+end
+
+and misc_ops obj = object
+ inherit gtkobj_misc (Widget.coerce obj)
+ method connect = new misc_signals obj
+ method show () = Widget.show obj
+ method unparent () = Widget.unparent obj
+ method show_all () = Widget.show_all obj
+ method hide () = Widget.hide obj
+ method hide_all () = Widget.hide_all obj
+ method map () = Widget.map obj
+ method unmap () = Widget.unmap obj
+ method realize () = Widget.realize obj
+ method unrealize () = Widget.unrealize obj
+ method draw = Widget.draw obj
+ method activate () = Widget.activate obj
+ method reparent (w : widget) = Widget.reparent obj w#as_widget
+ method popup = Widget.popup obj
+ method intersect = Widget.intersect obj
+ method grab_focus () = Widget.grab_focus obj
+ method grab_default () = Widget.grab_default obj
+ method is_ancestor (w : widget) = Widget.is_ancestor obj w#as_widget
+ method add_accelerator ~sgn:sg ~group ?modi ?flags key =
+ Widget.add_accelerator obj ~sgn:sg group ~key ?modi ?flags
+ method remove_accelerator ~group ?modi key =
+ Widget.remove_accelerator obj group ~key ?modi
+ method lock_accelerators () = Widget.lock_accelerators obj
+ method set_name = Widget.set_name obj
+ method set_state = Widget.set_state obj
+ method set_sensitive = Widget.set_sensitive obj
+ method set_can_default = Widget.set_can_default obj
+ method set_can_focus = Widget.set_can_focus obj
+ method set_geometry ?(x = -2) ?(y = -2) ?(width = -2) ?(height = -2) () =
+ if x+y <> -4 then Widget.set_uposition obj ~x ~y;
+ if width+height <> -4 then Widget.set_usize obj ~width ~height
+ method set_style (style : style) = Widget.set_style obj style#as_style
+ (* get functions *)
+ method name = Widget.get_name obj
+ method toplevel =
+ try Some (new widget (Object.unsafe_cast (Widget.get_toplevel obj)))
+ with Gpointer.Null -> None
+ method window = Widget.window obj
+ method colormap = Widget.get_colormap obj
+ method visual = Widget.get_visual obj
+ method visual_depth = Gdk.Window.visual_depth (Widget.get_visual obj)
+ method pointer = Widget.get_pointer obj
+ method style = new style (Widget.get_style obj)
+ method visible = Widget.visible obj
+ method has_focus = Widget.has_focus obj
+ method parent =
+ try Some (new widget (Object.unsafe_cast (Widget.parent obj)))
+ with Gpointer.Null -> None
+ method set_app_paintable = Widget.set_app_paintable obj
+ method allocation = Widget.allocation obj
+end
+
+and widget obj = object (self)
+ inherit gtkobj obj
+ method as_widget = Widget.coerce obj
+ method misc = new misc_ops obj
+ method drag = new drag_ops (Object.unsafe_cast obj)
+ method coerce =
+ (self :> < destroy : _; get_id : _; as_widget : _; misc : _;
+ drag : _; coerce : _ >)
+end
+
+(* just to check that GDraw.misc_ops is compatible with misc_ops *)
+let _ = fun (x : #GDraw.misc_ops) -> (x : misc_ops)
+
+class widget_signals ?after (obj : [> `widget] obj) =
+ gtkobj_signals ?after obj
+
+(*
+class widget_coerce obj = object
+ inherit widget obj
+ method coerce = (self :> widget)
+end
+*)
+
+class widget_full obj = object
+ inherit widget obj
+ method connect = new widget_signals obj
+end
+
+let as_widget (w : widget) = w#as_widget
+
+let pack_return self ~packing ~show =
+ may packing ~f:(fun f -> (f (self :> widget) : unit));
+ if show <> Some false then self#misc#show ();
+ self
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+(* Object *)
+
+class gtkobj :
+ 'a obj ->
+ object
+ val obj : 'a obj
+ method destroy : unit -> unit
+ method get_id : int
+ end
+
+class gtkobj_signals :
+ ?after:bool -> 'a obj ->
+ object ('b)
+ val obj : 'a obj
+ val after : bool
+ method after : 'b
+ method destroy : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class gtkobj_misc : 'a obj ->
+ object
+ method get_type : string
+ method disconnect : GtkSignal.id -> unit
+ method handler_block : GtkSignal.id -> unit
+ method handler_unblock : GtkSignal.id -> unit
+ end
+
+(* Widget *)
+
+class event_signals :
+ ?after:bool -> [>`widget] obj ->
+ object ('a)
+ method after : 'a
+ method any :
+ callback:(Gdk.Tags.event_type Gdk.event -> bool) -> GtkSignal.id
+ method button_press : callback:(GdkEvent.Button.t -> bool) -> GtkSignal.id
+ method button_release :
+ callback:(GdkEvent.Button.t -> bool) -> GtkSignal.id
+ method configure : callback:(GdkEvent.Configure.t -> bool) -> GtkSignal.id
+ method delete : callback:([`DELETE] Gdk.event -> bool) -> GtkSignal.id
+ method destroy : callback:([`DESTROY] Gdk.event -> bool) -> GtkSignal.id
+ method enter_notify :
+ callback:(GdkEvent.Crossing.t -> bool) -> GtkSignal.id
+ method expose : callback:(GdkEvent.Expose.t -> bool) -> GtkSignal.id
+ method focus_in : callback:(GdkEvent.Focus.t -> bool) -> GtkSignal.id
+ method focus_out : callback:(GdkEvent.Focus.t -> bool) -> GtkSignal.id
+ method key_press : callback:(GdkEvent.Key.t -> bool) -> GtkSignal.id
+ method key_release : callback:(GdkEvent.Key.t -> bool) -> GtkSignal.id
+ method leave_notify :
+ callback:(GdkEvent.Crossing.t -> bool) -> GtkSignal.id
+ method map : callback:([`MAP] Gdk.event -> bool) -> GtkSignal.id
+ method motion_notify :
+ callback:(GdkEvent.Motion.t -> bool) -> GtkSignal.id
+ method property_notify :
+ callback:(GdkEvent.Property.t -> bool) -> GtkSignal.id
+ method proximity_in :
+ callback:(GdkEvent.Proximity.t -> bool) -> GtkSignal.id
+ method proximity_out :
+ callback:(GdkEvent.Proximity.t -> bool) -> GtkSignal.id
+ method selection_clear :
+ callback:(GdkEvent.Selection.t -> bool) -> GtkSignal.id
+ method selection_notify :
+ callback:(GdkEvent.Selection.t -> bool) -> GtkSignal.id
+ method selection_request :
+ callback:(GdkEvent.Selection.t -> bool) -> GtkSignal.id
+ method unmap : callback:([`UNMAP] Gdk.event -> bool) -> GtkSignal.id
+ end
+
+class event_ops : [>`widget] obj ->
+ object
+ method add : Gdk.Tags.event_mask list -> unit
+ method connect : event_signals
+ method send : Gdk.Tags.event_type Gdk.event -> bool
+ method set_extensions : Gdk.Tags.extension_events -> unit
+ end
+
+class style : Gtk.style ->
+ object ('a)
+ val style : Gtk.style
+ method as_style : Gtk.style
+ method bg : Tags.state_type -> Gdk.Color.t
+ method colormap : Gdk.colormap
+ method copy : 'a
+ method font : Gdk.font
+ method set_background : Gdk.window -> Tags.state_type -> unit
+ method set_bg : (Tags.state_type * GDraw.color) list -> unit
+ method set_font : Gdk.font -> unit
+ end
+
+class selection_data :
+ GtkData.Selection.t ->
+ object
+ val sel : GtkData.Selection.t
+ method data : string (* May raise Null_pointer *)
+ method format : int
+ method selection : Gdk.atom
+ method seltype : Gdk.atom
+ method target : Gdk.atom
+ method set : typ:Gdk.atom -> format:int -> ?data:string -> unit
+ end
+
+class drag_ops : [>`widget] obj ->
+ object
+ method connect : drag_signals
+ method dest_set :
+ ?flags:Tags.dest_defaults list ->
+ ?actions:Gdk.Tags.drag_action list -> target_entry list -> unit
+ method dest_unset : unit -> unit
+ method get_data : ?time:int -> context:drag_context -> Gdk.atom ->unit
+ method highlight : unit -> unit
+ method source_set :
+ ?modi:Gdk.Tags.modifier list ->
+ ?actions:Gdk.Tags.drag_action list -> target_entry list -> unit
+ method source_set_icon : ?colormap:Gdk.colormap -> GDraw.pixmap -> unit
+ method source_unset : unit -> unit
+ method unhighlight : unit -> unit
+ end
+
+and misc_ops :
+ [>`widget] obj ->
+ object
+ inherit gtkobj_misc
+ val obj : Gtk.widget obj
+ method activate : unit -> bool
+ method add_accelerator :
+ sgn:(Gtk.widget, unit -> unit) GtkSignal.t ->
+ group:accel_group -> ?modi:Gdk.Tags.modifier list ->
+ ?flags:Tags.accel_flag list -> Gdk.keysym -> unit
+ method allocation : rectangle
+ method colormap : Gdk.colormap
+ method connect : misc_signals
+ method draw : Gdk.Rectangle.t option -> unit
+ method grab_default : unit -> unit
+ method grab_focus : unit -> unit
+ method has_focus : bool
+ method hide : unit -> unit
+ method hide_all : unit -> unit
+ method intersect : Gdk.Rectangle.t -> Gdk.Rectangle.t option
+ method is_ancestor : widget -> bool
+ method lock_accelerators : unit -> unit
+ method map : unit -> unit
+ method name : string
+ method parent : widget option
+ method pointer : int * int
+ method popup : x:int -> y:int -> unit
+ method realize : unit -> unit
+ method remove_accelerator :
+ group:accel_group -> ?modi:Gdk.Tags.modifier list -> Gdk.keysym -> unit
+ method reparent : widget -> unit
+ method set_app_paintable : bool -> unit
+ method set_can_default : bool -> unit
+ method set_can_focus : bool -> unit
+ method set_name : string -> unit
+ method set_sensitive : bool -> unit
+ method set_state : Tags.state_type -> unit
+ method set_style : style -> unit
+ method set_geometry :
+ ?x:int -> ?y:int -> ?width:int -> ?height:int -> unit -> unit
+ method show : unit -> unit
+ method show_all : unit -> unit
+ method style : style
+ method toplevel : widget option
+ method unmap : unit -> unit
+ method unparent : unit -> unit
+ method unrealize : unit -> unit
+ method visible : bool
+ method visual : Gdk.visual
+ method visual_depth : int
+ method window : Gdk.window
+ end
+
+and widget :
+ 'a obj ->
+ object
+ inherit gtkobj
+ constraint 'a = [>`widget]
+ val obj : 'a obj
+ method as_widget : Gtk.widget obj
+ method coerce : widget
+ method drag : drag_ops
+ method misc : misc_ops
+ end
+
+and misc_signals :
+ ?after:bool -> Gtk.widget obj ->
+ object ('b)
+ inherit gtkobj_signals
+ val obj : Gtk.widget obj
+ method after : 'b
+ method draw : callback:(Gtk.rectangle -> unit) -> GtkSignal.id
+ method hide : callback:(unit -> unit) -> GtkSignal.id
+ method map : callback:(unit -> unit) -> GtkSignal.id
+ method parent_set : callback:(widget option -> unit) -> GtkSignal.id
+ method realize : callback:(unit -> unit) -> GtkSignal.id
+ method show : callback:(unit -> unit) -> GtkSignal.id
+ method state_changed :
+ callback:(Gtk.Tags.state_type -> unit) -> GtkSignal.id
+ method style_set : callback:(unit -> unit) -> GtkSignal.id
+ method unmap : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+and drag_context :
+ Gdk.drag_context ->
+ object
+ val context : Gdk.drag_context
+ method context : Gdk.drag_context
+ method finish : success:bool -> del:bool -> time:int -> unit
+ method source_widget : widget
+ method set_icon_pixmap :
+ ?colormap:Gdk.colormap -> GDraw.pixmap -> hot_x:int -> hot_y:int -> unit
+ method set_icon_widget : widget -> hot_x:int -> hot_y:int -> unit
+ method status : ?time:int -> Gdk.Tags.drag_action list -> unit
+ method suggested_action : Gdk.Tags.drag_action
+ method targets : Gdk.atom list
+ end
+
+and drag_signals :
+ ?after:bool -> Gtk.widget obj ->
+ object ('a)
+ method after : 'a
+ method beginning :
+ callback:(drag_context -> unit) -> GtkSignal.id
+ method data_delete :
+ callback:(drag_context -> unit) -> GtkSignal.id
+ method data_get :
+ callback:(drag_context -> selection_data -> info:int -> time:int -> unit)
+ -> GtkSignal.id
+ method data_received :
+ callback:(drag_context -> x:int -> y:int ->
+ selection_data -> info:int -> time:int -> unit) -> GtkSignal.id
+ method drop :
+ callback:(drag_context -> x:int -> y:int -> time:int -> bool) ->
+ GtkSignal.id
+ method ending :
+ callback:(drag_context -> unit) -> GtkSignal.id
+ method leave :
+ callback:(drag_context -> time:int -> unit) -> GtkSignal.id
+ method motion :
+ callback:(drag_context -> x:int -> y:int -> time:int -> bool) ->
+ GtkSignal.id
+ end
+
+class widget_signals : ?after:bool -> 'a obj ->
+ object
+ inherit gtkobj_signals
+ constraint 'a = [>`widget]
+ val obj : 'a obj
+ end
+
+class widget_full : 'a obj ->
+ object
+ inherit widget
+ constraint 'a = [>`widget]
+ val obj : 'a obj
+ method connect : widget_signals
+ end
+
+val as_widget : widget -> Gtk.widget obj
+
+val pack_return :
+ (#widget as 'a) ->
+ packing:(widget -> unit) option -> show:bool option -> 'a
+ (* To use in initializers to provide a ?packing: option *)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkPack
+open GObj
+open GContainer
+
+class box_skel obj = object
+ inherit container obj
+ method pack ?from:f ?expand ?fill ?padding w =
+ Box.pack obj (as_widget w) ?from:f ?expand ?fill ?padding
+ method set_homogeneous = Box.set_homogeneous obj
+ method set_spacing = Box.set_spacing obj
+ method set_child_packing ?from:f ?expand ?fill ?padding w =
+ Box.set_child_packing obj (as_widget w) ?from:f ?expand ?fill ?padding
+ method reorder_child w = Box.reorder_child obj (as_widget w)
+end
+
+class box obj = object
+ inherit box_skel obj
+ method connect = new container_signals obj
+end
+
+let box dir ?homogeneous ?spacing ?border_width ?width ?height
+ ?packing ?show () =
+ let w = Box.create dir ?homogeneous ?spacing () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new box w) ~packing ~show
+
+let vbox = box `VERTICAL
+let hbox = box `HORIZONTAL
+
+class button_box obj = object
+ inherit box_skel (obj : Gtk.button_box obj)
+ method connect = new container_signals obj
+ method set_layout = BBox.set_layout obj
+ method set_spacing = BBox.set_spacing obj
+ method set_child_size = BBox.set_child_size obj
+ method set_child_ipadding = BBox.set_child_ipadding obj
+end
+
+let button_box dir ?spacing ?child_width ?child_height ?child_ipadx
+ ?child_ipady ?layout ?border_width ?width ?height ?packing ?show ()=
+ let w = BBox.create dir in
+ BBox.set w ?spacing ?child_width ?child_height ?child_ipadx
+ ?child_ipady ?layout;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new button_box w) ~packing ~show
+
+class table obj = object
+ inherit container_full (obj : Gtk.table obj)
+ method attach ~left ~top ?right ?bottom ?expand ?fill ?shrink
+ ?xpadding ?ypadding w =
+ Table.attach obj (as_widget w) ~left ~top ?right ?bottom ?expand
+ ?fill ?shrink ?xpadding ?ypadding
+ method set_row_spacing = Table.set_row_spacing obj
+ method set_col_spacing = Table.set_col_spacing obj
+ method set_row_spacings = Table.set_row_spacings obj
+ method set_col_spacings = Table.set_col_spacings obj
+ method set_homogeneous = Table.set_homogeneous obj
+end
+
+let table ~rows ~columns ?homogeneous ?row_spacings ?col_spacings
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Table.create ~rows ~columns ?homogeneous () in
+ Table.set w ?row_spacings ?col_spacings;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new table w) ~packing ~show
+
+class fixed obj = object
+ inherit container_full (obj : Gtk.fixed obj)
+ method event = new GObj.event_ops obj
+ method put w = Fixed.put obj (as_widget w)
+ method move w = Fixed.move obj (as_widget w)
+end
+
+let fixed ?border_width ?width ?height ?packing ?show () =
+ let w = Fixed.create () in
+ Container.set w ?border_width ?width ?height;
+ pack_return (new fixed w) ~packing ~show
+
+class layout obj = object
+ inherit container_full (obj : Gtk.layout obj)
+ method event = new GObj.event_ops obj
+ method put w = Layout.put obj (as_widget w)
+ method move w = Layout.move obj (as_widget w)
+ method set_hadjustment adj =
+ Layout.set_hadjustment obj (GData.as_adjustment adj)
+ method set_vadjustment adj =
+ Layout.set_vadjustment obj (GData.as_adjustment adj)
+ method set_width width = Layout.set_size obj ~width
+ method set_height height = Layout.set_size obj ~height
+ method hadjustment = new GData.adjustment (Layout.get_hadjustment obj)
+ method vadjustment = new GData.adjustment (Layout.get_vadjustment obj)
+ method freeze () = Layout.freeze obj
+ method thaw () = Layout.thaw obj
+ method width = Layout.get_width obj
+ method height = Layout.get_height obj
+end
+
+let layout ?hadjustment ?vadjustment ?layout_width ?layout_height
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Layout.create
+ (Gpointer.optboxed (may_map ~f:GData.as_adjustment hadjustment))
+ (Gpointer.optboxed (may_map ~f:GData.as_adjustment vadjustment)) in
+ if layout_width <> None || layout_height <> None then
+ Layout.set_size w ?width:layout_width ?height:layout_height;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new layout w) ~packing ~show
+
+
+class packer obj = object
+ inherit container_full (obj : Gtk.packer obj)
+ method pack ?side ?anchor ?expand ?fill
+ ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y w =
+ let options = Packer.build_options ?expand ?fill () in
+ if border_width == None && pad_x == None && pad_y == None &&
+ i_pad_x == None && i_pad_y == None
+ then Packer.add_defaults obj (as_widget w) ?side ?anchor ~options
+ else Packer.add obj (as_widget w) ?side ?anchor ~options
+ ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y
+ method set_child_packing ?side ?anchor ?expand ?fill
+ ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y w =
+ Packer.set_child_packing obj (as_widget w) ?side ?anchor
+ ~options:(Packer.build_options ?expand ?fill ())
+ ?border_width ?pad_x ?pad_y ?i_pad_x ?i_pad_y
+ method reorder_child w = Packer.reorder_child obj (as_widget w)
+ method set_spacing = Packer.set_spacing obj
+ method set_defaults = Packer.set_defaults obj
+end
+
+let packer ?spacing ?border_width ?width ?height ?packing ?show () =
+ let w = Packer.create () in
+ may spacing ~f:(Packer.set_spacing w);
+ Container.set w ?border_width ?width ?height;
+ pack_return (new packer w) ~packing ~show
+
+class paned obj = object
+ inherit container_full (obj : Gtk.paned obj)
+ method event = new GObj.event_ops obj
+ method add w =
+ if List.length (Container.children obj) = 2 then
+ raise(Error "Gpack.paned#add: already full");
+ Container.add obj (as_widget w)
+ method add1 w =
+ try ignore(Paned.child1 obj); raise(Error "GPack.paned#add1: already full")
+ with _ -> Paned.add1 obj (as_widget w)
+ method add2 w =
+ try ignore(Paned.child2 obj); raise(Error "GPack.paned#add2: already full")
+ with _ -> Paned.add2 obj (as_widget w)
+ method set_handle_size = Paned.set_handle_size obj
+ method set_gutter_size = Paned.set_gutter_size obj
+ method child1 = new widget (Paned.child1 obj)
+ method child2 = new widget (Paned.child2 obj)
+ method handle_size = Paned.handle_size obj
+ method gutter_size = Paned.gutter_size obj
+end
+
+let paned dir ?handle_size ?gutter_size
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Paned.create dir in
+ Paned.set w ?handle_size ?gutter_size;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new paned w) ~packing ~show
+
+class notebook_signals obj = object
+ inherit GContainer.container_signals obj
+ method switch_page =
+ GtkSignal.connect obj ~sgn:Notebook.Signals.switch_page ~after
+end
+
+class notebook obj = object (self)
+ inherit GContainer.container obj
+ method event = new GObj.event_ops obj
+ method connect = new notebook_signals obj
+ method insert_page ?tab_label ?menu_label ~pos child =
+ Notebook.insert_page obj (as_widget child) ~pos
+ ~tab_label:(Gpointer.may_box tab_label ~f:as_widget)
+ ~menu_label:(Gpointer.may_box menu_label ~f:as_widget)
+ method append_page = self#insert_page ~pos:(-1)
+ method prepend_page = self#insert_page ~pos:0
+ method remove_page = Notebook.remove_page obj
+ method current_page = Notebook.get_current_page obj
+ method goto_page = Notebook.set_page obj
+ method previous_page () = Notebook.prev_page obj
+ method next_page () = Notebook.next_page obj
+ method set_tab_pos = Notebook.set_tab_pos obj
+ method set_show_tabs = Notebook.set_show_tabs obj
+ method set_homogeneous_tabs = Notebook.set_homogeneous_tabs obj
+ method set_show_border = Notebook.set_show_border obj
+ method set_scrollable = Notebook.set_scrollable obj
+ method set_tab_border = Notebook.set_tab_border obj
+ method set_popup = Notebook.set_popup obj
+ method page_num w = Notebook.page_num obj (as_widget w)
+ method get_nth_page n = new widget (Notebook.get_nth_page obj n)
+ method get_tab_label w =
+ new widget (Notebook.get_tab_label obj (as_widget w))
+ method get_menu_label w =
+ new widget (Notebook.get_tab_label obj (as_widget w))
+ method set_page ?tab_label ?menu_label page =
+ let child = as_widget page in
+ may tab_label
+ ~f:(fun lbl -> Notebook.set_tab_label obj child (as_widget lbl));
+ may menu_label
+ ~f:(fun lbl -> Notebook.set_menu_label obj child (as_widget lbl))
+end
+
+let notebook ?tab_pos ?tab_border ?show_tabs ?homogeneous_tabs
+ ?show_border ?scrollable ?popup
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Notebook.create () in
+ Notebook.set w ?tab_pos ?tab_border ?show_tabs
+ ?homogeneous_tabs ?show_border ?scrollable ?popup;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new notebook w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class box_skel :
+ 'a obj ->
+ object
+ inherit container
+ constraint 'a = [>`box|`container|`widget]
+ val obj : 'a obj
+ method pack :
+ ?from:Tags.pack_type ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> widget -> unit
+ method reorder_child : widget -> pos:int -> unit
+ method set_child_packing :
+ ?from:Tags.pack_type ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> widget -> unit
+ method set_homogeneous : bool -> unit
+ method set_spacing : int -> unit
+ end
+class box :
+ 'a obj ->
+ object
+ inherit box_skel
+ constraint 'a = [>`box|`container|`widget]
+ val obj : 'a obj
+ method connect : GContainer.container_signals
+ end
+
+val box :
+ Tags.orientation ->
+ ?homogeneous:bool ->
+ ?spacing:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int -> ?packing:(widget -> unit) -> ?show:bool -> unit -> box
+val vbox :
+ ?homogeneous:bool ->
+ ?spacing:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int -> ?packing:(widget -> unit) -> ?show:bool -> unit -> box
+val hbox :
+ ?homogeneous:bool ->
+ ?spacing:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int -> ?packing:(widget -> unit) -> ?show:bool -> unit -> box
+
+class button_box :
+ Gtk.button_box obj ->
+ object
+ inherit container_full
+ val obj : Gtk.button_box obj
+ method pack :
+ ?from:Tags.pack_type ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> widget -> unit
+ method reorder_child : widget -> pos:int -> unit
+ method set_child_ipadding : ?x:int -> ?y:int -> unit -> unit
+ method set_child_packing :
+ ?from:Tags.pack_type ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> widget -> unit
+ method set_child_size : ?width:int -> ?height:int -> unit -> unit
+ method set_homogeneous : bool -> unit
+ method set_layout : GtkPack.BBox.bbox_style -> unit
+ method set_spacing : int -> unit
+ end
+val button_box :
+ Tags.orientation ->
+ ?spacing:int ->
+ ?child_width:int ->
+ ?child_height:int ->
+ ?child_ipadx:int ->
+ ?child_ipady:int ->
+ ?layout:GtkPack.BBox.bbox_style ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> button_box
+
+class table :
+ Gtk.table obj ->
+ object
+ inherit container_full
+ val obj : Gtk.table obj
+ method attach :
+ left:int ->
+ top:int ->
+ ?right:int ->
+ ?bottom:int ->
+ ?expand:Tags.expand_type ->
+ ?fill:Tags.expand_type ->
+ ?shrink:Tags.expand_type ->
+ ?xpadding:int -> ?ypadding:int -> widget -> unit
+ method set_col_spacing : int -> int -> unit
+ method set_col_spacings : int -> unit
+ method set_homogeneous : bool -> unit
+ method set_row_spacing : int -> int -> unit
+ method set_row_spacings : int -> unit
+ end
+val table :
+ rows:int ->
+ columns:int ->
+ ?homogeneous:bool ->
+ ?row_spacings:int ->
+ ?col_spacings:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> table
+
+class fixed :
+ Gtk.fixed obj ->
+ object
+ inherit container_full
+ val obj : Gtk.fixed obj
+ method event : event_ops
+ method move : widget -> x:int -> y:int -> unit
+ method put : widget -> x:int -> y:int -> unit
+ end
+val fixed :
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> fixed
+
+class layout :
+ Gtk.layout obj ->
+ object
+ inherit container_full
+ val obj : Gtk.layout obj
+ method event : event_ops
+ method freeze : unit -> unit
+ method hadjustment : GData.adjustment
+ method height : int
+ method move : widget -> x:int -> y:int -> unit
+ method put : widget -> x:int -> y:int -> unit
+ method set_hadjustment : GData.adjustment -> unit
+ method set_height : int -> unit
+ method set_vadjustment : GData.adjustment -> unit
+ method set_width : int -> unit
+ method thaw : unit -> unit
+ method vadjustment : GData.adjustment
+ method width : int
+ end
+val layout :
+ ?hadjustment:GData.adjustment ->
+ ?vadjustment:GData.adjustment ->
+ ?layout_width:int ->
+ ?layout_height:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> layout
+
+class notebook_signals : 'a obj ->
+ object
+ inherit container_signals
+ constraint 'a = [>`notebook|`container|`widget]
+ val obj : 'a obj
+ method switch_page : callback:(int -> unit) -> GtkSignal.id
+ end
+
+class notebook : ([> `widget | `container | `notebook] as 'a) obj ->
+ object
+ inherit container
+ val obj : 'a obj
+ method event : event_ops
+ method append_page :
+ ?tab_label:widget -> ?menu_label:widget -> widget -> unit
+ method connect : notebook_signals
+ method current_page : int
+ method get_menu_label : widget -> widget
+ method get_nth_page : int -> widget
+ method get_tab_label : widget -> widget
+ method goto_page : int -> unit
+ method insert_page :
+ ?tab_label:widget -> ?menu_label:widget -> pos:int -> widget -> unit
+ method next_page : unit -> unit
+ method page_num : widget -> int
+ method prepend_page :
+ ?tab_label:widget -> ?menu_label:widget -> widget -> unit
+ method previous_page : unit -> unit
+ method remove_page : int -> unit
+ method set_homogeneous_tabs : bool -> unit
+ method set_page :
+ ?tab_label:widget -> ?menu_label:widget -> widget -> unit
+ method set_popup : bool -> unit
+ method set_scrollable : bool -> unit
+ method set_show_border : bool -> unit
+ method set_show_tabs : bool -> unit
+ method set_tab_border : int -> unit
+ method set_tab_pos : Tags.position -> unit
+ end
+val notebook :
+ ?tab_pos:Tags.position ->
+ ?tab_border:int ->
+ ?show_tabs:bool ->
+ ?homogeneous_tabs:bool ->
+ ?show_border:bool ->
+ ?scrollable:bool ->
+ ?popup:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> notebook
+
+class packer :
+ Gtk.packer obj ->
+ object
+ inherit container_full
+ val obj : Gtk.packer obj
+ method pack :
+ ?side:Tags.side_type ->
+ ?anchor:Tags.anchor_type ->
+ ?expand:bool ->
+ ?fill:Tags.expand_type ->
+ ?border_width:int ->
+ ?pad_x:int ->
+ ?pad_y:int -> ?i_pad_x:int -> ?i_pad_y:int -> widget -> unit
+ method reorder_child : widget -> pos:int -> unit
+ method set_child_packing :
+ ?side:Tags.side_type ->
+ ?anchor:Tags.anchor_type ->
+ ?expand:bool ->
+ ?fill:Tags.expand_type ->
+ ?border_width:int ->
+ ?pad_x:int ->
+ ?pad_y:int -> ?i_pad_x:int -> ?i_pad_y:int -> widget -> unit
+ method set_defaults :
+ ?border_width:int ->
+ ?pad_x:int ->
+ ?pad_y:int -> ?i_pad_x:int -> ?i_pad_y:int -> unit -> unit
+ method set_spacing : int -> unit
+ end
+val packer :
+ ?spacing:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> packer
+
+class paned :
+ Gtk.paned obj ->
+ object
+ inherit container_full
+ val obj : Gtk.paned obj
+ method add1 : widget -> unit
+ method add2 : widget -> unit
+ method event : event_ops
+ method child1 : widget
+ method child2 : widget
+ method gutter_size : int
+ method handle_size : int
+ method set_gutter_size : int -> unit
+ method set_handle_size : int -> unit
+ end
+val paned :
+ Tags.orientation ->
+ ?handle_size:int ->
+ ?gutter_size:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> paned
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkRange
+open GObj
+
+class progress obj = object
+ inherit widget_full obj
+ method set_adjustment adj =
+ Progress.set_adjustment obj (GData.as_adjustment adj)
+ method set_show_text = Progress.set_show_text obj
+ method set_format_string = Progress.set_format_string obj
+ method set_text_alignment = Progress.set_text_alignment obj
+ method set_activity_mode = Progress.set_activity_mode obj
+ method set_value = Progress.set_value obj
+ method set_percentage = Progress.set_percentage obj
+ method configure = Progress.configure obj
+ method value = Progress.get_value obj
+ method percentage = Progress.get_percentage obj
+ method current_text = Progress.get_current_text obj
+ method adjustment = new GData.adjustment (Progress.get_adjustment obj)
+end
+
+class progress_bar obj = object
+ inherit progress (obj : Gtk.progress_bar obj)
+ method event = new GObj.event_ops obj
+ method set_bar_style = ProgressBar.set_bar_style obj
+ method set_discrete_blocks = ProgressBar.set_discrete_blocks obj
+ method set_activity_step = ProgressBar.set_activity_step obj
+ method set_activity_blocks = ProgressBar.set_activity_blocks obj
+ method set_orientation = ProgressBar.set_orientation obj
+end
+
+let progress_bar ?adjustment ?bar_style ?discrete_blocks
+ ?activity_step ?activity_blocks ?value ?percentage ?activity_mode
+ ?show_text ?format_string ?text_xalign ?text_yalign
+ ?packing ?show () =
+ let w =
+ match adjustment with None -> ProgressBar.create ()
+ | Some adj ->
+ ProgressBar.create_with_adjustment (GData.as_adjustment adj)
+ in
+ ProgressBar.set w ?bar_style ?discrete_blocks
+ ?activity_step ?activity_blocks;
+ Progress.set w ?value ?percentage ?activity_mode
+ ?show_text ?format_string ?text_xalign ?text_yalign;
+ pack_return (new progress_bar w) ~packing ~show
+
+class range obj = object
+ inherit widget_full obj
+ method adjustment = new GData.adjustment (Range.get_adjustment obj)
+ method set_adjustment adj =
+ Range.set_adjustment obj (GData.as_adjustment adj)
+ method set_update_policy = Range.set_update_policy obj
+end
+
+class scale obj = object
+ inherit range (obj : Gtk.scale obj)
+ method set_digits = Scale.set_digits obj
+ method set_draw_value = Scale.set_draw_value obj
+ method set_value_pos = Scale.set_value_pos obj
+end
+
+let scale dir ?adjustment ?digits ?draw_value ?value_pos
+ ?packing ?show () =
+ let w =
+ Scale.create dir ?adjustment:(may_map ~f:GData.as_adjustment adjustment)
+ in
+ let () = Scale.set w ?digits ?draw_value ?value_pos in
+ pack_return (new scale w) ~packing ~show
+
+class scrollbar obj = object
+ inherit range (obj : Gtk.scrollbar obj)
+ method event = new GObj.event_ops obj
+end
+
+let scrollbar dir ?adjustment ?update_policy ?packing ?show () =
+ let w = Scrollbar.create dir
+ ?adjustment:(may_map ~f:GData.as_adjustment adjustment) in
+ let () = may update_policy ~f:(Range.set_update_policy w) in
+ pack_return (new scrollbar w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+class progress : 'a obj ->
+ object
+ inherit widget_full
+ constraint 'a = [>`progress|`widget]
+ val obj : 'a obj
+ method adjustment : GData.adjustment
+ method configure : current:float -> min:float -> max:float -> unit
+ method current_text : string
+ method percentage : float
+ method set_activity_mode : bool -> unit
+ method set_adjustment : GData.adjustment -> unit
+ method set_format_string : string -> unit
+ method set_percentage : float -> unit
+ method set_show_text : bool -> unit
+ method set_text_alignment : ?x:float -> ?y:float -> unit -> unit
+ method set_value : float -> unit
+ method value : float
+ end
+
+class progress_bar : Gtk.progress_bar obj ->
+ object
+ inherit progress
+ val obj : Gtk.progress_bar obj
+ method event : event_ops
+ method set_activity_blocks : int -> unit
+ method set_activity_step : int -> unit
+ method set_bar_style : [`CONTINUOUS|`DISCRETE] -> unit
+ method set_discrete_blocks : int -> unit
+ method set_orientation : Tags.progress_bar_orientation -> unit
+ end
+val progress_bar :
+ ?adjustment:GData.adjustment ->
+ ?bar_style:[`CONTINUOUS|`DISCRETE] ->
+ ?discrete_blocks:int ->
+ ?activity_step:int ->
+ ?activity_blocks:int ->
+ ?value:float ->
+ ?percentage:float ->
+ ?activity_mode:bool ->
+ ?show_text:bool ->
+ ?format_string:string ->
+ ?text_xalign:float ->
+ ?text_yalign:float ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> progress_bar
+
+class range : 'a obj ->
+ object
+ inherit widget_full
+ constraint 'a = [>`range|`widget]
+ val obj : 'a obj
+ method adjustment : GData.adjustment
+ method set_adjustment : GData.adjustment -> unit
+ method set_update_policy : Tags.update_type -> unit
+ end
+
+class scale : Gtk.scale obj ->
+ object
+ inherit range
+ val obj : Gtk.scale obj
+ method set_digits : int -> unit
+ method set_draw_value : bool -> unit
+ method set_value_pos : Tags.position -> unit
+ end
+val scale :
+ Tags.orientation ->
+ ?adjustment:GData.adjustment ->
+ ?digits:int ->
+ ?draw_value:bool ->
+ ?value_pos:Tags.position ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> scale
+
+class scrollbar : Gtk.scrollbar obj ->
+ object
+ inherit range
+ val obj : Gtk.scrollbar obj
+ method event : event_ops
+ end
+val scrollbar :
+ Tags.orientation ->
+ ?adjustment:GData.adjustment ->
+ ?update_policy:Tags.update_type ->
+ ?packing:(widget -> unit) -> ?show:bool -> unit -> scrollbar
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkTree
+open GObj
+open GContainer
+
+class tree_item_signals obj = object
+ inherit item_signals obj
+ method expand = GtkSignal.connect obj ~sgn:TreeItem.Signals.expand ~after
+ method collapse = GtkSignal.connect obj ~sgn:TreeItem.Signals.collapse ~after
+end
+
+class tree_item obj = object
+ inherit container obj
+ method event = new GObj.event_ops obj
+ method as_item : Gtk.tree_item obj = obj
+ method connect = new tree_item_signals obj
+ method set_subtree (w : tree) = TreeItem.set_subtree obj w#as_tree
+ method remove_subtree () = TreeItem.remove_subtree obj
+ method expand () = TreeItem.expand obj
+ method collapse () = TreeItem.collapse obj
+ method subtree =
+ try Some(new tree (TreeItem.subtree obj)) with Gpointer.Null -> None
+end
+
+and tree_signals obj = object
+ inherit container_signals obj
+ method selection_changed =
+ GtkSignal.connect obj ~sgn:Tree.Signals.selection_changed ~after
+ method select_child ~callback =
+ GtkSignal.connect obj ~sgn:Tree.Signals.select_child ~after
+ ~callback:(fun w -> callback (new tree_item (TreeItem.cast w)))
+ method unselect_child ~callback =
+ GtkSignal.connect obj ~sgn:Tree.Signals.unselect_child ~after
+ ~callback:(fun w -> callback (new tree_item (TreeItem.cast w)))
+end
+
+and tree obj = object (self)
+ inherit [tree_item] item_container obj
+ method event = new GObj.event_ops obj
+ method as_tree = Tree.coerce obj
+ method insert w ~pos = Tree.insert obj w#as_item ~pos
+ method connect = new tree_signals obj
+ method clear_items = Tree.clear_items obj
+ method select_item = Tree.select_item obj
+ method unselect_item = Tree.unselect_item obj
+ method child_position (w : tree_item) = Tree.child_position obj w#as_item
+ method remove_items items =
+ Tree.remove_items obj
+ (List.map ~f:(fun (t : tree_item) -> t#as_item) items)
+ method set_selection_mode = Tree.set_selection_mode obj
+ method set_view_mode = Tree.set_view_mode obj
+ method set_view_lines = Tree.set_view_lines obj
+ method selection =
+ List.map ~f:(fun w -> self#wrap (Widget.coerce w)) (Tree.selection obj)
+ method private wrap w =
+ new tree_item (TreeItem.cast w)
+end
+
+let tree_item ?label ?border_width ?width ?height ?packing ?show () =
+ let w = TreeItem.create ?label () in
+ Container.set w ?border_width ?width ?height;
+ let self = new tree_item w in
+ may packing ~f:(fun f -> (f self : unit));
+ if show <> Some false then self#misc#show ();
+ self
+
+let tree ?selection_mode ?view_mode ?view_lines
+ ?border_width ?width ?height ?packing ?show () =
+ let w = Tree.create () in
+ Tree.set w ?selection_mode ?view_mode ?view_lines;
+ Container.set w ?border_width ?width ?height;
+ pack_return (new tree w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+open GContainer
+
+class tree_item_signals : 'a obj ->
+ object
+ inherit item_signals
+ constraint 'a = [>`treeitem|`container|`item|`widget]
+ val obj : 'a obj
+ method collapse : callback:(unit -> unit) -> GtkSignal.id
+ method expand : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class tree_item : Gtk.tree_item obj ->
+ object
+ inherit GContainer.container
+ val obj : Gtk.tree_item obj
+ method event : event_ops
+ method as_item : Gtk.tree_item obj
+ method collapse : unit -> unit
+ method connect : tree_item_signals
+ method expand : unit -> unit
+ method remove_subtree : unit -> unit
+ method set_subtree : tree -> unit
+ method subtree : tree option
+ end
+
+and tree_signals : Gtk.tree obj ->
+ object
+ inherit container_signals
+ val obj : Gtk.tree obj
+ method select_child : callback:(tree_item -> unit) -> GtkSignal.id
+ method selection_changed : callback:(unit -> unit) -> GtkSignal.id
+ method unselect_child : callback:(tree_item -> unit) -> GtkSignal.id
+ end
+
+and tree : Gtk.tree obj ->
+ object
+ inherit [tree_item] item_container
+ val obj : Gtk.tree obj
+ method event : event_ops
+ method as_tree : Gtk.tree obj
+ method child_position : tree_item -> int
+ method clear_items : start:int -> stop:int -> unit
+ method connect : tree_signals
+ method insert : tree_item -> pos:int -> unit
+ method remove_items : tree_item list -> unit
+ method select_item : pos:int -> unit
+ method selection : tree_item list
+ method set_selection_mode : Tags.selection_mode -> unit
+ method set_view_lines : bool -> unit
+ method set_view_mode : [`LINE|`ITEM] -> unit
+ method unselect_item : pos:int -> unit
+ method private wrap : Gtk.widget obj -> tree_item
+ end
+
+val tree_item :
+ ?label:string ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(tree_item -> unit) -> ?show:bool -> unit -> tree_item
+
+val tree :
+ ?selection_mode:Tags.selection_mode ->
+ ?view_mode:[`LINE|`ITEM] ->
+ ?view_lines:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> tree
--- /dev/null
+(* $Id$ *)
+
+open GObj
+
+class ['a] memo () = object
+ constraint 'a = #widget
+ val tbl = Hashtbl.create 7
+ method add (obj : 'a) =
+ Hashtbl.add tbl ~key:obj#get_id ~data:obj
+ method find (obj : widget) = Hashtbl.find tbl obj#get_id
+ method remove (obj : widget) = Hashtbl.remove tbl obj#get_id
+end
+
+let signal_id = ref 0
+
+let next_callback_id () : GtkSignal.id =
+ decr signal_id; Obj.magic (!signal_id : int)
+
+class ['a] signal () = object (self)
+ val mutable callbacks : (GtkSignal.id * ('a -> unit)) list = []
+ method callbacks = callbacks
+ method connect ~after ~callback =
+ let id = next_callback_id () in
+ callbacks <-
+ if after then callbacks @ [id,callback] else (id,callback)::callbacks;
+ id
+ method call arg =
+ List.exists callbacks ~f:
+ begin fun (_,f) ->
+ let old = GtkSignal.push_callback () in
+ try f arg; GtkSignal.pop_callback old
+ with exn -> GtkSignal.pop_callback old; raise exn
+ end;
+ ()
+ method disconnect key =
+ List.mem_assoc key callbacks &&
+ (callbacks <- List.remove_assoc key callbacks; true)
+end
+
+class virtual ml_signals disconnectors =
+ object (self)
+ val after = false
+ method after = {< after = true >}
+ val mutable disconnectors : (GtkSignal.id -> bool) list = disconnectors
+ method disconnect key =
+ ignore (List.exists disconnectors ~f:(fun f -> f key))
+ end
+
+class virtual add_ml_signals obj disconnectors =
+ object (self)
+ val mutable disconnectors : (GtkSignal.id -> bool) list = disconnectors
+ method disconnect key =
+ if List.exists disconnectors ~f:(fun f -> f key) then ()
+ else GtkSignal.disconnect obj key
+ end
+
+class ['a] variable_signals ~(set : 'a signal) ~(changed : 'a signal) =
+ object
+ inherit ml_signals [changed#disconnect; set#disconnect]
+ method changed = changed#connect ~after
+ method set = set#connect ~after
+ end
+
+class ['a] variable x =
+ object (self)
+ val changed = new signal ()
+ val set = new signal ()
+ method connect = new variable_signals ~set ~changed
+ val mutable x : 'a = x
+ method get = x
+ method set = set#call
+ method private equal : 'a -> 'a -> bool = (=)
+ method private real_set y =
+ let x0 = x in x <- y;
+ if changed#callbacks <> [] && not (self#equal x x0)
+ then changed#call y
+ initializer
+ ignore (set#connect ~after:false ~callback:self#real_set)
+ end
+
--- /dev/null
+(* $Id$ *)
+
+open GObj
+
+(* The memo class provides an easy way to remember the real class of
+ a widget.
+ Insert all widgets of class in one single t memo, and you can then
+ recover their original ML object with #find.
+*)
+
+class ['a] memo : unit ->
+ object
+ constraint 'a = #widget
+ val tbl : (int, 'a) Hashtbl.t
+ method add : 'a -> unit
+ method find : widget -> 'a
+ method remove : widget -> unit
+ end
+
+(* The ML signal mechanism allows one to add GTK-like signals to
+ arbitrary objects.
+*)
+
+val next_callback_id : unit -> GtkSignal.id
+
+class ['a] signal :
+ unit ->
+ object
+ val mutable callbacks : (GtkSignal.id * ('a -> unit)) list
+ method callbacks : (GtkSignal.id * ('a -> unit)) list
+ method call : 'a -> unit
+ method connect : after:bool -> callback:('a -> unit) -> GtkSignal.id
+ method disconnect : GtkSignal.id -> bool
+ end
+(* As with GTK signals, you can use [GtkSignal.stop_emit] inside a
+ callback to prevent other callbacks from being called. *)
+
+class virtual ml_signals : (GtkSignal.id -> bool) list ->
+ object ('a)
+ val after : bool
+ method after : 'a
+ method disconnect : GtkSignal.id -> unit
+ val mutable disconnectors : (GtkSignal.id -> bool) list
+ end
+class virtual add_ml_signals :
+ 'a Gtk.obj -> (GtkSignal.id -> bool) list ->
+ object
+ method disconnect : GtkSignal.id -> unit
+ val mutable disconnectors : (GtkSignal.id -> bool) list
+ end
+
+(* To add ML signals to a LablGTK object:
+
+ class mywidget_signals obj ~mysignal1 ~mysignal2 = object
+ inherit somewidget_signals obj
+ inherit add_ml_signals obj [mysignal1#disconnect; mysignal2#disconnect]
+ method mysignal1 = mysignal1#connect ~after
+ method mysignal2 = mysignal2#connect ~after
+ end
+
+ class mywidget obj = object (self)
+ inherit somewidget obj
+ val mysignal1 = new signal obj
+ val mysignal2 = new signal obj
+ method connect = new mywidget_signals obj ~mysignal1 ~mysignal2
+ method call1 = mysignal1#call
+ method call2 = mysignal2#call
+ end
+
+ You can also add ML signals to an arbitrary object; just inherit
+ from [ml_signals] in place of [widget_signals]+[add_ml_signals].
+
+ class mysignals ~mysignal1 ~mysignal2 = object
+ inherit ml_signals [mysignal1#disconnect; mysignal2#disconnect]
+ method mysignal1 = mysignal1#connect ~after
+ method mysignal2 = mysignal2#connect ~after
+ end
+*)
+
+(* The variable class provides an easy way to propagate state modifications.
+ A new variable is created by [new variable init]. The [#set] method just
+ calls the [set] signal, which by default only calls [real_set].
+ [real_set] sets the variable and calls [changed] when needed.
+ Deep equality is used to compare values, but check is only done if
+ there are callbacks for [changed].
+*)
+
+class ['a] variable_signals :
+ set:'a signal -> changed:'a signal ->
+ object ('b)
+ val after : bool
+ method after : 'b
+ method set : callback:('a -> unit) -> GtkSignal.id
+ method changed : callback:('a -> unit) -> GtkSignal.id
+ method disconnect : GtkSignal.id -> unit
+ val mutable disconnectors : (GtkSignal.id -> bool) list
+ end
+
+class ['a] variable : 'a ->
+ object
+ val set : 'a signal
+ val changed : 'a signal
+ val mutable x : 'a
+ method connect : 'a variable_signals
+ method get : 'a
+ method set : 'a -> unit
+ method private equal : 'a -> 'a -> bool
+ method private real_set : 'a -> unit
+ end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+open GtkWindow
+open GtkMisc
+open GObj
+open GContainer
+
+class ['a] window_skel obj = object
+ constraint 'a = _ #window_skel
+ inherit container obj
+ method event = new GObj.event_ops obj
+ method as_window = Window.coerce obj
+ method activate_focus () = Window.activate_focus obj
+ method activate_default () = Window.activate_default obj
+ method add_accel_group = Window.add_accel_group obj
+ method set_modal = Window.set_modal obj
+ method set_default_size = Window.set_default_size obj
+ method set_position = Window.set_position obj
+ method set_resize_mode = Container.set_resize_mode obj
+ method set_transient_for (w : 'a) =
+ Window.set_transient_for obj w#as_window
+ method set_title = Window.set_title obj
+ method set_wm_name name = Window.set_wmclass obj ~name
+ method set_wm_class cls = Window.set_wmclass obj ~clas:cls
+ method set_allow_shrink allow_shrink = Window.set_policy obj ~allow_shrink
+ method set_allow_grow allow_grow = Window.set_policy obj ~allow_grow
+ method set_auto_shrink auto_shrink = Window.set_policy obj ~auto_shrink
+ method show () = Widget.show obj
+end
+
+class window obj = object
+ inherit [window] window_skel (Window.coerce obj)
+ method connect = new container_signals obj
+end
+
+let window ?kind:(t=`TOPLEVEL) ?title ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y
+ ?border_width ?width ?height ?(show=false) () =
+ let w = Window.create t in
+ Window.set w ?title ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y;
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new window w
+
+class dialog obj = object
+ inherit [window] window_skel (Dialog.coerce obj)
+ method connect = new container_signals obj
+ method action_area = new GPack.box (Dialog.action_area obj)
+ method vbox = new GPack.box (Dialog.vbox obj)
+end
+
+let dialog ?title ?wm_name ?wm_class ?position ?allow_shrink
+ ?allow_grow ?auto_shrink ?modal ?x ?y ?border_width ?width ?height
+ ?(show=false) () =
+ let w = Dialog.create () in
+ Window.set w ?title ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y;
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new dialog w
+
+class color_selection_dialog obj = object
+ inherit [window] window_skel (obj : Gtk.color_selection_dialog obj)
+ method connect = new container_signals obj
+ method ok_button =
+ new GButton.button (ColorSelection.ok_button obj)
+ method cancel_button =
+ new GButton.button (ColorSelection.cancel_button obj)
+ method help_button =
+ new GButton.button (ColorSelection.help_button obj)
+ method colorsel =
+ new GMisc.color_selection (ColorSelection.colorsel obj)
+end
+
+let color_selection_dialog ?(title="Pick a color")
+ ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y
+ ?border_width ?width ?height ?(show=false) () =
+ let w = ColorSelection.create_dialog title in
+ Window.set w ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y;
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new color_selection_dialog w
+
+class file_selection obj = object
+ inherit [window] window_skel (obj : Gtk.file_selection obj)
+ method connect = new container_signals obj
+ method set_filename = FileSelection.set_filename obj
+ method get_filename = FileSelection.get_filename obj
+ method set_fileop_buttons = FileSelection.set_fileop_buttons obj
+ method ok_button = new GButton.button (FileSelection.get_ok_button obj)
+ method cancel_button =
+ new GButton.button (FileSelection.get_cancel_button obj)
+ method help_button = new GButton.button (FileSelection.get_help_button obj)
+end
+
+let file_selection ?(title="Choose a file") ?filename
+ ?(fileop_buttons=false)
+ ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y
+ ?border_width ?width ?height ?(show=false) () =
+ let w = FileSelection.create title in
+ FileSelection.set w ?filename ~fileop_buttons;
+ Window.set w ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y;
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new file_selection w
+
+class font_selection_dialog obj = object
+ inherit [window] window_skel (obj : Gtk.font_selection_dialog obj)
+ method connect = new container_signals obj
+(*
+ method font = FontSelectionDialog.get_font obj
+ method font_name = FontSelectionDialog.get_font_name obj
+ method set_font_name = FontSelectionDialog.set_font_name obj
+ method preview_text = FontSelectionDialog.get_preview_text obj
+ method set_preview_text = FontSelectionDialog.set_preview_text obj
+ method set_filter = FontSelectionDialog.set_filter obj
+*)
+ method selection =
+ new GMisc.font_selection (FontSelectionDialog.font_selection obj)
+ method ok_button = new GButton.button (FontSelectionDialog.ok_button obj)
+ method apply_button =
+ new GButton.button (FontSelectionDialog.apply_button obj)
+ method cancel_button =
+ new GButton.button (FontSelectionDialog.cancel_button obj)
+end
+
+let font_selection_dialog ?title ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y
+ ?border_width ?width ?height ?(show=false) () =
+ let w = FontSelectionDialog.create ?title () in
+ Window.set w ?wm_name ?wm_class ?position
+ ?allow_shrink ?allow_grow ?auto_shrink ?modal ?x ?y;
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new font_selection_dialog w
+
+class plug (obj : Gtk.plug obj) = window obj
+
+let plug ~window:xid ?border_width ?width ?height ?(show=false) () =
+ let w = Plug.create xid in
+ Container.set w ?border_width ?width ?height;
+ if show then Widget.show w;
+ new plug w
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+class ['a] window_skel : 'b obj ->
+ object
+ inherit GContainer.container
+ constraint 'a = 'a #window_skel
+ constraint 'b = [>`widget|`container|`window]
+ val obj : 'b obj
+ method activate_default : unit -> unit
+ method activate_focus : unit -> unit
+ method add_accel_group : accel_group -> unit
+ method event : event_ops
+ method as_window : Gtk.window obj
+ method set_allow_grow : bool -> unit
+ method set_allow_shrink : bool -> unit
+ method set_auto_shrink : bool -> unit
+ method set_default_size : width:int -> height:int -> unit
+ method set_modal : bool -> unit
+ method set_position : Tags.window_position -> unit
+ method set_resize_mode : Tags.resize_mode -> unit
+ method set_title : string -> unit
+ method set_transient_for : 'a -> unit
+ method set_wm_class : string -> unit
+ method set_wm_name : string -> unit
+ method show : unit -> unit
+ end
+
+class window : [>`window] obj ->
+ object
+ inherit [window] window_skel
+ val obj : Gtk.window obj
+ method connect : GContainer.container_signals
+ end
+val window :
+ ?kind:Tags.window_type ->
+ ?title:string ->
+ ?wm_name:string ->
+ ?wm_class:string ->
+ ?position:Tags.window_position ->
+ ?allow_shrink:bool ->
+ ?allow_grow:bool ->
+ ?auto_shrink:bool ->
+ ?modal:bool ->
+ ?x:int ->
+ ?y:int ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> window
+
+class dialog : [>`dialog] obj ->
+ object
+ inherit [window] window_skel
+ val obj : Gtk.dialog obj
+ method action_area : GPack.box
+ method connect : GContainer.container_signals
+ method event : event_ops
+ method vbox : GPack.box
+ end
+val dialog :
+ ?title:string ->
+ ?wm_name:string ->
+ ?wm_class:string ->
+ ?position:Tags.window_position ->
+ ?allow_shrink:bool ->
+ ?allow_grow:bool ->
+ ?auto_shrink:bool ->
+ ?modal:bool ->
+ ?x:int ->
+ ?y:int ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> dialog
+
+class color_selection_dialog : Gtk.color_selection_dialog obj ->
+ object
+ inherit [window] window_skel
+ val obj : Gtk.color_selection_dialog obj
+ method cancel_button : GButton.button
+ method colorsel : GMisc.color_selection
+ method connect : GContainer.container_signals
+ method help_button : GButton.button
+ method ok_button : GButton.button
+ end
+val color_selection_dialog :
+ ?title:string ->
+ ?wm_name:string ->
+ ?wm_class:string ->
+ ?position:Tags.window_position ->
+ ?allow_shrink:bool ->
+ ?allow_grow:bool ->
+ ?auto_shrink:bool ->
+ ?modal:bool ->
+ ?x:int ->
+ ?y:int ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> color_selection_dialog
+
+class file_selection : Gtk.file_selection obj ->
+ object
+ inherit [window] window_skel
+ val obj : Gtk.file_selection obj
+ method cancel_button : GButton.button
+ method connect : GContainer.container_signals
+ method get_filename : string
+ method help_button : GButton.button
+ method ok_button : GButton.button
+ method set_filename : string -> unit
+ method set_fileop_buttons : bool -> unit
+ end
+val file_selection :
+ ?title:string ->
+ ?filename:string ->
+ ?fileop_buttons:bool ->
+ ?wm_name:string ->
+ ?wm_class:string ->
+ ?position:Tags.window_position ->
+ ?allow_shrink:bool ->
+ ?allow_grow:bool ->
+ ?auto_shrink:bool ->
+ ?modal:bool ->
+ ?x:int ->
+ ?y:int ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> file_selection
+
+class font_selection_dialog : Gtk.font_selection_dialog obj ->
+ object
+ inherit [window] window_skel
+ val obj : Gtk.font_selection_dialog obj
+ method apply_button : GButton.button
+ method cancel_button : GButton.button
+ method connect : GContainer.container_signals
+ method selection : GMisc.font_selection
+ method ok_button : GButton.button
+ end
+val font_selection_dialog :
+ ?title:string ->
+ ?wm_name:string ->
+ ?wm_class:string ->
+ ?position:Tags.window_position ->
+ ?allow_shrink:bool ->
+ ?allow_grow:bool ->
+ ?auto_shrink:bool ->
+ ?modal:bool ->
+ ?x:int ->
+ ?y:int ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> font_selection_dialog
+
+class plug : Gtk.plug obj -> window
+
+val plug :
+ window:Gdk.xid ->
+ ?border_width:int ->
+ ?width:int -> ?height:int -> ?show:bool -> unit -> plug
--- /dev/null
+(* $Id$ *)
+
+(* Option handling *)
+
+let may ~f x =
+ match x with None -> ()
+ | Some x -> let _ = f x in ()
+
+let may_map ~f x =
+ match x with None -> None
+ | Some x -> Some (f x)
+
+let default x ~opt =
+ match opt with None -> x | Some y -> y
+
+let may_default f x ~opt =
+ match opt with None -> f x | Some y -> y
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+
+type colormap
+type visual
+type region
+type gc
+type 'a drawable
+type window = [`window] drawable
+type pixmap = [`pixmap] drawable
+type bitmap = [`bitmap] drawable
+type font
+type image
+type atom = int
+type keysym = int
+type 'a event
+type drag_context
+type cursor
+type xid = int32
+
+exception Error of string
+let _ = Callback.register_exception "gdkerror" (Error"")
+
+module Tags = struct
+ type event_type =
+ [ `NOTHING|`DELETE|`DESTROY|`EXPOSE|`MOTION_NOTIFY|`BUTTON_PRESS
+ |`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS
+ |`BUTTON_RELEASE|`KEY_PRESS
+ |`KEY_RELEASE|`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`CONFIGURE|`MAP|`UNMAP|`PROPERTY_NOTIFY|`SELECTION_CLEAR
+ |`SELECTION_REQUEST|`SELECTION_NOTIFY|`PROXIMITY_IN
+ |`PROXIMITY_OUT|`DRAG_ENTER|`DRAG_LEAVE|`DRAG_MOTION|`DRAG_STATUS
+ |`DROP_START|`DROP_FINISHED|`CLIENT_EVENT|`VISIBILITY_NOTIFY
+ |`NO_EXPOSE ]
+
+ type event_mask =
+ [ `EXPOSURE
+ |`POINTER_MOTION|`POINTER_MOTION_HINT
+ |`BUTTON_MOTION|`BUTTON1_MOTION|`BUTTON2_MOTION|`BUTTON3_MOTION
+ |`BUTTON_PRESS|`BUTTON_RELEASE
+ |`KEY_PRESS|`KEY_RELEASE
+ |`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`STRUCTURE|`PROPERTY_CHANGE|`VISIBILITY_NOTIFY
+ |`PROXIMITY_IN|`PROXIMITY_OUT|`SUBSTRUCTURE
+ |`ALL_EVENTS ]
+
+ type extension_events =
+ [ `NONE|`ALL|`CURSOR ]
+
+ type visibility_state =
+ [ `UNOBSCURED|`PARTIAL|`FULLY_OBSCURED ]
+
+ type input_source =
+ [ `MOUSE|`PEN|`ERASER|`CURSOR ]
+
+ type notify_type =
+ [ `ANCESTOR|`VIRTUAL|`INFERIOR|`NONLINEAR|`NONLINEAR_VIRTUAL|`UNKNOWN ]
+
+ type crossing_mode =
+ [ `NORMAL|`GRAB|`UNGRAB ]
+
+ type modifier =
+ [ `SHIFT|`LOCK|`CONTROL|`MOD1|`MOD2|`MOD3|`MOD4|`MOD5|`BUTTON1
+ |`BUTTON2|`BUTTON3|`BUTTON4|`BUTTON5 ]
+
+ type drag_action =
+ [ `DEFAULT|`COPY|`MOVE|`LINK|`PRIVATE|`ASK ]
+
+end
+open Tags
+
+module Convert = struct
+ external test_modifier : modifier -> int -> bool
+ = "ml_test_GdkModifier_val"
+ let modifier i =
+ List.filter [`SHIFT;`LOCK;`CONTROL;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5;
+ `BUTTON1;`BUTTON2;`BUTTON3;`BUTTON4;`BUTTON5]
+ ~f:(fun m -> test_modifier m i)
+end
+
+module Screen = struct
+ external width : unit -> int = "ml_gdk_screen_width"
+ external height : unit -> int = "ml_gdk_screen_height"
+end
+
+module Visual = struct
+ type visual_type =
+ [ `STATIC_GRAY|`GRAYSCALE|`STATIC_COLOR
+ |`PSEUDO_COLOR|`TRUE_COLOR|`DIRECT_COLOR ]
+
+ external get_best : ?depth:int -> ?kind:visual_type -> unit -> visual
+ = "ml_gdk_visual_get_best"
+ external get_type : visual -> visual_type = "ml_GdkVisual_type"
+ external depth : visual -> int = "ml_GdkVisual_depth"
+ external red_mask : visual -> int = "ml_GdkVisual_red_mask"
+ external red_shift : visual -> int = "ml_GdkVisual_red_shift"
+ external red_prec : visual -> int = "ml_GdkVisual_red_prec"
+ external green_mask : visual -> int = "ml_GdkVisual_green_mask"
+ external green_shift : visual -> int = "ml_GdkVisual_green_shift"
+ external green_prec : visual -> int = "ml_GdkVisual_green_prec"
+ external blue_mask : visual -> int = "ml_GdkVisual_blue_mask"
+ external blue_shift : visual -> int = "ml_GdkVisual_blue_shift"
+ external blue_prec : visual -> int = "ml_GdkVisual_blue_prec"
+end
+
+module Image = struct
+ type image_type =
+ [ `NORMAL|`SHARED|`FASTEST ]
+
+ external create_bitmap : visual: visual -> data: string ->
+ width: int -> height: int -> image
+ = "ml_gdk_image_new_bitmap"
+ external create : kind: image_type -> visual: visual ->
+ width: int -> height: int -> image
+ = "ml_gdk_image_new"
+ external get :
+ 'a drawable -> x: int -> y: int -> width: int -> height: int -> image
+ = "ml_gdk_image_get"
+ external put_pixel : image -> x: int -> y: int -> pixel: int -> unit
+ = "ml_gdk_image_put_pixel"
+ external get_pixel : image -> x: int -> y: int -> int
+ = "ml_gdk_image_get_pixel"
+ external destroy : image -> unit
+ = "ml_gdk_image_destroy"
+end
+
+module Color = struct
+ type t
+
+ external color_white : colormap -> t = "ml_gdk_color_white"
+ external color_black : colormap -> t = "ml_gdk_color_black"
+ external color_parse : string -> t = "ml_gdk_color_parse"
+ external color_alloc : colormap -> t -> bool = "ml_gdk_color_alloc"
+ external color_create : red:int -> green:int -> blue:int -> t
+ = "ml_GdkColor"
+
+ external get_system_colormap : unit -> colormap
+ = "ml_gdk_colormap_get_system"
+ external colormap_new : visual -> privat:bool -> colormap
+ = "ml_gdk_colormap_new"
+ let get_colormap ?(privat=false) vis = colormap_new vis ~privat
+
+ type spec = [ `BLACK | `NAME of string | `RGB of int * int * int | `WHITE]
+ let color_alloc ~colormap color =
+ if not (color_alloc colormap color) then raise (Error"Color.alloc");
+ color
+ let alloc ~colormap color =
+ match color with
+ `WHITE -> color_white colormap
+ | `BLACK -> color_black colormap
+ | `NAME s -> color_alloc ~colormap (color_parse s)
+ | `RGB (red,green,blue) ->
+ color_alloc ~colormap (color_create ~red ~green ~blue)
+
+ external red : t -> int = "ml_GdkColor_red"
+ external blue : t -> int = "ml_GdkColor_blue"
+ external green : t -> int = "ml_GdkColor_green"
+ external pixel : t -> int = "ml_GdkColor_pixel"
+end
+
+module Rectangle = struct
+ type t
+ external create : x:int -> y:int -> width:int -> height:int -> t
+ = "ml_GdkRectangle"
+ external x : t -> int = "ml_GdkRectangle_x"
+ external y : t -> int = "ml_GdkRectangle_y"
+ external width : t -> int = "ml_GdkRectangle_width"
+ external height : t -> int = "ml_GdkRectangle_height"
+end
+
+module Window = struct
+ type background_pixmap = [ `NONE | `PARENT_RELATIVE | `PIXMAP of pixmap]
+ external visual_depth : visual -> int = "ml_gdk_visual_get_depth"
+ external get_visual : window -> visual = "ml_gdk_window_get_visual"
+ external get_parent : window -> window = "ml_gdk_window_get_parent"
+ external get_size : window -> int * int = "ml_gdk_window_get_size"
+ external get_position : window -> int * int =
+ "ml_gdk_window_get_position"
+ external root_parent : unit -> window = "ml_GDK_ROOT_PARENT"
+ external set_back_pixmap : window -> pixmap -> int -> unit =
+ "ml_gdk_window_set_back_pixmap"
+ external clear : window -> unit = "ml_gdk_window_clear"
+ external get_xwindow : window -> xid = "ml_GDK_WINDOW_XWINDOW"
+
+ let set_back_pixmap w pix =
+ let null_pixmap = (Obj.magic Gpointer.boxed_null : pixmap) in
+ match pix with
+ `NONE -> set_back_pixmap w null_pixmap 0
+ | `PARENT_RELATIVE -> set_back_pixmap w null_pixmap 1
+ | `PIXMAP(pixmap) -> set_back_pixmap w pixmap 0
+ (* anything OK, Maybe... *)
+end
+
+module PointArray = struct
+ type t = { len: int}
+ external create : len:int -> t = "ml_point_array_new"
+ external set : t -> pos:int -> x:int -> y:int -> unit = "ml_point_array_set"
+ let set arr ~pos =
+ if pos < 0 || pos >= arr.len then invalid_arg "PointArray.set";
+ set arr ~pos
+end
+
+module Region = struct
+ type gdkFillRule = [ `EVEN_ODD_RULE|`WINDING_RULE ]
+ type gdkOverlapType = [ `IN|`OUT|`PART ]
+ external create : unit -> region = "ml_gdk_region_new"
+ external destroy : region -> unit = "ml_gdk_region_destroy"
+ external polygon : PointArray.t -> gdkFillRule -> region
+ = "ml_gdk_region_polygon"
+ let polygon l =
+ let len = List.length l in
+ let arr = PointArray.create ~len in
+ List.fold_left l ~init:0
+ ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
+ polygon arr
+ external intersect : region -> region -> region
+ = "ml_gdk_regions_intersect"
+ external union : region -> region -> region
+ = "ml_gdk_regions_union"
+ external subtract : region -> region -> region
+ = "ml_gdk_regions_subtract"
+ external xor : region -> region -> region
+ = "ml_gdk_regions_xor"
+ external union_with_rect : region -> Rectangle.t -> region
+ = "ml_gdk_region_union_with_rect"
+ external offset : region -> x:int -> y:int -> unit = "ml_gdk_region_offset"
+ external shrink : region -> x:int -> y:int -> unit = "ml_gdk_region_shrink"
+ external empty : region -> bool = "ml_gdk_region_empty"
+ external equal : region -> region -> bool = "ml_gdk_region_equal"
+ external point_in : region -> x:int -> y:int -> bool
+ = "ml_gdk_region_point_in"
+ external rect_in : region -> Rectangle.t -> gdkOverlapType
+ = "ml_gdk_region_rect_in"
+ external get_clipbox : region -> Rectangle.t -> unit
+ = "ml_gdk_region_get_clipbox"
+end
+
+
+module GC = struct
+ type gdkFunction = [ `COPY|`INVERT|`XOR ]
+ type gdkFill = [ `SOLID|`TILED|`STIPPLED|`OPAQUE_STIPPLED ]
+ type gdkSubwindowMode = [ `CLIP_BY_CHILDREN|`INCLUDE_INFERIORS ]
+ type gdkLineStyle = [ `SOLID|`ON_OFF_DASH|`DOUBLE_DASH ]
+ type gdkCapStyle = [ `NOT_LAST|`BUTT|`ROUND|`PROJECTING ]
+ type gdkJoinStyle = [ `MITER|`ROUND|`BEVEL ]
+ external create : 'a drawable -> gc = "ml_gdk_gc_new"
+ external set_foreground : gc -> Color.t -> unit = "ml_gdk_gc_set_foreground"
+ external set_background : gc -> Color.t -> unit = "ml_gdk_gc_set_background"
+ external set_font : gc -> font -> unit = "ml_gdk_gc_set_font"
+ external set_function : gc -> gdkFunction -> unit = "ml_gdk_gc_set_function"
+ external set_fill : gc -> gdkFill -> unit = "ml_gdk_gc_set_fill"
+ external set_tile : gc -> pixmap -> unit = "ml_gdk_gc_set_tile"
+ external set_stipple : gc -> pixmap -> unit = "ml_gdk_gc_set_stipple"
+ external set_ts_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_ts_origin"
+ external set_clip_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_clip_origin"
+ external set_clip_mask : gc -> bitmap -> unit = "ml_gdk_gc_set_clip_mask"
+ external set_clip_rectangle : gc -> Rectangle.t -> unit
+ = "ml_gdk_gc_set_clip_rectangle"
+ external set_clip_region : gc -> region -> unit = "ml_gdk_gc_set_clip_region"
+ external set_subwindow : gc -> gdkSubwindowMode -> unit
+ = "ml_gdk_gc_set_subwindow"
+ external set_exposures : gc -> bool -> unit = "ml_gdk_gc_set_exposures"
+ external set_line_attributes :
+ gc -> width:int -> style:gdkLineStyle -> cap:gdkCapStyle ->
+ join:gdkJoinStyle -> unit
+ = "ml_gdk_gc_set_line_attributes"
+ external copy : dst:gc -> gc -> unit = "ml_gdk_gc_copy"
+ type values = {
+ foreground : Color.t;
+ background : Color.t;
+ font : font option;
+ fonction : gdkFunction;
+ fill : gdkFill;
+ tile : pixmap option;
+ stipple : pixmap option;
+ clip_mask : bitmap option;
+ subwindow_mode : gdkSubwindowMode;
+ ts_x_origin : int;
+ ts_y_origin : int;
+ clip_x_origin : int;
+ clip_y_origin : int;
+ graphics_exposures : bool;
+ line_width : int;
+ line_style : gdkLineStyle;
+ cap_style : gdkCapStyle;
+ join_style : gdkJoinStyle;
+ }
+ external get_values : gc -> values = "ml_gdk_gc_get_values"
+end
+
+module Pixmap = struct
+ external create : window -> width:int -> height:int -> depth:int -> pixmap
+ = "ml_gdk_pixmap_new"
+ external create_from_data :
+ window -> string -> width:int -> height:int -> depth:int ->
+ fg:Color.t -> bg:Color.t -> pixmap
+ = "ml_gdk_pixmap_create_from_data_bc" "ml_gk_pixmap_create_from_data"
+ external create_from_xpm :
+ window -> ?colormap:colormap -> ?transparent:Color.t ->
+ file:string -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm"
+ external create_from_xpm_d :
+ window -> ?colormap:colormap -> ?transparent:Color.t ->
+ data:string array -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm_d"
+end
+
+module Bitmap = struct
+ let create : window -> width:int -> height:int -> bitmap =
+ Obj.magic (Pixmap.create ~depth:1)
+ external create_from_data :
+ window -> string -> width:int -> height:int -> bitmap
+ = "ml_gdk_bitmap_create_from_data"
+end
+
+module Font = struct
+ external load : string -> font = "ml_gdk_font_load"
+ external load_fontset : string -> font = "ml_gdk_fontset_load"
+ external string_width : font -> string -> int = "ml_gdk_string_width"
+ external char_width : font -> char -> int = "ml_gdk_char_width"
+ external string_height : font -> string -> int = "ml_gdk_string_height"
+ external char_height : font -> char -> int = "ml_gdk_char_height"
+ external string_measure : font -> string -> int = "ml_gdk_string_measure"
+ external char_measure : font -> char -> int = "ml_gdk_char_measure"
+ external get_type : font -> [`FONT | `FONTSET] = "ml_GdkFont_type"
+ external ascent : font -> int = "ml_GdkFont_ascent"
+ external descent : font -> int = "ml_GdkFont_descent"
+end
+
+module Draw = struct
+ external point : 'a drawable -> gc -> x:int -> y:int -> unit
+ = "ml_gdk_draw_point"
+ external line : 'a drawable -> gc -> x:int -> y:int -> x:int -> y:int -> unit
+ = "ml_gdk_draw_line_bc" "ml_gdk_draw_line"
+ external rectangle :
+ 'a drawable -> gc ->
+ filled:bool -> x:int -> y:int -> width:int -> height:int -> unit
+ = "ml_gdk_draw_rectangle_bc" "ml_gdk_draw_rectangle"
+ let rectangle w gc ~x ~y ~width ~height ?(filled=false) () =
+ rectangle w gc ~x ~y ~width ~height ~filled
+ external arc :
+ 'a drawable -> gc -> filled:bool -> x:int -> y:int ->
+ width:int -> height:int -> start:int -> angle:int -> unit
+ = "ml_gdk_draw_arc_bc" "ml_gdk_draw_arc"
+ let arc w gc ~x ~y ~width ~height ?(filled=false) ?(start=0.)
+ ?(angle=360.) () =
+ arc w gc ~x ~y ~width ~height ~filled
+ ~start:(truncate(start *. 64.))
+ ~angle:(truncate(angle *. 64.))
+ external polygon : 'a drawable -> gc -> filled:bool -> PointArray.t -> unit
+ = "ml_gdk_draw_polygon"
+ let polygon w gc ?(filled=false) l =
+ let len = List.length l in
+ let arr = PointArray.create ~len in
+ List.fold_left l ~init:0
+ ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
+ polygon w gc ~filled arr
+ external string : 'a drawable -> font: font -> gc -> x: int -> y: int ->
+ string: string -> unit
+ = "ml_gdk_draw_string_bc" "ml_gdk_draw_string"
+ external image : 'a drawable -> gc -> image: image ->
+ xsrc: int -> ysrc: int -> xdest: int -> ydest: int ->
+ width: int -> height: int -> unit
+ = "ml_gdk_draw_image_bc" "ml_gdk_draw_image"
+end
+
+module Rgb = struct
+ external init : unit -> unit = "ml_gdk_rgb_init"
+ external get_visual : unit -> visual = "ml_gdk_rgb_get_visual"
+ external get_cmap : unit -> colormap = "ml_gdk_rgb_get_cmap"
+end
+
+module DnD = struct
+ external drag_status : drag_context -> drag_action list -> time:int -> unit
+ = "ml_gdk_drag_status"
+ external drag_context_suggested_action : drag_context -> drag_action
+ = "ml_GdkDragContext_suggested_action"
+ external drag_context_targets : drag_context -> atom list
+ = "ml_GdkDragContext_targets"
+end
+
+module Truecolor = struct
+ (* Truecolor quick color query *)
+
+ type visual_shift_prec = {
+ red_shift : int;
+ red_prec : int;
+ green_shift : int;
+ green_prec : int;
+ blue_shift : int;
+ blue_prec : int
+ }
+
+ let shift_prec visual = {
+ red_shift = Visual.red_shift visual;
+ red_prec = Visual.red_prec visual;
+ green_shift = Visual.green_shift visual;
+ green_prec = Visual.green_prec visual;
+ blue_shift = Visual.blue_shift visual;
+ blue_prec = Visual.blue_prec visual;
+ }
+
+ let color_creator visual =
+ match Visual.get_type visual with
+ `TRUE_COLOR | `DIRECT_COLOR ->
+ let shift_prec = shift_prec visual in
+ Format.eprintf "red : %d %d, "
+ shift_prec.red_shift shift_prec.red_prec;
+ Format.eprintf "green : %d %d, "
+ shift_prec.green_shift shift_prec.green_prec;
+ Format.eprintf "blue : %d %d"
+ shift_prec.blue_shift shift_prec.blue_prec;
+ Format.pp_print_newline Format.err_formatter ();
+ let red_lsr = 16 - shift_prec.red_prec
+ and green_lsr = 16 - shift_prec.green_prec
+ and blue_lsr = 16 - shift_prec.blue_prec in
+ fun ~red: red ~green: green ~blue: blue ->
+ (((red lsr red_lsr) lsl shift_prec.red_shift) lor
+ ((green lsr green_lsr) lsl shift_prec.green_shift) lor
+ ((blue lsr blue_lsr) lsl shift_prec.blue_shift))
+ | _ -> raise (Invalid_argument "Gdk.Truecolor.color_creator")
+
+ let color_parser visual =
+ match Visual.get_type visual with
+ `TRUE_COLOR | `DIRECT_COLOR ->
+ let shift_prec = shift_prec visual in
+ let red_lsr = 16 - shift_prec.red_prec
+ and green_lsr = 16 - shift_prec.green_prec
+ and blue_lsr = 16 - shift_prec.blue_prec in
+ let mask = 1 lsl 16 - 1 in
+ fun pixel ->
+ ((pixel lsr shift_prec.red_shift) lsl red_lsr) land mask,
+ ((pixel lsr shift_prec.green_shift) lsl green_lsr) land mask,
+ ((pixel lsr shift_prec.blue_shift) lsl blue_lsr) land mask
+ | _ -> raise (Invalid_argument "Gdk.Truecolor.color_parser")
+end
+
+module X = struct
+ (* X related functions *)
+ external flush : unit -> unit
+ = "ml_gdk_flush"
+ external beep : unit -> unit
+ = "ml_gdk_beep"
+end
+
+module Cursor = struct
+ type cursor_type = [
+ | `X_CURSOR
+ | `ARROW
+ | `BASED_ARROW_DOWN
+ | `BASED_ARROW_UP
+ | `BOAT
+ | `BOGOSITY
+ | `BOTTOM_LEFT_CORNER
+ | `BOTTOM_RIGHT_CORNER
+ | `BOTTOM_SIDE
+ | `BOTTOM_TEE
+ | `BOX_SPIRAL
+ | `CENTER_PTR
+ | `CIRCLE
+ | `CLOCK
+ | `COFFEE_MUG
+ | `CROSS
+ | `CROSS_REVERSE
+ | `CROSSHAIR
+ | `DIAMOND_CROSS
+ | `DOT
+ | `DOTBOX
+ | `DOUBLE_ARROW
+ | `DRAFT_LARGE
+ | `DRAFT_SMALL
+ | `DRAPED_BOX
+ | `EXCHANGE
+ | `FLEUR
+ | `GOBBLER
+ | `GUMBY
+ | `HAND1
+ | `HAND2
+ | `HEART
+ | `ICON
+ | `IRON_CROSS
+ | `LEFT_PTR
+ | `LEFT_SIDE
+ | `LEFT_TEE
+ | `LEFTBUTTON
+ | `LL_ANGLE
+ | `LR_ANGLE
+ | `MAN
+ | `MIDDLEBUTTON
+ | `MOUSE
+ | `PENCIL
+ | `PIRATE
+ | `PLUS
+ | `QUESTION_ARROW
+ | `RIGHT_PTR
+ | `RIGHT_SIDE
+ | `RIGHT_TEE
+ | `RIGHTBUTTON
+ | `RTL_LOGO
+ | `SAILBOAT
+ | `SB_DOWN_ARROW
+ | `SB_H_DOUBLE_ARROW
+ | `SB_LEFT_ARROW
+ | `SB_RIGHT_ARROW
+ | `SB_UP_ARROW
+ | `SB_V_DOUBLE_ARROW
+ | `SHUTTLE
+ | `SIZING
+ | `SPIDER
+ | `SPRAYCAN
+ | `STAR
+ | `TARGET
+ | `TCROSS
+ | `TOP_LEFT_ARROW
+ | `TOP_LEFT_CORNER
+ | `TOP_RIGHT_CORNER
+ | `TOP_SIDE
+ | `TOP_TEE
+ | `TREK
+ | `UL_ANGLE
+ | `UMBRELLA
+ | `UR_ANGLE
+ | `WATCH
+ | `XTERM
+ ]
+ external create : cursor_type -> cursor = "ml_gdk_cursor_new"
+ external create_from_pixmap :
+ pixmap -> mask:bitmap ->
+ fg:Color.t -> bg:Color.t -> x:int -> y:int -> cursor
+ = "ml_gdk_cursor_new_from_pixmap_bc" "ml_gdk_cursor_new_from_pixmap"
+ external destroy : cursor -> unit = "ml_gdk_cursor_destroy"
+end
--- /dev/null
+(* $Id$ *)
+
+type colormap
+type visual
+type region
+type gc
+type 'a drawable
+type window = [`window] drawable
+type pixmap = [`pixmap] drawable
+type bitmap = [`bitmap] drawable
+type font
+type image
+type atom = int
+type keysym = int
+type 'a event
+type drag_context
+type cursor
+type xid = int32
+
+exception Error of string
+
+module Tags : sig
+ type event_type =
+ [ `NOTHING|`DELETE|`DESTROY|`EXPOSE|`MOTION_NOTIFY|`BUTTON_PRESS
+ |`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS
+ |`BUTTON_RELEASE|`KEY_PRESS
+ |`KEY_RELEASE|`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`CONFIGURE|`MAP|`UNMAP|`PROPERTY_NOTIFY|`SELECTION_CLEAR
+ |`SELECTION_REQUEST|`SELECTION_NOTIFY|`PROXIMITY_IN
+ |`PROXIMITY_OUT|`DRAG_ENTER|`DRAG_LEAVE|`DRAG_MOTION|`DRAG_STATUS
+ |`DROP_START|`DROP_FINISHED|`CLIENT_EVENT|`VISIBILITY_NOTIFY
+ |`NO_EXPOSE ]
+ type event_mask =
+ [ `EXPOSURE
+ |`POINTER_MOTION|`POINTER_MOTION_HINT
+ |`BUTTON_MOTION|`BUTTON1_MOTION|`BUTTON2_MOTION|`BUTTON3_MOTION
+ |`BUTTON_PRESS|`BUTTON_RELEASE
+ |`KEY_PRESS|`KEY_RELEASE
+ |`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`STRUCTURE|`PROPERTY_CHANGE|`VISIBILITY_NOTIFY
+ |`PROXIMITY_IN|`PROXIMITY_OUT|`SUBSTRUCTURE
+ |`ALL_EVENTS ]
+ type extension_events = [ `NONE|`ALL|`CURSOR ]
+ type visibility_state = [ `UNOBSCURED|`PARTIAL|`FULLY_OBSCURED ]
+ type input_source = [ `MOUSE|`PEN|`ERASER|`CURSOR ]
+ type notify_type =
+ [ `ANCESTOR|`VIRTUAL|`INFERIOR|`NONLINEAR|`NONLINEAR_VIRTUAL|`UNKNOWN ]
+ type crossing_mode = [ `NORMAL|`GRAB|`UNGRAB ]
+ type modifier =
+ [ `SHIFT|`LOCK|`CONTROL|`MOD1|`MOD2|`MOD3|`MOD4|`MOD5|`BUTTON1
+ |`BUTTON2|`BUTTON3|`BUTTON4|`BUTTON5 ]
+ type drag_action = [ `DEFAULT|`COPY|`MOVE|`LINK|`PRIVATE|`ASK ]
+end
+
+module Convert :
+ sig
+ val modifier : int -> Tags.modifier list
+ end
+
+module Screen :
+ sig
+ external width : unit -> int = "ml_gdk_screen_width"
+ external height : unit -> int = "ml_gdk_screen_height"
+ end
+
+module Visual :
+ sig
+ type visual_type =
+ [ `STATIC_GRAY|`GRAYSCALE|`STATIC_COLOR
+ |`PSEUDO_COLOR|`TRUE_COLOR|`DIRECT_COLOR ]
+ external get_best : ?depth:int -> ?kind:visual_type -> unit -> visual
+ = "ml_gdk_visual_get_best"
+ external get_type : visual -> visual_type = "ml_GdkVisual_type"
+ external depth : visual -> int = "ml_GdkVisual_depth"
+ external red_mask : visual -> int = "ml_GdkVisual_red_mask"
+ external red_shift : visual -> int = "ml_GdkVisual_red_shift"
+ external red_prec : visual -> int = "ml_GdkVisual_red_prec"
+ external green_mask : visual -> int = "ml_GdkVisual_green_mask"
+ external green_shift : visual -> int = "ml_GdkVisual_green_shift"
+ external green_prec : visual -> int = "ml_GdkVisual_green_prec"
+ external blue_mask : visual -> int = "ml_GdkVisual_blue_mask"
+ external blue_shift : visual -> int = "ml_GdkVisual_blue_shift"
+ external blue_prec : visual -> int = "ml_GdkVisual_blue_prec"
+ end
+
+module Image :
+ sig
+ type image_type = [ `FASTEST|`NORMAL|`SHARED ]
+ external create_bitmap :
+ visual:visual -> data:string -> width:int -> height:int -> image
+ = "ml_gdk_image_new_bitmap"
+ external create :
+ kind:image_type ->
+ visual:visual -> width:int -> height:int -> image = "ml_gdk_image_new"
+ external get :
+ 'a drawable -> x:int -> y:int -> width:int -> height:int -> image
+ = "ml_gdk_image_get"
+ external put_pixel : image -> x:int -> y:int -> pixel:int -> unit
+ = "ml_gdk_image_put_pixel"
+ external get_pixel : image -> x:int -> y:int -> int
+ = "ml_gdk_image_get_pixel"
+ external destroy : image -> unit = "ml_gdk_image_destroy"
+ end
+
+module Color :
+ sig
+ external get_system_colormap : unit -> colormap
+ = "ml_gdk_colormap_get_system"
+ val get_colormap : ?privat:bool -> visual -> colormap
+
+ type t
+ type spec = [
+ | `BLACK
+ | `NAME of string
+ | `RGB of int * int * int
+ | `WHITE
+ ]
+ val alloc : colormap:colormap -> spec -> t
+ external red : t -> int = "ml_GdkColor_red"
+ external blue : t -> int = "ml_GdkColor_blue"
+ external green : t -> int = "ml_GdkColor_green"
+ external pixel : t -> int = "ml_GdkColor_pixel"
+ end
+
+module Rectangle :
+ sig
+ type t
+ external create : x:int -> y:int -> width:int -> height:int -> t
+ = "ml_GdkRectangle"
+ external x : t -> int = "ml_GdkRectangle_x"
+ external y : t -> int = "ml_GdkRectangle_y"
+ external width : t -> int = "ml_GdkRectangle_width"
+ external height : t -> int = "ml_GdkRectangle_height"
+ end
+
+module Window :
+ sig
+ type background_pixmap = [ `NONE|`PARENT_RELATIVE|`PIXMAP of pixmap ]
+ external visual_depth : visual -> int = "ml_gdk_visual_get_depth"
+ external get_visual : window -> visual = "ml_gdk_window_get_visual"
+ external get_parent : window -> window = "ml_gdk_window_get_parent"
+ external get_size : window -> int * int = "ml_gdk_window_get_size"
+ external get_position : window -> int * int
+ = "ml_gdk_window_get_position"
+ external root_parent : unit -> window = "ml_GDK_ROOT_PARENT"
+ external clear : window -> unit = "ml_gdk_window_clear"
+ external get_xwindow : window -> xid = "ml_GDK_WINDOW_XWINDOW"
+ val set_back_pixmap : window -> background_pixmap -> unit
+ end
+
+module PointArray :
+ sig
+ type t = { len: int }
+ external create : len:int -> t = "ml_point_array_new"
+ val set : t -> pos:int -> x:int -> y:int -> unit
+ end
+
+module Region :
+ sig
+ type gdkFillRule = [ `EVEN_ODD_RULE|`WINDING_RULE ]
+ type gdkOverlapType = [ `IN|`OUT|`PART ]
+ external create : unit -> region = "ml_gdk_region_new"
+ external destroy : region -> unit = "ml_gdk_region_destroy"
+ val polygon : (int * int) list -> gdkFillRule -> region
+ external intersect : region -> region -> region
+ = "ml_gdk_regions_intersect"
+ external union : region -> region -> region
+ = "ml_gdk_regions_union"
+ external subtract : region -> region -> region
+ = "ml_gdk_regions_subtract"
+ external xor : region -> region -> region
+ = "ml_gdk_regions_xor"
+ external union_with_rect : region -> Rectangle.t -> region
+ = "ml_gdk_region_union_with_rect"
+ external offset : region -> x:int -> y:int -> unit = "ml_gdk_region_offset"
+ external shrink : region -> x:int -> y:int -> unit = "ml_gdk_region_shrink"
+ external empty : region -> bool = "ml_gdk_region_empty"
+ external equal : region -> region -> bool = "ml_gdk_region_equal"
+ external point_in : region -> x:int -> y:int -> bool
+ = "ml_gdk_region_point_in"
+ external rect_in : region -> Rectangle.t -> gdkOverlapType
+ = "ml_gdk_region_rect_in"
+ external get_clipbox : region -> Rectangle.t -> unit
+ = "ml_gdk_region_get_clipbox"
+ end
+
+module GC :
+ sig
+ type gdkFunction = [ `COPY|`INVERT|`XOR ]
+ type gdkFill = [ `SOLID|`TILED|`STIPPLED|`OPAQUE_STIPPLED ]
+ type gdkSubwindowMode = [ `CLIP_BY_CHILDREN|`INCLUDE_INFERIORS ]
+ type gdkLineStyle = [ `SOLID|`ON_OFF_DASH|`DOUBLE_DASH ]
+ type gdkCapStyle = [ `NOT_LAST|`BUTT|`ROUND|`PROJECTING ]
+ type gdkJoinStyle = [ `MITER|`ROUND|`BEVEL ]
+ external create : 'a drawable -> gc = "ml_gdk_gc_new"
+ external set_foreground : gc -> Color.t -> unit
+ = "ml_gdk_gc_set_foreground"
+ external set_background : gc -> Color.t -> unit
+ = "ml_gdk_gc_set_background"
+ external set_font : gc -> font -> unit = "ml_gdk_gc_set_font"
+ external set_function : gc -> gdkFunction -> unit
+ = "ml_gdk_gc_set_function"
+ external set_fill : gc -> gdkFill -> unit = "ml_gdk_gc_set_fill"
+ external set_tile : gc -> pixmap -> unit = "ml_gdk_gc_set_tile"
+ external set_stipple : gc -> pixmap -> unit = "ml_gdk_gc_set_stipple"
+ external set_ts_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_ts_origin"
+ external set_clip_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_clip_origin"
+ external set_clip_mask : gc -> bitmap -> unit = "ml_gdk_gc_set_clip_mask"
+ external set_clip_rectangle : gc -> Rectangle.t -> unit
+ = "ml_gdk_gc_set_clip_rectangle"
+ external set_clip_region : gc -> region -> unit
+ = "ml_gdk_gc_set_clip_region"
+ external set_subwindow : gc -> gdkSubwindowMode -> unit
+ = "ml_gdk_gc_set_subwindow"
+ external set_exposures : gc -> bool -> unit = "ml_gdk_gc_set_exposures"
+ external set_line_attributes :
+ gc ->
+ width:int ->
+ style:gdkLineStyle -> cap:gdkCapStyle -> join:gdkJoinStyle -> unit
+ = "ml_gdk_gc_set_line_attributes"
+ external copy : dst:gc -> gc -> unit = "ml_gdk_gc_copy"
+ type values = {
+ foreground : Color.t;
+ background : Color.t;
+ font : font option;
+ fonction : gdkFunction;
+ fill : gdkFill;
+ tile : pixmap option;
+ stipple : pixmap option;
+ clip_mask : bitmap option;
+ subwindow_mode : gdkSubwindowMode;
+ ts_x_origin : int;
+ ts_y_origin : int;
+ clip_x_origin : int;
+ clip_y_origin : int;
+ graphics_exposures : bool;
+ line_width : int;
+ line_style : gdkLineStyle;
+ cap_style : gdkCapStyle;
+ join_style : gdkJoinStyle;
+ }
+ external get_values : gc -> values = "ml_gdk_gc_get_values"
+ end
+
+module Pixmap :
+ sig
+ external create :
+ window -> width:int -> height:int -> depth:int -> pixmap
+ = "ml_gdk_pixmap_new"
+ external create_from_data :
+ window ->
+ string ->
+ width:int ->
+ height:int -> depth:int -> fg:Color.t -> bg:Color.t -> pixmap
+ = "ml_gdk_pixmap_create_from_data_bc" "ml_gk_pixmap_create_from_data"
+ external create_from_xpm :
+ window ->
+ ?colormap:colormap ->
+ ?transparent:Color.t -> file:string -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm"
+ external create_from_xpm_d :
+ window ->
+ ?colormap:colormap ->
+ ?transparent:Color.t -> data:string array -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm_d"
+ end
+
+module Bitmap :
+ sig
+ val create : window -> width:int -> height:int -> bitmap
+ external create_from_data :
+ window -> string -> width:int -> height:int -> bitmap
+ = "ml_gdk_bitmap_create_from_data"
+ end
+
+module Font :
+ sig
+ external load : string -> font = "ml_gdk_font_load"
+ external load_fontset : string -> font = "ml_gdk_fontset_load"
+ external string_width : font -> string -> int = "ml_gdk_string_width"
+ external char_width : font -> char -> int = "ml_gdk_char_width"
+ external string_height : font -> string -> int = "ml_gdk_string_height"
+ external char_height : font -> char -> int = "ml_gdk_char_height"
+ external string_measure : font -> string -> int = "ml_gdk_string_measure"
+ external char_measure : font -> char -> int = "ml_gdk_char_measure"
+ external get_type : font -> [`FONT | `FONTSET] = "ml_GdkFont_type"
+ external ascent : font -> int = "ml_GdkFont_ascent"
+ external descent : font -> int = "ml_GdkFont_descent"
+ end
+
+module Draw :
+ sig
+ external point : 'a drawable -> gc -> x:int -> y:int -> unit
+ = "ml_gdk_draw_point"
+ external line :
+ 'a drawable -> gc -> x:int -> y:int -> x:int -> y:int -> unit
+ = "ml_gdk_draw_line_bc" "ml_gdk_draw_line"
+ val rectangle :
+ 'a drawable -> gc ->
+ x:int -> y:int -> width:int -> height:int -> ?filled:bool -> unit -> unit
+ val arc :
+ 'a drawable -> gc ->
+ x:int -> y:int -> width:int -> height:int ->
+ ?filled:bool -> ?start:float -> ?angle:float -> unit -> unit
+ val polygon :
+ 'a drawable -> gc -> ?filled:bool ->(int * int) list -> unit
+ external string :
+ 'a drawable ->
+ font:font -> gc -> x:int -> y:int -> string:string -> unit
+ = "ml_gdk_draw_string_bc" "ml_gdk_draw_string"
+ external image :
+ 'a drawable ->
+ gc ->
+ image:image ->
+ xsrc:int ->
+ ysrc:int -> xdest:int -> ydest:int -> width:int -> height:int -> unit
+ = "ml_gdk_draw_image_bc" "ml_gdk_draw_image"
+ end
+
+module Rgb :
+ sig
+ external init : unit -> unit = "ml_gdk_rgb_init"
+ external get_visual : unit -> visual = "ml_gdk_rgb_get_visual"
+ external get_cmap : unit -> colormap = "ml_gdk_rgb_get_cmap"
+ end
+
+module DnD :
+ sig
+ external drag_status :
+ drag_context -> Tags.drag_action list -> time:int -> unit
+ = "ml_gdk_drag_status"
+ external drag_context_suggested_action : drag_context -> Tags.drag_action
+ = "ml_GdkDragContext_suggested_action"
+ external drag_context_targets : drag_context -> atom list
+ = "ml_GdkDragContext_targets"
+ end
+
+module Truecolor :
+ sig
+ val color_creator : visual -> (red: int -> green: int -> blue: int -> int)
+ (* [color_creator visual] creates a function to calculate
+ the pixel color id for given red, green and blue component
+ value ([0..65535]) at the client side. [visual] must have
+ `TRUE_COLOR or `DIRECT_COLOR type. This function improves
+ the speed of the color query of true color visual greatly. *)
+ (* WARN: this approach is not theoretically correct for true color
+ visual, because we need gamma correction. *)
+
+ val color_parser : visual -> int -> int * int * int
+ end
+
+module X :
+ (* X related functions *)
+ sig
+ val flush : unit -> unit (* also in GtkMain *)
+ val beep : unit -> unit
+ end
+
+module Cursor : sig
+ type cursor_type = [
+ | `X_CURSOR
+ | `ARROW
+ | `BASED_ARROW_DOWN
+ | `BASED_ARROW_UP
+ | `BOAT
+ | `BOGOSITY
+ | `BOTTOM_LEFT_CORNER
+ | `BOTTOM_RIGHT_CORNER
+ | `BOTTOM_SIDE
+ | `BOTTOM_TEE
+ | `BOX_SPIRAL
+ | `CENTER_PTR
+ | `CIRCLE
+ | `CLOCK
+ | `COFFEE_MUG
+ | `CROSS
+ | `CROSS_REVERSE
+ | `CROSSHAIR
+ | `DIAMOND_CROSS
+ | `DOT
+ | `DOTBOX
+ | `DOUBLE_ARROW
+ | `DRAFT_LARGE
+ | `DRAFT_SMALL
+ | `DRAPED_BOX
+ | `EXCHANGE
+ | `FLEUR
+ | `GOBBLER
+ | `GUMBY
+ | `HAND1
+ | `HAND2
+ | `HEART
+ | `ICON
+ | `IRON_CROSS
+ | `LEFT_PTR
+ | `LEFT_SIDE
+ | `LEFT_TEE
+ | `LEFTBUTTON
+ | `LL_ANGLE
+ | `LR_ANGLE
+ | `MAN
+ | `MIDDLEBUTTON
+ | `MOUSE
+ | `PENCIL
+ | `PIRATE
+ | `PLUS
+ | `QUESTION_ARROW
+ | `RIGHT_PTR
+ | `RIGHT_SIDE
+ | `RIGHT_TEE
+ | `RIGHTBUTTON
+ | `RTL_LOGO
+ | `SAILBOAT
+ | `SB_DOWN_ARROW
+ | `SB_H_DOUBLE_ARROW
+ | `SB_LEFT_ARROW
+ | `SB_RIGHT_ARROW
+ | `SB_UP_ARROW
+ | `SB_V_DOUBLE_ARROW
+ | `SHUTTLE
+ | `SIZING
+ | `SPIDER
+ | `SPRAYCAN
+ | `STAR
+ | `TARGET
+ | `TCROSS
+ | `TOP_LEFT_ARROW
+ | `TOP_LEFT_CORNER
+ | `TOP_RIGHT_CORNER
+ | `TOP_SIDE
+ | `TOP_TEE
+ | `TREK
+ | `UL_ANGLE
+ | `UMBRELLA
+ | `UR_ANGLE
+ | `WATCH
+ | `XTERM
+ ]
+ external create : cursor_type -> cursor = "ml_gdk_cursor_new"
+ external create_from_pixmap :
+ pixmap -> mask:bitmap ->
+ fg:Color.t -> bg:Color.t -> x:int -> y:int -> cursor
+ = "ml_gdk_cursor_new_from_pixmap_bc" "ml_gdk_cursor_new_from_pixmap"
+ external destroy : cursor -> unit = "ml_gdk_cursor_destroy"
+end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gdk
+open Tags
+
+external coerce : 'a event -> event_type event = "%identity"
+external unsafe_copy : Gpointer.boxed -> #event_type event
+ = "ml_gdk_event_copy"
+external copy : (#event_type as 'a) event -> 'a event
+ = "ml_gdk_event_copy"
+external get_type : 'a event -> 'a = "ml_GdkEventAny_type"
+external get_window : 'a event -> window = "ml_GdkEventAny_window"
+external get_send_event : 'a event -> bool = "ml_GdkEventAny_send_event"
+
+external create : (#event_type as 'a) -> 'a event
+ = "ml_gdk_event_new"
+external set_window : 'a event -> window -> unit
+ = "ml_gdk_event_set_window"
+
+module Expose = struct
+ type t = [ `EXPOSE ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `EXPOSE -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Expose.cast"
+ external area : t -> Rectangle.t = "ml_GdkEventExpose_area"
+ external count : t -> int = "ml_GdkEventExpose_count"
+end
+
+module Visibility = struct
+ type t = [ `VISIBILITY_NOTIFY ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `VISIBILITY_NOTIFY -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Visibility.cast"
+ external visibility : t -> visibility_state
+ = "ml_GdkEventVisibility_state"
+end
+
+module Motion = struct
+ type t = [ `MOTION_NOTIFY ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `MOTION_NOTIFY -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Motion.cast"
+ external time : t -> int = "ml_GdkEventMotion_time"
+ external x : t -> float = "ml_GdkEventMotion_x"
+ external y : t -> float = "ml_GdkEventMotion_y"
+ external pressure : t -> float = "ml_GdkEventMotion_pressure"
+ external xtilt : t -> float = "ml_GdkEventMotion_xtilt"
+ external ytilt : t -> float = "ml_GdkEventMotion_ytilt"
+ external state : t -> int = "ml_GdkEventMotion_state"
+ external is_hint : t -> bool = "ml_GdkEventMotion_is_hint"
+ external source : t -> input_source = "ml_GdkEventMotion_source"
+ external deviceid : t -> int = "ml_GdkEventMotion_deviceid"
+ external x_root : t -> float = "ml_GdkEventMotion_x_root"
+ external y_root : t -> float = "ml_GdkEventMotion_y_root"
+end
+
+module Button = struct
+ type types =
+ [ `BUTTON_PRESS|`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS|`BUTTON_RELEASE ]
+ type t = types event
+ let cast (ev : event_type event) : t =
+ match get_type ev with
+ `BUTTON_PRESS|`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS|`BUTTON_RELEASE
+ -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Button.cast"
+ external time : t -> int = "ml_GdkEventButton_time"
+ external x : t -> float = "ml_GdkEventButton_x"
+ external y : t -> float = "ml_GdkEventButton_y"
+ external pressure : t -> float = "ml_GdkEventButton_pressure"
+ external xtilt : t -> float = "ml_GdkEventButton_xtilt"
+ external ytilt : t -> float = "ml_GdkEventButton_ytilt"
+ external state : t -> int = "ml_GdkEventButton_state"
+ external button : t -> int = "ml_GdkEventButton_button"
+ external source : t -> input_source = "ml_GdkEventButton_source"
+ external deviceid : t -> int = "ml_GdkEventButton_deviceid"
+ external x_root : t -> float = "ml_GdkEventButton_x_root"
+ external y_root : t -> float = "ml_GdkEventButton_y_root"
+ external set_type : t -> #types -> unit
+ = "ml_gdk_event_set_type"
+ external set_button : t -> int -> unit
+ = "ml_gdk_event_button_set_button"
+end
+
+module Key = struct
+ type t = [ `KEY_PRESS|`KEY_RELEASE ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with
+ `KEY_PRESS|`KEY_RELEASE -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Key.cast"
+ external time : t -> int = "ml_GdkEventKey_time"
+ external state : t -> int = "ml_GdkEventKey_state"
+ external keyval : t -> keysym = "ml_GdkEventKey_keyval"
+ external string : t -> string = "ml_GdkEventKey_string"
+ let state ev = Convert.modifier (state ev)
+end
+
+module Crossing = struct
+ type t = [ `ENTER_NOTIFY|`LEAVE_NOTIFY ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with
+ `ENTER_NOTIFY|`LEAVE_NOTIFY -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Crossing.cast"
+ external subwindow : t -> window = "ml_GdkEventCrossing_subwindow"
+ external detail : t -> notify_type = "ml_GdkEventCrossing_detail"
+end
+
+module Focus = struct
+ type t = [ `FOCUS_CHANGE ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `FOCUS_CHANGE -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Focus.cast"
+ external focus_in : t -> bool = "ml_GdkEventFocus_in"
+end
+
+module Configure = struct
+ type t = [ `CONFIGURE ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `CONFIGURE -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Configure.cast"
+ external x : t -> int = "ml_GdkEventConfigure_x"
+ external y : t -> int = "ml_GdkEventConfigure_y"
+ external width : t -> int = "ml_GdkEventConfigure_width"
+ external height : t -> int = "ml_GdkEventConfigure_height"
+end
+
+module Property = struct
+ type t = [ `PROPERTY_NOTIFY ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with `PROPERTY_NOTIFY -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Property.cast"
+ external atom : t -> atom = "ml_GdkEventProperty_atom"
+ external time : t -> int = "ml_GdkEventProperty_time"
+ external state : t -> int = "ml_GdkEventProperty_state"
+end
+
+module Selection = struct
+ type t = [ `SELECTION_CLEAR|`SELECTION_REQUEST|`SELECTION_NOTIFY ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with
+ `SELECTION_CLEAR|`SELECTION_REQUEST|`SELECTION_NOTIFY -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Selection.cast"
+ external selection : t -> atom = "ml_GdkEventSelection_selection"
+ external target : t -> atom = "ml_GdkEventSelection_target"
+ external property : t -> atom = "ml_GdkEventSelection_property"
+ external requestor : t -> int = "ml_GdkEventSelection_requestor"
+ external time : t -> int = "ml_GdkEventSelection_time"
+end
+
+module Proximity = struct
+ type t = [ `PROXIMITY_IN|`PROXIMITY_OUT ] event
+ let cast (ev : event_type event) : t =
+ match get_type ev with
+ `PROXIMITY_IN|`PROXIMITY_OUT -> Obj.magic ev
+ | _ -> invalid_arg "GdkEvent.Proximity.cast"
+ external time : t -> int = "ml_GdkEventProximity_time"
+ external source : t -> input_source = "ml_GdkEventProximity_source"
+ external deviceid : t -> int = "ml_GdkEventProximity_deviceid"
+end
--- /dev/null
+(* $Id$ *)
+
+open Gdk
+let _VoidSymbol : keysym = 0xFFFFFF
+let _BackSpace : keysym = 0xFF08
+let _Tab : keysym = 0xFF09
+let _Linefeed : keysym = 0xFF0A
+let _Clear : keysym = 0xFF0B
+let _Return : keysym = 0xFF0D
+let _Pause : keysym = 0xFF13
+let _Scroll_Lock : keysym = 0xFF14
+let _Sys_Req : keysym = 0xFF15
+let _Escape : keysym = 0xFF1B
+let _Delete : keysym = 0xFFFF
+let _Multi_key : keysym = 0xFF20
+let _SingleCandidate : keysym = 0xFF3C
+let _MultipleCandidate : keysym = 0xFF3D
+let _PreviousCandidate : keysym = 0xFF3E
+let _Kanji : keysym = 0xFF21
+let _Muhenkan : keysym = 0xFF22
+let _Henkan_Mode : keysym = 0xFF23
+let _Henkan : keysym = 0xFF23
+let _Romaji : keysym = 0xFF24
+let _Hiragana : keysym = 0xFF25
+let _Katakana : keysym = 0xFF26
+let _Hiragana_Katakana : keysym = 0xFF27
+let _Zenkaku : keysym = 0xFF28
+let _Hankaku : keysym = 0xFF29
+let _Zenkaku_Hankaku : keysym = 0xFF2A
+let _Touroku : keysym = 0xFF2B
+let _Massyo : keysym = 0xFF2C
+let _Kana_Lock : keysym = 0xFF2D
+let _Kana_Shift : keysym = 0xFF2E
+let _Eisu_Shift : keysym = 0xFF2F
+let _Eisu_toggle : keysym = 0xFF30
+let _Zen_Koho : keysym = 0xFF3D
+let _Mae_Koho : keysym = 0xFF3E
+let _Home : keysym = 0xFF50
+let _Left : keysym = 0xFF51
+let _Up : keysym = 0xFF52
+let _Right : keysym = 0xFF53
+let _Down : keysym = 0xFF54
+let _Prior : keysym = 0xFF55
+let _Page_Up : keysym = 0xFF55
+let _Next : keysym = 0xFF56
+let _Page_Down : keysym = 0xFF56
+let _End : keysym = 0xFF57
+let _Begin : keysym = 0xFF58
+let _Select : keysym = 0xFF60
+let _Print : keysym = 0xFF61
+let _Execute : keysym = 0xFF62
+let _Insert : keysym = 0xFF63
+let _Undo : keysym = 0xFF65
+let _Redo : keysym = 0xFF66
+let _Menu : keysym = 0xFF67
+let _Find : keysym = 0xFF68
+let _Cancel : keysym = 0xFF69
+let _Help : keysym = 0xFF6A
+let _Break : keysym = 0xFF6B
+let _Mode_switch : keysym = 0xFF7E
+let _script_switch : keysym = 0xFF7E
+let _Num_Lock : keysym = 0xFF7F
+let _KP_Space : keysym = 0xFF80
+let _KP_Tab : keysym = 0xFF89
+let _KP_Enter : keysym = 0xFF8D
+let _KP_F1 : keysym = 0xFF91
+let _KP_F2 : keysym = 0xFF92
+let _KP_F3 : keysym = 0xFF93
+let _KP_F4 : keysym = 0xFF94
+let _KP_Home : keysym = 0xFF95
+let _KP_Left : keysym = 0xFF96
+let _KP_Up : keysym = 0xFF97
+let _KP_Right : keysym = 0xFF98
+let _KP_Down : keysym = 0xFF99
+let _KP_Prior : keysym = 0xFF9A
+let _KP_Page_Up : keysym = 0xFF9A
+let _KP_Next : keysym = 0xFF9B
+let _KP_Page_Down : keysym = 0xFF9B
+let _KP_End : keysym = 0xFF9C
+let _KP_Begin : keysym = 0xFF9D
+let _KP_Insert : keysym = 0xFF9E
+let _KP_Delete : keysym = 0xFF9F
+let _KP_Equal : keysym = 0xFFBD
+let _KP_Multiply : keysym = 0xFFAA
+let _KP_Add : keysym = 0xFFAB
+let _KP_Separator : keysym = 0xFFAC
+let _KP_Subtract : keysym = 0xFFAD
+let _KP_Decimal : keysym = 0xFFAE
+let _KP_Divide : keysym = 0xFFAF
+let _KP_0 : keysym = 0xFFB0
+let _KP_1 : keysym = 0xFFB1
+let _KP_2 : keysym = 0xFFB2
+let _KP_3 : keysym = 0xFFB3
+let _KP_4 : keysym = 0xFFB4
+let _KP_5 : keysym = 0xFFB5
+let _KP_6 : keysym = 0xFFB6
+let _KP_7 : keysym = 0xFFB7
+let _KP_8 : keysym = 0xFFB8
+let _KP_9 : keysym = 0xFFB9
+let _F1 : keysym = 0xFFBE
+let _F2 : keysym = 0xFFBF
+let _F3 : keysym = 0xFFC0
+let _F4 : keysym = 0xFFC1
+let _F5 : keysym = 0xFFC2
+let _F6 : keysym = 0xFFC3
+let _F7 : keysym = 0xFFC4
+let _F8 : keysym = 0xFFC5
+let _F9 : keysym = 0xFFC6
+let _F10 : keysym = 0xFFC7
+let _F11 : keysym = 0xFFC8
+let _L1 : keysym = 0xFFC8
+let _F12 : keysym = 0xFFC9
+let _L2 : keysym = 0xFFC9
+let _F13 : keysym = 0xFFCA
+let _L3 : keysym = 0xFFCA
+let _F14 : keysym = 0xFFCB
+let _L4 : keysym = 0xFFCB
+let _F15 : keysym = 0xFFCC
+let _L5 : keysym = 0xFFCC
+let _F16 : keysym = 0xFFCD
+let _L6 : keysym = 0xFFCD
+let _F17 : keysym = 0xFFCE
+let _L7 : keysym = 0xFFCE
+let _F18 : keysym = 0xFFCF
+let _L8 : keysym = 0xFFCF
+let _F19 : keysym = 0xFFD0
+let _L9 : keysym = 0xFFD0
+let _F20 : keysym = 0xFFD1
+let _L10 : keysym = 0xFFD1
+let _F21 : keysym = 0xFFD2
+let _R1 : keysym = 0xFFD2
+let _F22 : keysym = 0xFFD3
+let _R2 : keysym = 0xFFD3
+let _F23 : keysym = 0xFFD4
+let _R3 : keysym = 0xFFD4
+let _F24 : keysym = 0xFFD5
+let _R4 : keysym = 0xFFD5
+let _F25 : keysym = 0xFFD6
+let _R5 : keysym = 0xFFD6
+let _F26 : keysym = 0xFFD7
+let _R6 : keysym = 0xFFD7
+let _F27 : keysym = 0xFFD8
+let _R7 : keysym = 0xFFD8
+let _F28 : keysym = 0xFFD9
+let _R8 : keysym = 0xFFD9
+let _F29 : keysym = 0xFFDA
+let _R9 : keysym = 0xFFDA
+let _F30 : keysym = 0xFFDB
+let _R10 : keysym = 0xFFDB
+let _F31 : keysym = 0xFFDC
+let _R11 : keysym = 0xFFDC
+let _F32 : keysym = 0xFFDD
+let _R12 : keysym = 0xFFDD
+let _F33 : keysym = 0xFFDE
+let _R13 : keysym = 0xFFDE
+let _F34 : keysym = 0xFFDF
+let _R14 : keysym = 0xFFDF
+let _F35 : keysym = 0xFFE0
+let _R15 : keysym = 0xFFE0
+let _Shift_L : keysym = 0xFFE1
+let _Shift_R : keysym = 0xFFE2
+let _Control_L : keysym = 0xFFE3
+let _Control_R : keysym = 0xFFE4
+let _Caps_Lock : keysym = 0xFFE5
+let _Shift_Lock : keysym = 0xFFE6
+let _Meta_L : keysym = 0xFFE7
+let _Meta_R : keysym = 0xFFE8
+let _Alt_L : keysym = 0xFFE9
+let _Alt_R : keysym = 0xFFEA
+let _Super_L : keysym = 0xFFEB
+let _Super_R : keysym = 0xFFEC
+let _Hyper_L : keysym = 0xFFED
+let _Hyper_R : keysym = 0xFFEE
+let _ISO_Lock : keysym = 0xFE01
+let _ISO_Level2_Latch : keysym = 0xFE02
+let _ISO_Level3_Shift : keysym = 0xFE03
+let _ISO_Level3_Latch : keysym = 0xFE04
+let _ISO_Level3_Lock : keysym = 0xFE05
+let _ISO_Group_Shift : keysym = 0xFF7E
+let _ISO_Group_Latch : keysym = 0xFE06
+let _ISO_Group_Lock : keysym = 0xFE07
+let _ISO_Next_Group : keysym = 0xFE08
+let _ISO_Next_Group_Lock : keysym = 0xFE09
+let _ISO_Prev_Group : keysym = 0xFE0A
+let _ISO_Prev_Group_Lock : keysym = 0xFE0B
+let _ISO_First_Group : keysym = 0xFE0C
+let _ISO_First_Group_Lock : keysym = 0xFE0D
+let _ISO_Last_Group : keysym = 0xFE0E
+let _ISO_Last_Group_Lock : keysym = 0xFE0F
+let _ISO_Left_Tab : keysym = 0xFE20
+let _ISO_Move_Line_Up : keysym = 0xFE21
+let _ISO_Move_Line_Down : keysym = 0xFE22
+let _ISO_Partial_Line_Up : keysym = 0xFE23
+let _ISO_Partial_Line_Down : keysym = 0xFE24
+let _ISO_Partial_Space_Left : keysym = 0xFE25
+let _ISO_Partial_Space_Right : keysym = 0xFE26
+let _ISO_Set_Margin_Left : keysym = 0xFE27
+let _ISO_Set_Margin_Right : keysym = 0xFE28
+let _ISO_Release_Margin_Left : keysym = 0xFE29
+let _ISO_Release_Margin_Right : keysym = 0xFE2A
+let _ISO_Release_Both_Margins : keysym = 0xFE2B
+let _ISO_Fast_Cursor_Left : keysym = 0xFE2C
+let _ISO_Fast_Cursor_Right : keysym = 0xFE2D
+let _ISO_Fast_Cursor_Up : keysym = 0xFE2E
+let _ISO_Fast_Cursor_Down : keysym = 0xFE2F
+let _ISO_Continuous_Underline : keysym = 0xFE30
+let _ISO_Discontinuous_Underline : keysym = 0xFE31
+let _ISO_Emphasize : keysym = 0xFE32
+let _ISO_Center_Object : keysym = 0xFE33
+let _ISO_Enter : keysym = 0xFE34
+let _dead_grave : keysym = 0xFE50
+let _dead_acute : keysym = 0xFE51
+let _dead_circumflex : keysym = 0xFE52
+let _dead_tilde : keysym = 0xFE53
+let _dead_macron : keysym = 0xFE54
+let _dead_breve : keysym = 0xFE55
+let _dead_abovedot : keysym = 0xFE56
+let _dead_diaeresis : keysym = 0xFE57
+let _dead_abovering : keysym = 0xFE58
+let _dead_doubleacute : keysym = 0xFE59
+let _dead_caron : keysym = 0xFE5A
+let _dead_cedilla : keysym = 0xFE5B
+let _dead_ogonek : keysym = 0xFE5C
+let _dead_iota : keysym = 0xFE5D
+let _dead_voiced_sound : keysym = 0xFE5E
+let _dead_semivoiced_sound : keysym = 0xFE5F
+let _dead_belowdot : keysym = 0xFE60
+let _First_Virtual_Screen : keysym = 0xFED0
+let _Prev_Virtual_Screen : keysym = 0xFED1
+let _Next_Virtual_Screen : keysym = 0xFED2
+let _Last_Virtual_Screen : keysym = 0xFED4
+let _Terminate_Server : keysym = 0xFED5
+let _AccessX_Enable : keysym = 0xFE70
+let _AccessX_Feedback_Enable : keysym = 0xFE71
+let _RepeatKeys_Enable : keysym = 0xFE72
+let _SlowKeys_Enable : keysym = 0xFE73
+let _BounceKeys_Enable : keysym = 0xFE74
+let _StickyKeys_Enable : keysym = 0xFE75
+let _MouseKeys_Enable : keysym = 0xFE76
+let _MouseKeys_Accel_Enable : keysym = 0xFE77
+let _Overlay1_Enable : keysym = 0xFE78
+let _Overlay2_Enable : keysym = 0xFE79
+let _AudibleBell_Enable : keysym = 0xFE7A
+let _Pointer_Left : keysym = 0xFEE0
+let _Pointer_Right : keysym = 0xFEE1
+let _Pointer_Up : keysym = 0xFEE2
+let _Pointer_Down : keysym = 0xFEE3
+let _Pointer_UpLeft : keysym = 0xFEE4
+let _Pointer_UpRight : keysym = 0xFEE5
+let _Pointer_DownLeft : keysym = 0xFEE6
+let _Pointer_DownRight : keysym = 0xFEE7
+let _Pointer_Button_Dflt : keysym = 0xFEE8
+let _Pointer_Button1 : keysym = 0xFEE9
+let _Pointer_Button2 : keysym = 0xFEEA
+let _Pointer_Button3 : keysym = 0xFEEB
+let _Pointer_Button4 : keysym = 0xFEEC
+let _Pointer_Button5 : keysym = 0xFEED
+let _Pointer_DblClick_Dflt : keysym = 0xFEEE
+let _Pointer_DblClick1 : keysym = 0xFEEF
+let _Pointer_DblClick2 : keysym = 0xFEF0
+let _Pointer_DblClick3 : keysym = 0xFEF1
+let _Pointer_DblClick4 : keysym = 0xFEF2
+let _Pointer_DblClick5 : keysym = 0xFEF3
+let _Pointer_Drag_Dflt : keysym = 0xFEF4
+let _Pointer_Drag1 : keysym = 0xFEF5
+let _Pointer_Drag2 : keysym = 0xFEF6
+let _Pointer_Drag3 : keysym = 0xFEF7
+let _Pointer_Drag4 : keysym = 0xFEF8
+let _Pointer_Drag5 : keysym = 0xFEFD
+let _Pointer_EnableKeys : keysym = 0xFEF9
+let _Pointer_Accelerate : keysym = 0xFEFA
+let _Pointer_DfltBtnNext : keysym = 0xFEFB
+let _Pointer_DfltBtnPrev : keysym = 0xFEFC
+let _3270_Duplicate : keysym = 0xFD01
+let _3270_FieldMark : keysym = 0xFD02
+let _3270_Right2 : keysym = 0xFD03
+let _3270_Left2 : keysym = 0xFD04
+let _3270_BackTab : keysym = 0xFD05
+let _3270_EraseEOF : keysym = 0xFD06
+let _3270_EraseInput : keysym = 0xFD07
+let _3270_Reset : keysym = 0xFD08
+let _3270_Quit : keysym = 0xFD09
+let _3270_PA1 : keysym = 0xFD0A
+let _3270_PA2 : keysym = 0xFD0B
+let _3270_PA3 : keysym = 0xFD0C
+let _3270_Test : keysym = 0xFD0D
+let _3270_Attn : keysym = 0xFD0E
+let _3270_CursorBlink : keysym = 0xFD0F
+let _3270_AltCursor : keysym = 0xFD10
+let _3270_KeyClick : keysym = 0xFD11
+let _3270_Jump : keysym = 0xFD12
+let _3270_Ident : keysym = 0xFD13
+let _3270_Rule : keysym = 0xFD14
+let _3270_Copy : keysym = 0xFD15
+let _3270_Play : keysym = 0xFD16
+let _3270_Setup : keysym = 0xFD17
+let _3270_Record : keysym = 0xFD18
+let _3270_ChangeScreen : keysym = 0xFD19
+let _3270_DeleteWord : keysym = 0xFD1A
+let _3270_ExSelect : keysym = 0xFD1B
+let _3270_CursorSelect : keysym = 0xFD1C
+let _3270_PrintScreen : keysym = 0xFD1D
+let _3270_Enter : keysym = 0xFD1E
+let _space : keysym = 0x020
+let _exclam : keysym = 0x021
+let _quotedbl : keysym = 0x022
+let _numbersign : keysym = 0x023
+let _dollar : keysym = 0x024
+let _percent : keysym = 0x025
+let _ampersand : keysym = 0x026
+let _apostrophe : keysym = 0x027
+let _quoteright : keysym = 0x027
+let _parenleft : keysym = 0x028
+let _parenright : keysym = 0x029
+let _asterisk : keysym = 0x02a
+let _plus : keysym = 0x02b
+let _comma : keysym = 0x02c
+let _minus : keysym = 0x02d
+let _period : keysym = 0x02e
+let _slash : keysym = 0x02f
+let _0 : keysym = 0x030
+let _1 : keysym = 0x031
+let _2 : keysym = 0x032
+let _3 : keysym = 0x033
+let _4 : keysym = 0x034
+let _5 : keysym = 0x035
+let _6 : keysym = 0x036
+let _7 : keysym = 0x037
+let _8 : keysym = 0x038
+let _9 : keysym = 0x039
+let _colon : keysym = 0x03a
+let _semicolon : keysym = 0x03b
+let _less : keysym = 0x03c
+let _equal : keysym = 0x03d
+let _greater : keysym = 0x03e
+let _question : keysym = 0x03f
+let _at : keysym = 0x040
+let _A : keysym = 0x041
+let _B : keysym = 0x042
+let _C : keysym = 0x043
+let _D : keysym = 0x044
+let _E : keysym = 0x045
+let _F : keysym = 0x046
+let _G : keysym = 0x047
+let _H : keysym = 0x048
+let _I : keysym = 0x049
+let _J : keysym = 0x04a
+let _K : keysym = 0x04b
+let _L : keysym = 0x04c
+let _M : keysym = 0x04d
+let _N : keysym = 0x04e
+let _O : keysym = 0x04f
+let _P : keysym = 0x050
+let _Q : keysym = 0x051
+let _R : keysym = 0x052
+let _S : keysym = 0x053
+let _T : keysym = 0x054
+let _U : keysym = 0x055
+let _V : keysym = 0x056
+let _W : keysym = 0x057
+let _X : keysym = 0x058
+let _Y : keysym = 0x059
+let _Z : keysym = 0x05a
+let _bracketleft : keysym = 0x05b
+let _backslash : keysym = 0x05c
+let _bracketright : keysym = 0x05d
+let _asciicircum : keysym = 0x05e
+let _underscore : keysym = 0x05f
+let _grave : keysym = 0x060
+let _quoteleft : keysym = 0x060
+let _a : keysym = 0x061
+let _b : keysym = 0x062
+let _c : keysym = 0x063
+let _d : keysym = 0x064
+let _e : keysym = 0x065
+let _f : keysym = 0x066
+let _g : keysym = 0x067
+let _h : keysym = 0x068
+let _i : keysym = 0x069
+let _j : keysym = 0x06a
+let _k : keysym = 0x06b
+let _l : keysym = 0x06c
+let _m : keysym = 0x06d
+let _n : keysym = 0x06e
+let _o : keysym = 0x06f
+let _p : keysym = 0x070
+let _q : keysym = 0x071
+let _r : keysym = 0x072
+let _s : keysym = 0x073
+let _t : keysym = 0x074
+let _u : keysym = 0x075
+let _v : keysym = 0x076
+let _w : keysym = 0x077
+let _x : keysym = 0x078
+let _y : keysym = 0x079
+let _z : keysym = 0x07a
+let _braceleft : keysym = 0x07b
+let _bar : keysym = 0x07c
+let _braceright : keysym = 0x07d
+let _asciitilde : keysym = 0x07e
+let _nobreakspace : keysym = 0x0a0
+let _exclamdown : keysym = 0x0a1
+let _cent : keysym = 0x0a2
+let _sterling : keysym = 0x0a3
+let _currency : keysym = 0x0a4
+let _yen : keysym = 0x0a5
+let _brokenbar : keysym = 0x0a6
+let _section : keysym = 0x0a7
+let _diaeresis : keysym = 0x0a8
+let _copyright : keysym = 0x0a9
+let _ordfeminine : keysym = 0x0aa
+let _guillemotleft : keysym = 0x0ab
+let _notsign : keysym = 0x0ac
+let _hyphen : keysym = 0x0ad
+let _registered : keysym = 0x0ae
+let _macron : keysym = 0x0af
+let _degree : keysym = 0x0b0
+let _plusminus : keysym = 0x0b1
+let _twosuperior : keysym = 0x0b2
+let _threesuperior : keysym = 0x0b3
+let _acute : keysym = 0x0b4
+let _mu : keysym = 0x0b5
+let _paragraph : keysym = 0x0b6
+let _periodcentered : keysym = 0x0b7
+let _cedilla : keysym = 0x0b8
+let _onesuperior : keysym = 0x0b9
+let _masculine : keysym = 0x0ba
+let _guillemotright : keysym = 0x0bb
+let _onequarter : keysym = 0x0bc
+let _onehalf : keysym = 0x0bd
+let _threequarters : keysym = 0x0be
+let _questiondown : keysym = 0x0bf
+let _Agrave : keysym = 0x0c0
+let _Aacute : keysym = 0x0c1
+let _Acircumflex : keysym = 0x0c2
+let _Atilde : keysym = 0x0c3
+let _Adiaeresis : keysym = 0x0c4
+let _Aring : keysym = 0x0c5
+let _AE : keysym = 0x0c6
+let _Ccedilla : keysym = 0x0c7
+let _Egrave : keysym = 0x0c8
+let _Eacute : keysym = 0x0c9
+let _Ecircumflex : keysym = 0x0ca
+let _Ediaeresis : keysym = 0x0cb
+let _Igrave : keysym = 0x0cc
+let _Iacute : keysym = 0x0cd
+let _Icircumflex : keysym = 0x0ce
+let _Idiaeresis : keysym = 0x0cf
+let _ETH : keysym = 0x0d0
+let _Eth : keysym = 0x0d0
+let _Ntilde : keysym = 0x0d1
+let _Ograve : keysym = 0x0d2
+let _Oacute : keysym = 0x0d3
+let _Ocircumflex : keysym = 0x0d4
+let _Otilde : keysym = 0x0d5
+let _Odiaeresis : keysym = 0x0d6
+let _multiply : keysym = 0x0d7
+let _Ooblique : keysym = 0x0d8
+let _Ugrave : keysym = 0x0d9
+let _Uacute : keysym = 0x0da
+let _Ucircumflex : keysym = 0x0db
+let _Udiaeresis : keysym = 0x0dc
+let _Yacute : keysym = 0x0dd
+let _THORN : keysym = 0x0de
+let _Thorn : keysym = 0x0de
+let _ssharp : keysym = 0x0df
+let _agrave : keysym = 0x0e0
+let _aacute : keysym = 0x0e1
+let _acircumflex : keysym = 0x0e2
+let _atilde : keysym = 0x0e3
+let _adiaeresis : keysym = 0x0e4
+let _aring : keysym = 0x0e5
+let _ae : keysym = 0x0e6
+let _ccedilla : keysym = 0x0e7
+let _egrave : keysym = 0x0e8
+let _eacute : keysym = 0x0e9
+let _ecircumflex : keysym = 0x0ea
+let _ediaeresis : keysym = 0x0eb
+let _igrave : keysym = 0x0ec
+let _iacute : keysym = 0x0ed
+let _icircumflex : keysym = 0x0ee
+let _idiaeresis : keysym = 0x0ef
+let _eth : keysym = 0x0f0
+let _ntilde : keysym = 0x0f1
+let _ograve : keysym = 0x0f2
+let _oacute : keysym = 0x0f3
+let _ocircumflex : keysym = 0x0f4
+let _otilde : keysym = 0x0f5
+let _odiaeresis : keysym = 0x0f6
+let _division : keysym = 0x0f7
+let _oslash : keysym = 0x0f8
+let _ugrave : keysym = 0x0f9
+let _uacute : keysym = 0x0fa
+let _ucircumflex : keysym = 0x0fb
+let _udiaeresis : keysym = 0x0fc
+let _yacute : keysym = 0x0fd
+let _thorn : keysym = 0x0fe
+let _ydiaeresis : keysym = 0x0ff
+let _Aogonek : keysym = 0x1a1
+let _breve : keysym = 0x1a2
+let _Lstroke : keysym = 0x1a3
+let _Lcaron : keysym = 0x1a5
+let _Sacute : keysym = 0x1a6
+let _Scaron : keysym = 0x1a9
+let _Scedilla : keysym = 0x1aa
+let _Tcaron : keysym = 0x1ab
+let _Zacute : keysym = 0x1ac
+let _Zcaron : keysym = 0x1ae
+let _Zabovedot : keysym = 0x1af
+let _aogonek : keysym = 0x1b1
+let _ogonek : keysym = 0x1b2
+let _lstroke : keysym = 0x1b3
+let _lcaron : keysym = 0x1b5
+let _sacute : keysym = 0x1b6
+let _caron : keysym = 0x1b7
+let _scaron : keysym = 0x1b9
+let _scedilla : keysym = 0x1ba
+let _tcaron : keysym = 0x1bb
+let _zacute : keysym = 0x1bc
+let _doubleacute : keysym = 0x1bd
+let _zcaron : keysym = 0x1be
+let _zabovedot : keysym = 0x1bf
+let _Racute : keysym = 0x1c0
+let _Abreve : keysym = 0x1c3
+let _Lacute : keysym = 0x1c5
+let _Cacute : keysym = 0x1c6
+let _Ccaron : keysym = 0x1c8
+let _Eogonek : keysym = 0x1ca
+let _Ecaron : keysym = 0x1cc
+let _Dcaron : keysym = 0x1cf
+let _Dstroke : keysym = 0x1d0
+let _Nacute : keysym = 0x1d1
+let _Ncaron : keysym = 0x1d2
+let _Odoubleacute : keysym = 0x1d5
+let _Rcaron : keysym = 0x1d8
+let _Uring : keysym = 0x1d9
+let _Udoubleacute : keysym = 0x1db
+let _Tcedilla : keysym = 0x1de
+let _racute : keysym = 0x1e0
+let _abreve : keysym = 0x1e3
+let _lacute : keysym = 0x1e5
+let _cacute : keysym = 0x1e6
+let _ccaron : keysym = 0x1e8
+let _eogonek : keysym = 0x1ea
+let _ecaron : keysym = 0x1ec
+let _dcaron : keysym = 0x1ef
+let _dstroke : keysym = 0x1f0
+let _nacute : keysym = 0x1f1
+let _ncaron : keysym = 0x1f2
+let _odoubleacute : keysym = 0x1f5
+let _udoubleacute : keysym = 0x1fb
+let _rcaron : keysym = 0x1f8
+let _uring : keysym = 0x1f9
+let _tcedilla : keysym = 0x1fe
+let _abovedot : keysym = 0x1ff
+let _Hstroke : keysym = 0x2a1
+let _Hcircumflex : keysym = 0x2a6
+let _Iabovedot : keysym = 0x2a9
+let _Gbreve : keysym = 0x2ab
+let _Jcircumflex : keysym = 0x2ac
+let _hstroke : keysym = 0x2b1
+let _hcircumflex : keysym = 0x2b6
+let _idotless : keysym = 0x2b9
+let _gbreve : keysym = 0x2bb
+let _jcircumflex : keysym = 0x2bc
+let _Cabovedot : keysym = 0x2c5
+let _Ccircumflex : keysym = 0x2c6
+let _Gabovedot : keysym = 0x2d5
+let _Gcircumflex : keysym = 0x2d8
+let _Ubreve : keysym = 0x2dd
+let _Scircumflex : keysym = 0x2de
+let _cabovedot : keysym = 0x2e5
+let _ccircumflex : keysym = 0x2e6
+let _gabovedot : keysym = 0x2f5
+let _gcircumflex : keysym = 0x2f8
+let _ubreve : keysym = 0x2fd
+let _scircumflex : keysym = 0x2fe
+let _kra : keysym = 0x3a2
+let _kappa : keysym = 0x3a2
+let _Rcedilla : keysym = 0x3a3
+let _Itilde : keysym = 0x3a5
+let _Lcedilla : keysym = 0x3a6
+let _Emacron : keysym = 0x3aa
+let _Gcedilla : keysym = 0x3ab
+let _Tslash : keysym = 0x3ac
+let _rcedilla : keysym = 0x3b3
+let _itilde : keysym = 0x3b5
+let _lcedilla : keysym = 0x3b6
+let _emacron : keysym = 0x3ba
+let _gcedilla : keysym = 0x3bb
+let _tslash : keysym = 0x3bc
+let _ENG : keysym = 0x3bd
+let _eng : keysym = 0x3bf
+let _Amacron : keysym = 0x3c0
+let _Iogonek : keysym = 0x3c7
+let _Eabovedot : keysym = 0x3cc
+let _Imacron : keysym = 0x3cf
+let _Ncedilla : keysym = 0x3d1
+let _Omacron : keysym = 0x3d2
+let _Kcedilla : keysym = 0x3d3
+let _Uogonek : keysym = 0x3d9
+let _Utilde : keysym = 0x3dd
+let _Umacron : keysym = 0x3de
+let _amacron : keysym = 0x3e0
+let _iogonek : keysym = 0x3e7
+let _eabovedot : keysym = 0x3ec
+let _imacron : keysym = 0x3ef
+let _ncedilla : keysym = 0x3f1
+let _omacron : keysym = 0x3f2
+let _kcedilla : keysym = 0x3f3
+let _uogonek : keysym = 0x3f9
+let _utilde : keysym = 0x3fd
+let _umacron : keysym = 0x3fe
+let _overline : keysym = 0x47e
+let _kana_fullstop : keysym = 0x4a1
+let _kana_openingbracket : keysym = 0x4a2
+let _kana_closingbracket : keysym = 0x4a3
+let _kana_comma : keysym = 0x4a4
+let _kana_conjunctive : keysym = 0x4a5
+let _kana_middledot : keysym = 0x4a5
+let _kana_WO : keysym = 0x4a6
+let _kana_a : keysym = 0x4a7
+let _kana_i : keysym = 0x4a8
+let _kana_u : keysym = 0x4a9
+let _kana_e : keysym = 0x4aa
+let _kana_o : keysym = 0x4ab
+let _kana_ya : keysym = 0x4ac
+let _kana_yu : keysym = 0x4ad
+let _kana_yo : keysym = 0x4ae
+let _kana_tsu : keysym = 0x4af
+let _kana_tu : keysym = 0x4af
+let _prolongedsound : keysym = 0x4b0
+let _kana_A : keysym = 0x4b1
+let _kana_I : keysym = 0x4b2
+let _kana_U : keysym = 0x4b3
+let _kana_E : keysym = 0x4b4
+let _kana_O : keysym = 0x4b5
+let _kana_KA : keysym = 0x4b6
+let _kana_KI : keysym = 0x4b7
+let _kana_KU : keysym = 0x4b8
+let _kana_KE : keysym = 0x4b9
+let _kana_KO : keysym = 0x4ba
+let _kana_SA : keysym = 0x4bb
+let _kana_SHI : keysym = 0x4bc
+let _kana_SU : keysym = 0x4bd
+let _kana_SE : keysym = 0x4be
+let _kana_SO : keysym = 0x4bf
+let _kana_TA : keysym = 0x4c0
+let _kana_CHI : keysym = 0x4c1
+let _kana_TI : keysym = 0x4c1
+let _kana_TSU : keysym = 0x4c2
+let _kana_TU : keysym = 0x4c2
+let _kana_TE : keysym = 0x4c3
+let _kana_TO : keysym = 0x4c4
+let _kana_NA : keysym = 0x4c5
+let _kana_NI : keysym = 0x4c6
+let _kana_NU : keysym = 0x4c7
+let _kana_NE : keysym = 0x4c8
+let _kana_NO : keysym = 0x4c9
+let _kana_HA : keysym = 0x4ca
+let _kana_HI : keysym = 0x4cb
+let _kana_FU : keysym = 0x4cc
+let _kana_HU : keysym = 0x4cc
+let _kana_HE : keysym = 0x4cd
+let _kana_HO : keysym = 0x4ce
+let _kana_MA : keysym = 0x4cf
+let _kana_MI : keysym = 0x4d0
+let _kana_MU : keysym = 0x4d1
+let _kana_ME : keysym = 0x4d2
+let _kana_MO : keysym = 0x4d3
+let _kana_YA : keysym = 0x4d4
+let _kana_YU : keysym = 0x4d5
+let _kana_YO : keysym = 0x4d6
+let _kana_RA : keysym = 0x4d7
+let _kana_RI : keysym = 0x4d8
+let _kana_RU : keysym = 0x4d9
+let _kana_RE : keysym = 0x4da
+let _kana_RO : keysym = 0x4db
+let _kana_WA : keysym = 0x4dc
+let _kana_N : keysym = 0x4dd
+let _voicedsound : keysym = 0x4de
+let _semivoicedsound : keysym = 0x4df
+let _kana_switch : keysym = 0xFF7E
+let _Arabic_comma : keysym = 0x5ac
+let _Arabic_semicolon : keysym = 0x5bb
+let _Arabic_question_mark : keysym = 0x5bf
+let _Arabic_hamza : keysym = 0x5c1
+let _Arabic_maddaonalef : keysym = 0x5c2
+let _Arabic_hamzaonalef : keysym = 0x5c3
+let _Arabic_hamzaonwaw : keysym = 0x5c4
+let _Arabic_hamzaunderalef : keysym = 0x5c5
+let _Arabic_hamzaonyeh : keysym = 0x5c6
+let _Arabic_alef : keysym = 0x5c7
+let _Arabic_beh : keysym = 0x5c8
+let _Arabic_tehmarbuta : keysym = 0x5c9
+let _Arabic_teh : keysym = 0x5ca
+let _Arabic_theh : keysym = 0x5cb
+let _Arabic_jeem : keysym = 0x5cc
+let _Arabic_hah : keysym = 0x5cd
+let _Arabic_khah : keysym = 0x5ce
+let _Arabic_dal : keysym = 0x5cf
+let _Arabic_thal : keysym = 0x5d0
+let _Arabic_ra : keysym = 0x5d1
+let _Arabic_zain : keysym = 0x5d2
+let _Arabic_seen : keysym = 0x5d3
+let _Arabic_sheen : keysym = 0x5d4
+let _Arabic_sad : keysym = 0x5d5
+let _Arabic_dad : keysym = 0x5d6
+let _Arabic_tah : keysym = 0x5d7
+let _Arabic_zah : keysym = 0x5d8
+let _Arabic_ain : keysym = 0x5d9
+let _Arabic_ghain : keysym = 0x5da
+let _Arabic_tatweel : keysym = 0x5e0
+let _Arabic_feh : keysym = 0x5e1
+let _Arabic_qaf : keysym = 0x5e2
+let _Arabic_kaf : keysym = 0x5e3
+let _Arabic_lam : keysym = 0x5e4
+let _Arabic_meem : keysym = 0x5e5
+let _Arabic_noon : keysym = 0x5e6
+let _Arabic_ha : keysym = 0x5e7
+let _Arabic_heh : keysym = 0x5e7
+let _Arabic_waw : keysym = 0x5e8
+let _Arabic_alefmaksura : keysym = 0x5e9
+let _Arabic_yeh : keysym = 0x5ea
+let _Arabic_fathatan : keysym = 0x5eb
+let _Arabic_dammatan : keysym = 0x5ec
+let _Arabic_kasratan : keysym = 0x5ed
+let _Arabic_fatha : keysym = 0x5ee
+let _Arabic_damma : keysym = 0x5ef
+let _Arabic_kasra : keysym = 0x5f0
+let _Arabic_shadda : keysym = 0x5f1
+let _Arabic_sukun : keysym = 0x5f2
+let _Arabic_switch : keysym = 0xFF7E
+let _Serbian_dje : keysym = 0x6a1
+let _Macedonia_gje : keysym = 0x6a2
+let _Cyrillic_io : keysym = 0x6a3
+let _Ukrainian_ie : keysym = 0x6a4
+let _Ukranian_je : keysym = 0x6a4
+let _Macedonia_dse : keysym = 0x6a5
+let _Ukrainian_i : keysym = 0x6a6
+let _Ukranian_i : keysym = 0x6a6
+let _Ukrainian_yi : keysym = 0x6a7
+let _Ukranian_yi : keysym = 0x6a7
+let _Cyrillic_je : keysym = 0x6a8
+let _Serbian_je : keysym = 0x6a8
+let _Cyrillic_lje : keysym = 0x6a9
+let _Serbian_lje : keysym = 0x6a9
+let _Cyrillic_nje : keysym = 0x6aa
+let _Serbian_nje : keysym = 0x6aa
+let _Serbian_tshe : keysym = 0x6ab
+let _Macedonia_kje : keysym = 0x6ac
+let _Byelorussian_shortu : keysym = 0x6ae
+let _Cyrillic_dzhe : keysym = 0x6af
+let _Serbian_dze : keysym = 0x6af
+let _numerosign : keysym = 0x6b0
+let _Serbian_DJE : keysym = 0x6b1
+let _Macedonia_GJE : keysym = 0x6b2
+let _Cyrillic_IO : keysym = 0x6b3
+let _Ukrainian_IE : keysym = 0x6b4
+let _Ukranian_JE : keysym = 0x6b4
+let _Macedonia_DSE : keysym = 0x6b5
+let _Ukrainian_I : keysym = 0x6b6
+let _Ukranian_I : keysym = 0x6b6
+let _Ukrainian_YI : keysym = 0x6b7
+let _Ukranian_YI : keysym = 0x6b7
+let _Cyrillic_JE : keysym = 0x6b8
+let _Serbian_JE : keysym = 0x6b8
+let _Cyrillic_LJE : keysym = 0x6b9
+let _Serbian_LJE : keysym = 0x6b9
+let _Cyrillic_NJE : keysym = 0x6ba
+let _Serbian_NJE : keysym = 0x6ba
+let _Serbian_TSHE : keysym = 0x6bb
+let _Macedonia_KJE : keysym = 0x6bc
+let _Byelorussian_SHORTU : keysym = 0x6be
+let _Cyrillic_DZHE : keysym = 0x6bf
+let _Serbian_DZE : keysym = 0x6bf
+let _Cyrillic_yu : keysym = 0x6c0
+let _Cyrillic_a : keysym = 0x6c1
+let _Cyrillic_be : keysym = 0x6c2
+let _Cyrillic_tse : keysym = 0x6c3
+let _Cyrillic_de : keysym = 0x6c4
+let _Cyrillic_ie : keysym = 0x6c5
+let _Cyrillic_ef : keysym = 0x6c6
+let _Cyrillic_ghe : keysym = 0x6c7
+let _Cyrillic_ha : keysym = 0x6c8
+let _Cyrillic_i : keysym = 0x6c9
+let _Cyrillic_shorti : keysym = 0x6ca
+let _Cyrillic_ka : keysym = 0x6cb
+let _Cyrillic_el : keysym = 0x6cc
+let _Cyrillic_em : keysym = 0x6cd
+let _Cyrillic_en : keysym = 0x6ce
+let _Cyrillic_o : keysym = 0x6cf
+let _Cyrillic_pe : keysym = 0x6d0
+let _Cyrillic_ya : keysym = 0x6d1
+let _Cyrillic_er : keysym = 0x6d2
+let _Cyrillic_es : keysym = 0x6d3
+let _Cyrillic_te : keysym = 0x6d4
+let _Cyrillic_u : keysym = 0x6d5
+let _Cyrillic_zhe : keysym = 0x6d6
+let _Cyrillic_ve : keysym = 0x6d7
+let _Cyrillic_softsign : keysym = 0x6d8
+let _Cyrillic_yeru : keysym = 0x6d9
+let _Cyrillic_ze : keysym = 0x6da
+let _Cyrillic_sha : keysym = 0x6db
+let _Cyrillic_e : keysym = 0x6dc
+let _Cyrillic_shcha : keysym = 0x6dd
+let _Cyrillic_che : keysym = 0x6de
+let _Cyrillic_hardsign : keysym = 0x6df
+let _Cyrillic_YU : keysym = 0x6e0
+let _Cyrillic_A : keysym = 0x6e1
+let _Cyrillic_BE : keysym = 0x6e2
+let _Cyrillic_TSE : keysym = 0x6e3
+let _Cyrillic_DE : keysym = 0x6e4
+let _Cyrillic_IE : keysym = 0x6e5
+let _Cyrillic_EF : keysym = 0x6e6
+let _Cyrillic_GHE : keysym = 0x6e7
+let _Cyrillic_HA : keysym = 0x6e8
+let _Cyrillic_I : keysym = 0x6e9
+let _Cyrillic_SHORTI : keysym = 0x6ea
+let _Cyrillic_KA : keysym = 0x6eb
+let _Cyrillic_EL : keysym = 0x6ec
+let _Cyrillic_EM : keysym = 0x6ed
+let _Cyrillic_EN : keysym = 0x6ee
+let _Cyrillic_O : keysym = 0x6ef
+let _Cyrillic_PE : keysym = 0x6f0
+let _Cyrillic_YA : keysym = 0x6f1
+let _Cyrillic_ER : keysym = 0x6f2
+let _Cyrillic_ES : keysym = 0x6f3
+let _Cyrillic_TE : keysym = 0x6f4
+let _Cyrillic_U : keysym = 0x6f5
+let _Cyrillic_ZHE : keysym = 0x6f6
+let _Cyrillic_VE : keysym = 0x6f7
+let _Cyrillic_SOFTSIGN : keysym = 0x6f8
+let _Cyrillic_YERU : keysym = 0x6f9
+let _Cyrillic_ZE : keysym = 0x6fa
+let _Cyrillic_SHA : keysym = 0x6fb
+let _Cyrillic_E : keysym = 0x6fc
+let _Cyrillic_SHCHA : keysym = 0x6fd
+let _Cyrillic_CHE : keysym = 0x6fe
+let _Cyrillic_HARDSIGN : keysym = 0x6ff
+let _Greek_ALPHAaccent : keysym = 0x7a1
+let _Greek_EPSILONaccent : keysym = 0x7a2
+let _Greek_ETAaccent : keysym = 0x7a3
+let _Greek_IOTAaccent : keysym = 0x7a4
+let _Greek_IOTAdiaeresis : keysym = 0x7a5
+let _Greek_OMICRONaccent : keysym = 0x7a7
+let _Greek_UPSILONaccent : keysym = 0x7a8
+let _Greek_UPSILONdieresis : keysym = 0x7a9
+let _Greek_OMEGAaccent : keysym = 0x7ab
+let _Greek_accentdieresis : keysym = 0x7ae
+let _Greek_horizbar : keysym = 0x7af
+let _Greek_alphaaccent : keysym = 0x7b1
+let _Greek_epsilonaccent : keysym = 0x7b2
+let _Greek_etaaccent : keysym = 0x7b3
+let _Greek_iotaaccent : keysym = 0x7b4
+let _Greek_iotadieresis : keysym = 0x7b5
+let _Greek_iotaaccentdieresis : keysym = 0x7b6
+let _Greek_omicronaccent : keysym = 0x7b7
+let _Greek_upsilonaccent : keysym = 0x7b8
+let _Greek_upsilondieresis : keysym = 0x7b9
+let _Greek_upsilonaccentdieresis : keysym = 0x7ba
+let _Greek_omegaaccent : keysym = 0x7bb
+let _Greek_ALPHA : keysym = 0x7c1
+let _Greek_BETA : keysym = 0x7c2
+let _Greek_GAMMA : keysym = 0x7c3
+let _Greek_DELTA : keysym = 0x7c4
+let _Greek_EPSILON : keysym = 0x7c5
+let _Greek_ZETA : keysym = 0x7c6
+let _Greek_ETA : keysym = 0x7c7
+let _Greek_THETA : keysym = 0x7c8
+let _Greek_IOTA : keysym = 0x7c9
+let _Greek_KAPPA : keysym = 0x7ca
+let _Greek_LAMDA : keysym = 0x7cb
+let _Greek_LAMBDA : keysym = 0x7cb
+let _Greek_MU : keysym = 0x7cc
+let _Greek_NU : keysym = 0x7cd
+let _Greek_XI : keysym = 0x7ce
+let _Greek_OMICRON : keysym = 0x7cf
+let _Greek_PI : keysym = 0x7d0
+let _Greek_RHO : keysym = 0x7d1
+let _Greek_SIGMA : keysym = 0x7d2
+let _Greek_TAU : keysym = 0x7d4
+let _Greek_UPSILON : keysym = 0x7d5
+let _Greek_PHI : keysym = 0x7d6
+let _Greek_CHI : keysym = 0x7d7
+let _Greek_PSI : keysym = 0x7d8
+let _Greek_OMEGA : keysym = 0x7d9
+let _Greek_alpha : keysym = 0x7e1
+let _Greek_beta : keysym = 0x7e2
+let _Greek_gamma : keysym = 0x7e3
+let _Greek_delta : keysym = 0x7e4
+let _Greek_epsilon : keysym = 0x7e5
+let _Greek_zeta : keysym = 0x7e6
+let _Greek_eta : keysym = 0x7e7
+let _Greek_theta : keysym = 0x7e8
+let _Greek_iota : keysym = 0x7e9
+let _Greek_kappa : keysym = 0x7ea
+let _Greek_lamda : keysym = 0x7eb
+let _Greek_lambda : keysym = 0x7eb
+let _Greek_mu : keysym = 0x7ec
+let _Greek_nu : keysym = 0x7ed
+let _Greek_xi : keysym = 0x7ee
+let _Greek_omicron : keysym = 0x7ef
+let _Greek_pi : keysym = 0x7f0
+let _Greek_rho : keysym = 0x7f1
+let _Greek_sigma : keysym = 0x7f2
+let _Greek_finalsmallsigma : keysym = 0x7f3
+let _Greek_tau : keysym = 0x7f4
+let _Greek_upsilon : keysym = 0x7f5
+let _Greek_phi : keysym = 0x7f6
+let _Greek_chi : keysym = 0x7f7
+let _Greek_psi : keysym = 0x7f8
+let _Greek_omega : keysym = 0x7f9
+let _Greek_switch : keysym = 0xFF7E
+let _leftradical : keysym = 0x8a1
+let _topleftradical : keysym = 0x8a2
+let _horizconnector : keysym = 0x8a3
+let _topintegral : keysym = 0x8a4
+let _botintegral : keysym = 0x8a5
+let _vertconnector : keysym = 0x8a6
+let _topleftsqbracket : keysym = 0x8a7
+let _botleftsqbracket : keysym = 0x8a8
+let _toprightsqbracket : keysym = 0x8a9
+let _botrightsqbracket : keysym = 0x8aa
+let _topleftparens : keysym = 0x8ab
+let _botleftparens : keysym = 0x8ac
+let _toprightparens : keysym = 0x8ad
+let _botrightparens : keysym = 0x8ae
+let _leftmiddlecurlybrace : keysym = 0x8af
+let _rightmiddlecurlybrace : keysym = 0x8b0
+let _topleftsummation : keysym = 0x8b1
+let _botleftsummation : keysym = 0x8b2
+let _topvertsummationconnector : keysym = 0x8b3
+let _botvertsummationconnector : keysym = 0x8b4
+let _toprightsummation : keysym = 0x8b5
+let _botrightsummation : keysym = 0x8b6
+let _rightmiddlesummation : keysym = 0x8b7
+let _lessthanequal : keysym = 0x8bc
+let _notequal : keysym = 0x8bd
+let _greaterthanequal : keysym = 0x8be
+let _integral : keysym = 0x8bf
+let _therefore : keysym = 0x8c0
+let _variation : keysym = 0x8c1
+let _infinity : keysym = 0x8c2
+let _nabla : keysym = 0x8c5
+let _approximate : keysym = 0x8c8
+let _similarequal : keysym = 0x8c9
+let _ifonlyif : keysym = 0x8cd
+let _implies : keysym = 0x8ce
+let _identical : keysym = 0x8cf
+let _radical : keysym = 0x8d6
+let _includedin : keysym = 0x8da
+let _includes : keysym = 0x8db
+let _intersection : keysym = 0x8dc
+let _union : keysym = 0x8dd
+let _logicaland : keysym = 0x8de
+let _logicalor : keysym = 0x8df
+let _partialderivative : keysym = 0x8ef
+let _function : keysym = 0x8f6
+let _leftarrow : keysym = 0x8fb
+let _uparrow : keysym = 0x8fc
+let _rightarrow : keysym = 0x8fd
+let _downarrow : keysym = 0x8fe
+let _blank : keysym = 0x9df
+let _soliddiamond : keysym = 0x9e0
+let _checkerboard : keysym = 0x9e1
+let _ht : keysym = 0x9e2
+let _ff : keysym = 0x9e3
+let _cr : keysym = 0x9e4
+let _lf : keysym = 0x9e5
+let _nl : keysym = 0x9e8
+let _vt : keysym = 0x9e9
+let _lowrightcorner : keysym = 0x9ea
+let _uprightcorner : keysym = 0x9eb
+let _upleftcorner : keysym = 0x9ec
+let _lowleftcorner : keysym = 0x9ed
+let _crossinglines : keysym = 0x9ee
+let _horizlinescan1 : keysym = 0x9ef
+let _horizlinescan3 : keysym = 0x9f0
+let _horizlinescan5 : keysym = 0x9f1
+let _horizlinescan7 : keysym = 0x9f2
+let _horizlinescan9 : keysym = 0x9f3
+let _leftt : keysym = 0x9f4
+let _rightt : keysym = 0x9f5
+let _bott : keysym = 0x9f6
+let _topt : keysym = 0x9f7
+let _vertbar : keysym = 0x9f8
+let _emspace : keysym = 0xaa1
+let _enspace : keysym = 0xaa2
+let _em3space : keysym = 0xaa3
+let _em4space : keysym = 0xaa4
+let _digitspace : keysym = 0xaa5
+let _punctspace : keysym = 0xaa6
+let _thinspace : keysym = 0xaa7
+let _hairspace : keysym = 0xaa8
+let _emdash : keysym = 0xaa9
+let _endash : keysym = 0xaaa
+let _signifblank : keysym = 0xaac
+let _ellipsis : keysym = 0xaae
+let _doubbaselinedot : keysym = 0xaaf
+let _onethird : keysym = 0xab0
+let _twothirds : keysym = 0xab1
+let _onefifth : keysym = 0xab2
+let _twofifths : keysym = 0xab3
+let _threefifths : keysym = 0xab4
+let _fourfifths : keysym = 0xab5
+let _onesixth : keysym = 0xab6
+let _fivesixths : keysym = 0xab7
+let _careof : keysym = 0xab8
+let _figdash : keysym = 0xabb
+let _leftanglebracket : keysym = 0xabc
+let _decimalpoint : keysym = 0xabd
+let _rightanglebracket : keysym = 0xabe
+let _marker : keysym = 0xabf
+let _oneeighth : keysym = 0xac3
+let _threeeighths : keysym = 0xac4
+let _fiveeighths : keysym = 0xac5
+let _seveneighths : keysym = 0xac6
+let _trademark : keysym = 0xac9
+let _signaturemark : keysym = 0xaca
+let _trademarkincircle : keysym = 0xacb
+let _leftopentriangle : keysym = 0xacc
+let _rightopentriangle : keysym = 0xacd
+let _emopencircle : keysym = 0xace
+let _emopenrectangle : keysym = 0xacf
+let _leftsinglequotemark : keysym = 0xad0
+let _rightsinglequotemark : keysym = 0xad1
+let _leftdoublequotemark : keysym = 0xad2
+let _rightdoublequotemark : keysym = 0xad3
+let _prescription : keysym = 0xad4
+let _minutes : keysym = 0xad6
+let _seconds : keysym = 0xad7
+let _latincross : keysym = 0xad9
+let _hexagram : keysym = 0xada
+let _filledrectbullet : keysym = 0xadb
+let _filledlefttribullet : keysym = 0xadc
+let _filledrighttribullet : keysym = 0xadd
+let _emfilledcircle : keysym = 0xade
+let _emfilledrect : keysym = 0xadf
+let _enopencircbullet : keysym = 0xae0
+let _enopensquarebullet : keysym = 0xae1
+let _openrectbullet : keysym = 0xae2
+let _opentribulletup : keysym = 0xae3
+let _opentribulletdown : keysym = 0xae4
+let _openstar : keysym = 0xae5
+let _enfilledcircbullet : keysym = 0xae6
+let _enfilledsqbullet : keysym = 0xae7
+let _filledtribulletup : keysym = 0xae8
+let _filledtribulletdown : keysym = 0xae9
+let _leftpointer : keysym = 0xaea
+let _rightpointer : keysym = 0xaeb
+let _club : keysym = 0xaec
+let _diamond : keysym = 0xaed
+let _heart : keysym = 0xaee
+let _maltesecross : keysym = 0xaf0
+let _dagger : keysym = 0xaf1
+let _doubledagger : keysym = 0xaf2
+let _checkmark : keysym = 0xaf3
+let _ballotcross : keysym = 0xaf4
+let _musicalsharp : keysym = 0xaf5
+let _musicalflat : keysym = 0xaf6
+let _malesymbol : keysym = 0xaf7
+let _femalesymbol : keysym = 0xaf8
+let _telephone : keysym = 0xaf9
+let _telephonerecorder : keysym = 0xafa
+let _phonographcopyright : keysym = 0xafb
+let _caret : keysym = 0xafc
+let _singlelowquotemark : keysym = 0xafd
+let _doublelowquotemark : keysym = 0xafe
+let _cursor : keysym = 0xaff
+let _leftcaret : keysym = 0xba3
+let _rightcaret : keysym = 0xba6
+let _downcaret : keysym = 0xba8
+let _upcaret : keysym = 0xba9
+let _overbar : keysym = 0xbc0
+let _downtack : keysym = 0xbc2
+let _upshoe : keysym = 0xbc3
+let _downstile : keysym = 0xbc4
+let _underbar : keysym = 0xbc6
+let _jot : keysym = 0xbca
+let _quad : keysym = 0xbcc
+let _uptack : keysym = 0xbce
+let _circle : keysym = 0xbcf
+let _upstile : keysym = 0xbd3
+let _downshoe : keysym = 0xbd6
+let _rightshoe : keysym = 0xbd8
+let _leftshoe : keysym = 0xbda
+let _lefttack : keysym = 0xbdc
+let _righttack : keysym = 0xbfc
+let _hebrew_doublelowline : keysym = 0xcdf
+let _hebrew_aleph : keysym = 0xce0
+let _hebrew_bet : keysym = 0xce1
+let _hebrew_beth : keysym = 0xce1
+let _hebrew_gimel : keysym = 0xce2
+let _hebrew_gimmel : keysym = 0xce2
+let _hebrew_dalet : keysym = 0xce3
+let _hebrew_daleth : keysym = 0xce3
+let _hebrew_he : keysym = 0xce4
+let _hebrew_waw : keysym = 0xce5
+let _hebrew_zain : keysym = 0xce6
+let _hebrew_zayin : keysym = 0xce6
+let _hebrew_chet : keysym = 0xce7
+let _hebrew_het : keysym = 0xce7
+let _hebrew_tet : keysym = 0xce8
+let _hebrew_teth : keysym = 0xce8
+let _hebrew_yod : keysym = 0xce9
+let _hebrew_finalkaph : keysym = 0xcea
+let _hebrew_kaph : keysym = 0xceb
+let _hebrew_lamed : keysym = 0xcec
+let _hebrew_finalmem : keysym = 0xced
+let _hebrew_mem : keysym = 0xcee
+let _hebrew_finalnun : keysym = 0xcef
+let _hebrew_nun : keysym = 0xcf0
+let _hebrew_samech : keysym = 0xcf1
+let _hebrew_samekh : keysym = 0xcf1
+let _hebrew_ayin : keysym = 0xcf2
+let _hebrew_finalpe : keysym = 0xcf3
+let _hebrew_pe : keysym = 0xcf4
+let _hebrew_finalzade : keysym = 0xcf5
+let _hebrew_finalzadi : keysym = 0xcf5
+let _hebrew_zade : keysym = 0xcf6
+let _hebrew_zadi : keysym = 0xcf6
+let _hebrew_qoph : keysym = 0xcf7
+let _hebrew_kuf : keysym = 0xcf7
+let _hebrew_resh : keysym = 0xcf8
+let _hebrew_shin : keysym = 0xcf9
+let _hebrew_taw : keysym = 0xcfa
+let _hebrew_taf : keysym = 0xcfa
+let _Hebrew_switch : keysym = 0xFF7E
+let _Thai_kokai : keysym = 0xda1
+let _Thai_khokhai : keysym = 0xda2
+let _Thai_khokhuat : keysym = 0xda3
+let _Thai_khokhwai : keysym = 0xda4
+let _Thai_khokhon : keysym = 0xda5
+let _Thai_khorakhang : keysym = 0xda6
+let _Thai_ngongu : keysym = 0xda7
+let _Thai_chochan : keysym = 0xda8
+let _Thai_choching : keysym = 0xda9
+let _Thai_chochang : keysym = 0xdaa
+let _Thai_soso : keysym = 0xdab
+let _Thai_chochoe : keysym = 0xdac
+let _Thai_yoying : keysym = 0xdad
+let _Thai_dochada : keysym = 0xdae
+let _Thai_topatak : keysym = 0xdaf
+let _Thai_thothan : keysym = 0xdb0
+let _Thai_thonangmontho : keysym = 0xdb1
+let _Thai_thophuthao : keysym = 0xdb2
+let _Thai_nonen : keysym = 0xdb3
+let _Thai_dodek : keysym = 0xdb4
+let _Thai_totao : keysym = 0xdb5
+let _Thai_thothung : keysym = 0xdb6
+let _Thai_thothahan : keysym = 0xdb7
+let _Thai_thothong : keysym = 0xdb8
+let _Thai_nonu : keysym = 0xdb9
+let _Thai_bobaimai : keysym = 0xdba
+let _Thai_popla : keysym = 0xdbb
+let _Thai_phophung : keysym = 0xdbc
+let _Thai_fofa : keysym = 0xdbd
+let _Thai_phophan : keysym = 0xdbe
+let _Thai_fofan : keysym = 0xdbf
+let _Thai_phosamphao : keysym = 0xdc0
+let _Thai_moma : keysym = 0xdc1
+let _Thai_yoyak : keysym = 0xdc2
+let _Thai_rorua : keysym = 0xdc3
+let _Thai_ru : keysym = 0xdc4
+let _Thai_loling : keysym = 0xdc5
+let _Thai_lu : keysym = 0xdc6
+let _Thai_wowaen : keysym = 0xdc7
+let _Thai_sosala : keysym = 0xdc8
+let _Thai_sorusi : keysym = 0xdc9
+let _Thai_sosua : keysym = 0xdca
+let _Thai_hohip : keysym = 0xdcb
+let _Thai_lochula : keysym = 0xdcc
+let _Thai_oang : keysym = 0xdcd
+let _Thai_honokhuk : keysym = 0xdce
+let _Thai_paiyannoi : keysym = 0xdcf
+let _Thai_saraa : keysym = 0xdd0
+let _Thai_maihanakat : keysym = 0xdd1
+let _Thai_saraaa : keysym = 0xdd2
+let _Thai_saraam : keysym = 0xdd3
+let _Thai_sarai : keysym = 0xdd4
+let _Thai_saraii : keysym = 0xdd5
+let _Thai_saraue : keysym = 0xdd6
+let _Thai_sarauee : keysym = 0xdd7
+let _Thai_sarau : keysym = 0xdd8
+let _Thai_sarauu : keysym = 0xdd9
+let _Thai_phinthu : keysym = 0xdda
+let _Thai_maihanakat_maitho : keysym = 0xdde
+let _Thai_baht : keysym = 0xddf
+let _Thai_sarae : keysym = 0xde0
+let _Thai_saraae : keysym = 0xde1
+let _Thai_sarao : keysym = 0xde2
+let _Thai_saraaimaimuan : keysym = 0xde3
+let _Thai_saraaimaimalai : keysym = 0xde4
+let _Thai_lakkhangyao : keysym = 0xde5
+let _Thai_maiyamok : keysym = 0xde6
+let _Thai_maitaikhu : keysym = 0xde7
+let _Thai_maiek : keysym = 0xde8
+let _Thai_maitho : keysym = 0xde9
+let _Thai_maitri : keysym = 0xdea
+let _Thai_maichattawa : keysym = 0xdeb
+let _Thai_thanthakhat : keysym = 0xdec
+let _Thai_nikhahit : keysym = 0xded
+let _Thai_leksun : keysym = 0xdf0
+let _Thai_leknung : keysym = 0xdf1
+let _Thai_leksong : keysym = 0xdf2
+let _Thai_leksam : keysym = 0xdf3
+let _Thai_leksi : keysym = 0xdf4
+let _Thai_lekha : keysym = 0xdf5
+let _Thai_lekhok : keysym = 0xdf6
+let _Thai_lekchet : keysym = 0xdf7
+let _Thai_lekpaet : keysym = 0xdf8
+let _Thai_lekkao : keysym = 0xdf9
+let _Hangul : keysym = 0xff31
+let _Hangul_Start : keysym = 0xff32
+let _Hangul_End : keysym = 0xff33
+let _Hangul_Hanja : keysym = 0xff34
+let _Hangul_Jamo : keysym = 0xff35
+let _Hangul_Romaja : keysym = 0xff36
+let _Hangul_Codeinput : keysym = 0xff37
+let _Hangul_Jeonja : keysym = 0xff38
+let _Hangul_Banja : keysym = 0xff39
+let _Hangul_PreHanja : keysym = 0xff3a
+let _Hangul_PostHanja : keysym = 0xff3b
+let _Hangul_SingleCandidate : keysym = 0xff3c
+let _Hangul_MultipleCandidate : keysym = 0xff3d
+let _Hangul_PreviousCandidate : keysym = 0xff3e
+let _Hangul_Special : keysym = 0xff3f
+let _Hangul_switch : keysym = 0xFF7E
+let _Hangul_Kiyeog : keysym = 0xea1
+let _Hangul_SsangKiyeog : keysym = 0xea2
+let _Hangul_KiyeogSios : keysym = 0xea3
+let _Hangul_Nieun : keysym = 0xea4
+let _Hangul_NieunJieuj : keysym = 0xea5
+let _Hangul_NieunHieuh : keysym = 0xea6
+let _Hangul_Dikeud : keysym = 0xea7
+let _Hangul_SsangDikeud : keysym = 0xea8
+let _Hangul_Rieul : keysym = 0xea9
+let _Hangul_RieulKiyeog : keysym = 0xeaa
+let _Hangul_RieulMieum : keysym = 0xeab
+let _Hangul_RieulPieub : keysym = 0xeac
+let _Hangul_RieulSios : keysym = 0xead
+let _Hangul_RieulTieut : keysym = 0xeae
+let _Hangul_RieulPhieuf : keysym = 0xeaf
+let _Hangul_RieulHieuh : keysym = 0xeb0
+let _Hangul_Mieum : keysym = 0xeb1
+let _Hangul_Pieub : keysym = 0xeb2
+let _Hangul_SsangPieub : keysym = 0xeb3
+let _Hangul_PieubSios : keysym = 0xeb4
+let _Hangul_Sios : keysym = 0xeb5
+let _Hangul_SsangSios : keysym = 0xeb6
+let _Hangul_Ieung : keysym = 0xeb7
+let _Hangul_Jieuj : keysym = 0xeb8
+let _Hangul_SsangJieuj : keysym = 0xeb9
+let _Hangul_Cieuc : keysym = 0xeba
+let _Hangul_Khieuq : keysym = 0xebb
+let _Hangul_Tieut : keysym = 0xebc
+let _Hangul_Phieuf : keysym = 0xebd
+let _Hangul_Hieuh : keysym = 0xebe
+let _Hangul_A : keysym = 0xebf
+let _Hangul_AE : keysym = 0xec0
+let _Hangul_YA : keysym = 0xec1
+let _Hangul_YAE : keysym = 0xec2
+let _Hangul_EO : keysym = 0xec3
+let _Hangul_E : keysym = 0xec4
+let _Hangul_YEO : keysym = 0xec5
+let _Hangul_YE : keysym = 0xec6
+let _Hangul_O : keysym = 0xec7
+let _Hangul_WA : keysym = 0xec8
+let _Hangul_WAE : keysym = 0xec9
+let _Hangul_OE : keysym = 0xeca
+let _Hangul_YO : keysym = 0xecb
+let _Hangul_U : keysym = 0xecc
+let _Hangul_WEO : keysym = 0xecd
+let _Hangul_WE : keysym = 0xece
+let _Hangul_WI : keysym = 0xecf
+let _Hangul_YU : keysym = 0xed0
+let _Hangul_EU : keysym = 0xed1
+let _Hangul_YI : keysym = 0xed2
+let _Hangul_I : keysym = 0xed3
+let _Hangul_J_Kiyeog : keysym = 0xed4
+let _Hangul_J_SsangKiyeog : keysym = 0xed5
+let _Hangul_J_KiyeogSios : keysym = 0xed6
+let _Hangul_J_Nieun : keysym = 0xed7
+let _Hangul_J_NieunJieuj : keysym = 0xed8
+let _Hangul_J_NieunHieuh : keysym = 0xed9
+let _Hangul_J_Dikeud : keysym = 0xeda
+let _Hangul_J_Rieul : keysym = 0xedb
+let _Hangul_J_RieulKiyeog : keysym = 0xedc
+let _Hangul_J_RieulMieum : keysym = 0xedd
+let _Hangul_J_RieulPieub : keysym = 0xede
+let _Hangul_J_RieulSios : keysym = 0xedf
+let _Hangul_J_RieulTieut : keysym = 0xee0
+let _Hangul_J_RieulPhieuf : keysym = 0xee1
+let _Hangul_J_RieulHieuh : keysym = 0xee2
+let _Hangul_J_Mieum : keysym = 0xee3
+let _Hangul_J_Pieub : keysym = 0xee4
+let _Hangul_J_PieubSios : keysym = 0xee5
+let _Hangul_J_Sios : keysym = 0xee6
+let _Hangul_J_SsangSios : keysym = 0xee7
+let _Hangul_J_Ieung : keysym = 0xee8
+let _Hangul_J_Jieuj : keysym = 0xee9
+let _Hangul_J_Cieuc : keysym = 0xeea
+let _Hangul_J_Khieuq : keysym = 0xeeb
+let _Hangul_J_Tieut : keysym = 0xeec
+let _Hangul_J_Phieuf : keysym = 0xeed
+let _Hangul_J_Hieuh : keysym = 0xeee
+let _Hangul_RieulYeorinHieuh : keysym = 0xeef
+let _Hangul_SunkyeongeumMieum : keysym = 0xef0
+let _Hangul_SunkyeongeumPieub : keysym = 0xef1
+let _Hangul_PanSios : keysym = 0xef2
+let _Hangul_KkogjiDalrinIeung : keysym = 0xef3
+let _Hangul_SunkyeongeumPhieuf : keysym = 0xef4
+let _Hangul_YeorinHieuh : keysym = 0xef5
+let _Hangul_AraeA : keysym = 0xef6
+let _Hangul_AraeAE : keysym = 0xef7
+let _Hangul_J_PanSios : keysym = 0xef8
+let _Hangul_J_KkogjiDalrinIeung : keysym = 0xef9
+let _Hangul_J_YeorinHieuh : keysym = 0xefa
+let _Korean_Won : keysym = 0xeff
--- /dev/null
+(* $Id$ *)
+
+type gdkEventType = "GDK_"
+ [ `NOTHING | `DELETE | `DESTROY | `EXPOSE | `MOTION_NOTIFY | `BUTTON_PRESS
+ | `TWO_BUTTON_PRESS "GDK_2BUTTON_PRESS"
+ | `THREE_BUTTON_PRESS "GDK_3BUTTON_PRESS"
+ | `BUTTON_RELEASE | `KEY_PRESS
+ | `KEY_RELEASE | `ENTER_NOTIFY | `LEAVE_NOTIFY | `FOCUS_CHANGE
+ | `CONFIGURE | `MAP | `UNMAP | `PROPERTY_NOTIFY | `SELECTION_CLEAR
+ | `SELECTION_REQUEST | `SELECTION_NOTIFY | `PROXIMITY_IN
+ | `PROXIMITY_OUT
+ | `DRAG_ENTER | `DRAG_LEAVE | `DRAG_MOTION | `DRAG_STATUS
+ | `DROP_START | `DROP_FINISHED | `CLIENT_EVENT | `VISIBILITY_NOTIFY
+ | `NO_EXPOSE ]
+
+type event_mask = "GDK_"
+ [ `EXPOSURE
+ | `POINTER_MOTION | `POINTER_MOTION_HINT
+ | `BUTTON_MOTION | `BUTTON1_MOTION | `BUTTON2_MOTION | `BUTTON3_MOTION
+ | `BUTTON_PRESS | `BUTTON_RELEASE
+ | `KEY_PRESS | `KEY_RELEASE
+ | `ENTER_NOTIFY | `LEAVE_NOTIFY | `FOCUS_CHANGE
+ | `STRUCTURE | `PROPERTY_CHANGE | `VISIBILITY_NOTIFY
+ | `PROXIMITY_IN | `PROXIMITY_OUT | `SUBSTRUCTURE
+ | `ALL_EVENTS ] "_MASK"
+
+type extension_events = "GDK_EXTENSION_EVENTS_"
+ [ `NONE | `ALL | `CURSOR ]
+
+type gdkVisibilityState = "GDK_VISIBILITY_"
+ [ `UNOBSCURED | `PARTIAL | `FULLY_OBSCURED ]
+
+type gdkInputSource = "GDK_SOURCE_"
+ [ `MOUSE | `PEN | `ERASER | `CURSOR ]
+
+type gdkCrossingMode = "GDK_CROSSING_"
+ [ `NORMAL | `GRAB | `UNGRAB ]
+
+type gdkNotifyType = "GDK_NOTIFY_"
+ [ `ANCESTOR | `VIRTUAL | `INFERIOR | `NONLINEAR | `NONLINEAR_VIRTUAL
+ | `UNKNOWN ]
+
+type gdkFillRule = "GDK_"
+ [ `EVEN_ODD_RULE | `WINDING_RULE ]
+
+type gdkOverlapType = "GDK_OVERLAP_RECTANGLE_"
+ [ `IN | `OUT | `PART ]
+
+type gdkFunction = "GDK_"
+ [ `COPY | `INVERT | `XOR ]
+
+type gdkFill = "GDK_"
+ [ `SOLID | `TILED | `STIPPLED | `OPAQUE_STIPPLED ]
+
+type gdkSubwindowMode = "GDK_"
+ [ `CLIP_BY_CHILDREN | `INCLUDE_INFERIORS ]
+
+type gdkLineStyle = "GDK_LINE_"
+ [ `SOLID | `ON_OFF_DASH | `DOUBLE_DASH ]
+
+type gdkCapStyle = "GDK_CAP_"
+ [ `NOT_LAST | `BUTT | `ROUND | `PROJECTING ]
+
+type gdkJoinStyle = "GDK_JOIN_"
+ [ `MITER | `ROUND | `BEVEL ]
+
+type gdkModifier = "GDK_"
+ [ `SHIFT | `LOCK | `CONTROL | `MOD1 | `MOD2 | `MOD3 | `MOD4 | `MOD5
+ | `BUTTON1 | `BUTTON2 | `BUTTON3 | `BUTTON4 | `BUTTON5 ] "_MASK"
+
+type gdkImageType = "GDK_IMAGE_"
+ [ `NORMAL | `SHARED | `FASTEST ]
+
+type gdkVisualType = "GDK_VISUAL_"
+ [ `STATIC_GRAY | `GRAYSCALE | `STATIC_COLOR | `PSEUDO_COLOR
+ | `TRUE_COLOR | `DIRECT_COLOR ]
+
+type gdkFontType = "GDK_FONT_"
+ [ `FONT | `FONTSET ]
+
+type gdkDragAction = "GDK_ACTION_"
+ [ `DEFAULT | `COPY | `MOVE | `LINK | `PRIVATE | `ASK ]
+
+type gdkCursorType = "GDK_" [
+ | `NUM_GLYPHS
+ | `X_CURSOR
+ | `ARROW
+ | `BASED_ARROW_DOWN
+ | `BASED_ARROW_UP
+ | `BOAT
+ | `BOGOSITY
+ | `BOTTOM_LEFT_CORNER
+ | `BOTTOM_RIGHT_CORNER
+ | `BOTTOM_SIDE
+ | `BOTTOM_TEE
+ | `BOX_SPIRAL
+ | `CENTER_PTR
+ | `CIRCLE
+ | `CLOCK
+ | `COFFEE_MUG
+ | `CROSS
+ | `CROSS_REVERSE
+ | `CROSSHAIR
+ | `DIAMOND_CROSS
+ | `DOT
+ | `DOTBOX
+ | `DOUBLE_ARROW
+ | `DRAFT_LARGE
+ | `DRAFT_SMALL
+ | `DRAPED_BOX
+ | `EXCHANGE
+ | `FLEUR
+ | `GOBBLER
+ | `GUMBY
+ | `HAND1
+ | `HAND2
+ | `HEART
+ | `ICON
+ | `IRON_CROSS
+ | `LEFT_PTR
+ | `LEFT_SIDE
+ | `LEFT_TEE
+ | `LEFTBUTTON
+ | `LL_ANGLE
+ | `LR_ANGLE
+ | `MAN
+ | `MIDDLEBUTTON
+ | `MOUSE
+ | `PENCIL
+ | `PIRATE
+ | `PLUS
+ | `QUESTION_ARROW
+ | `RIGHT_PTR
+ | `RIGHT_SIDE
+ | `RIGHT_TEE
+ | `RIGHTBUTTON
+ | `RTL_LOGO
+ | `SAILBOAT
+ | `SB_DOWN_ARROW
+ | `SB_H_DOUBLE_ARROW
+ | `SB_LEFT_ARROW
+ | `SB_RIGHT_ARROW
+ | `SB_UP_ARROW
+ | `SB_V_DOUBLE_ARROW
+ | `SHUTTLE
+ | `SIZING
+ | `SPIDER
+ | `SPRAYCAN
+ | `STAR
+ | `TARGET
+ | `TCROSS
+ | `TOP_LEFT_ARROW
+ | `TOP_LEFT_CORNER
+ | `TOP_RIGHT_CORNER
+ | `TOP_SIDE
+ | `TOP_TEE
+ | `TREK
+ | `UL_ANGLE
+ | `UMBRELLA
+ | `UR_ANGLE
+ | `WATCH
+ | `XTERM
+ ]
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+
+type visual_options = [
+ | `USE_GL
+ | `BUFFER_SIZE of int
+ | `LEVEL of int
+ | `RGBA
+ | `DOUBLEBUFFER
+ | `STEREO
+ | `AUX_BUFFERS of int
+ | `RED_SIZE of int
+ | `GREEN_SIZE of int
+ | `BLUE_SIZE of int
+ | `ALPHA_SIZE of int
+ | `DEPTH_SIZE of int
+ | `STENCIL_SIZE of int
+ | `ACCUM_GREEN_SIZE of int
+ | `ACCUM_ALPHA_SIZE of int
+]
+
+type gl_area = [`widget|`drawing|`glarea]
+
+module Raw = struct
+ external create :
+ visual_options list -> share:[>`glarea] optobj -> gl_area obj
+ = "ml_gtk_gl_area_new"
+
+ external swap_buffers : [>`glarea] obj -> unit
+ = "ml_gtk_gl_area_swapbuffers"
+
+ external make_current : [>`glarea] obj -> bool
+ = "ml_gtk_gl_area_make_current"
+end
+
+class area_signals obj =
+object (connect)
+ inherit GObj.widget_signals obj
+ method display ~callback =
+ (new GObj.event_signals ~after obj)#expose ~callback:
+ begin fun ev ->
+ if GdkEvent.Expose.count ev = 0 then
+ if Raw.make_current obj then callback ()
+ else prerr_endline "GlGtk-WARNING **: could not make current";
+ true
+ end
+ method reshape ~callback =
+ (new GObj.event_signals ~after obj)#configure ~callback:
+ begin fun ev ->
+ if Raw.make_current obj then begin
+ callback ~width:(GdkEvent.Configure.width ev)
+ ~height:(GdkEvent.Configure.height ev)
+ end
+ else prerr_endline "GlGtk-WARNING **: could not make current";
+ true
+ end
+ method realize ~callback =
+ let connect = new GObj.misc_signals ~after (GtkBase.Widget.coerce obj) in
+ connect#realize ~callback:
+ begin fun ev ->
+ if Raw.make_current obj then callback ()
+ else prerr_endline "GlGtk-WARNING **: could not make current"
+ end
+end
+
+class area obj = object (self)
+ inherit GObj.widget (obj : gl_area obj)
+ method as_area = obj
+ method event = new GObj.event_ops obj
+ method connect = new area_signals obj
+ method set_size = GtkMisc.DrawingArea.size obj
+ method swap_buffers () = Raw.swap_buffers obj
+ method make_current () =
+ if not (Raw.make_current obj) then
+ raise (Gl.GLerror "make_current")
+end
+
+let area options ?share ?(width=0) ?(height=0) ?packing ?show () =
+ let share =
+ match share with Some (x : area) -> Some x#as_area | None -> None in
+ let w = Raw.create options ~share:(Gpointer.optboxed share) in
+ if width <> 0 || height <> 0 then GtkMisc.DrawingArea.size w ~width ~height;
+ GtkBase.Widget.add_events w [`EXPOSURE];
+ GObj.pack_return (new area w) ~packing ~show
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+type visual_options = [
+ `USE_GL
+ | `BUFFER_SIZE of int
+ | `LEVEL of int
+ | `RGBA
+ | `DOUBLEBUFFER
+ | `STEREO
+ | `AUX_BUFFERS of int
+ | `RED_SIZE of int
+ | `GREEN_SIZE of int
+ | `BLUE_SIZE of int
+ | `ALPHA_SIZE of int
+ | `DEPTH_SIZE of int
+ | `STENCIL_SIZE of int
+ | `ACCUM_GREEN_SIZE of int
+ | `ACCUM_ALPHA_SIZE of int
+]
+type gl_area = [`widget|`drawing|`glarea]
+
+module Raw :
+ sig
+ external create :
+ visual_options list -> share:[>`glarea] optobj -> gl_area obj
+ = "ml_gtk_gl_area_new"
+ external swap_buffers : [>`glarea] obj -> unit
+ = "ml_gtk_gl_area_swapbuffers"
+ external make_current : [>`glarea] obj -> bool
+ = "ml_gtk_gl_area_make_current"
+ end
+
+class area_signals : 'a obj ->
+ object
+ inherit widget_signals
+ constraint 'a = [>`glarea|`widget]
+ val obj : 'a obj
+ method display : callback:(unit -> unit) -> GtkSignal.id
+ method realize : callback:(unit -> unit) -> GtkSignal.id
+ method reshape :
+ callback:(width:int -> height:int -> unit) -> GtkSignal.id
+ end
+
+class area : gl_area obj ->
+ object
+ inherit widget
+ val obj : gl_area obj
+ method event : event_ops
+ method as_area : gl_area obj
+ method connect : area_signals
+ method make_current : unit -> unit
+ method set_size : width:int -> height:int -> unit
+ method swap_buffers : unit -> unit
+ end
+
+val area :
+ visual_options list ->
+ ?share:area ->
+ ?width:int ->
+ ?height:int -> ?packing:(widget -> unit) -> ?show:bool -> unit -> area
--- /dev/null
+(* $Id$ *)
+
+type warning_func = string -> unit
+
+external set_warning_handler : (string -> unit) -> warning_func
+ = "ml_g_set_warning_handler"
+
+type print_func = string -> unit
+
+external set_print_handler : (string -> unit) -> print_func
+ = "ml_g_set_print_handler"
+
+module Main = struct
+ type t
+ external create : bool -> t = "ml_g_main_new"
+ external iteration : bool -> bool = "ml_g_main_iteration"
+ external pending : unit -> bool = "ml_g_main_pending"
+ external is_running : t -> bool = "ml_g_main_is_running"
+ external quit : t -> unit = "ml_g_main_quit"
+ external destroy : t -> unit = "ml_g_main_destroy"
+end
--- /dev/null
+(* $Id$ *)
+
+(* marked pointers *)
+type 'a optaddr
+
+let optaddr : 'a option -> 'a optaddr =
+ function
+ None -> Obj.magic 0
+ | Some x -> Obj.magic x
+
+(* naked pointers *)
+type optstring
+
+external get_null : unit -> optstring = "ml_get_null"
+let raw_null = get_null ()
+
+let optstring : string option -> optstring =
+ function
+ None -> raw_null
+ | Some x -> Obj.magic x
+
+(* boxed pointers *)
+type boxed
+let boxed_null : boxed = Obj.magic (0, raw_null)
+
+type 'a optboxed
+
+let optboxed : 'a option -> 'a optboxed =
+ function
+ None -> Obj.magic boxed_null
+ | Some obj -> Obj.magic obj
+
+let may_box ~f obj : 'a optboxed =
+ match obj with
+ None -> Obj.magic boxed_null
+ | Some obj -> Obj.magic (f obj : 'a)
+
+(* Exceptions *)
+
+exception Null
+let _ = Callback.register_exception "null_pointer" Null
--- /dev/null
+(* $Id$ *)
+
+exception Error of string
+exception Warning of string
+exception Cannot_cast of string * string
+type 'a obj
+type 'a optobj = 'a obj Gpointer.optboxed
+type clampf = float
+
+module Tags = struct
+ type arrow_type = [ `UP|`DOWN|`LEFT|`RIGHT ]
+ type attach_options = [ `EXPAND|`SHRINK|`FILL ]
+ type direction_type = [ `TAB_FORWARD|`TAB_BACKWARD|`UP|`DOWN|`LEFT|`RIGHT ]
+ type justification = [ `LEFT|`RIGHT|`CENTER|`FILL ]
+ type match_type = [ `ALL|`ALL_TAIL|`HEAD|`TAIL|`EXACT|`LAST ]
+ type metric_type = [ `PIXELS|`INCHES|`CENTIMETERS ]
+ type orientation = [ `HORIZONTAL|`VERTICAL ]
+ type corner_type = [ `TOP_LEFT|`BOTTOM_LEFT|`TOP_RIGHT|`BOTTOM_RIGHT ]
+ type pack_type = [ `START|`END ]
+ type path_type = [ `WIDGET|`WIDGET_CLASS|`CLASS ]
+ type policy_type = [ `ALWAYS|`AUTOMATIC|`NEVER ]
+ type position = [ `LEFT|`RIGHT|`TOP|`BOTTOM ]
+ type preview_type = [ `COLOR|`GRAYSCALE ]
+ type relief_style = [ `NORMAL|`HALF|`NONE ]
+ type resize_mode = [ `PARENT|`QUEUE|`IMMEDIATE ]
+ type signal_run_type = [ `FIRST|`LAST|`BOTH|`NO_RECURSE|`ACTION|`NO_HOOKS ]
+ type scroll_type =
+ [ `NONE|`STEP_FORWARD|`STEP_BACKWARD|`PAGE_BACKWARD|`PAGE_FORWARD|`JUMP ]
+ type selection_mode = [ `SINGLE|`BROWSE|`MULTIPLE|`EXTENDED ]
+ type shadow_type = [ `NONE|`IN|`OUT|`ETCHED_IN|`ETCHED_OUT ]
+ type state_type = [ `NORMAL|`ACTIVE|`PRELIGHT|`SELECTED|`INSENSITIVE ]
+ type submenu_direction = [ `LEFT|`RIGHT ]
+ type submenu_placement = [ `TOP_BOTTOM|`LEFT_RIGHT ]
+ type toolbar_style = [ `ICONS|`TEXT|`BOTH ]
+ type trough_type = [ `NONE|`START|`END|`JUMP ]
+ type update_type = [ `CONTINUOUS|`DISCONTINUOUS|`DELAYED ]
+ type visibility = [ `NONE|`PARTIAL|`FULL ]
+ type window_position = [ `NONE|`CENTER|`MOUSE|`CENTER_ALWAYS ]
+ type window_type = [ `TOPLEVEL|`DIALOG|`POPUP ]
+ type sort_type = [ `ASCENDING|`DESCENDING ]
+ type fundamental_type =
+ [ `INVALID|`NONE|`CHAR|`BOOL|`INT|`UINT|`LONG|`ULONG|`FLOAT|`DOUBLE
+ |`STRING|`ENUM|`FLAGS|`BOXED|`FOREIGN|`CALLBACK|`ARGS|`POINTER
+ |`SIGNAL|`C_CALLBACK|`OBJECT ]
+
+ type accel_flag = [ `VISIBLE|`SIGNAL_VISIBLE|`LOCKED ]
+ type button_box_style = [ `DEFAULT_STYLE|`SPREAD|`EDGE|`START|`END ]
+ type expand_type = [ `X|`Y|`BOTH|`NONE ]
+ type packer_options = [ `PACK_EXPAND|`FILL_X|`FILL_Y ]
+ type side_type = [ `TOP|`BOTTOM|`LEFT|`RIGHT ]
+ type anchor_type = [ `CENTER|`NORTH|`NW|`NE|`SOUTH|`SW|`SE|`WEST|`EAST ]
+ type update_policy = [ `ALWAYS|`IF_VALID|`SNAP_TO_TICKS ]
+ type cell_type = [ `EMPTY|`TEXT|`PIXMAP|`PIXTEXT|`WIDGET ]
+ type button_action = [ `SELECTS|`DRAGS|`EXPANDS ]
+ type calendar_display_options =
+ [ `SHOW_HEADING|`SHOW_DAY_NAMES|`NO_MONTH_CHANGE|`SHOW_WEEK_NUMBERS
+ |`WEEK_START_MONDAY ]
+ type spin_button_update_policy = [ `ALWAYS|`IF_VALID ]
+ type spin_type =
+ [ `STEP_FORWARD|`STEP_BACKWARD|`PAGE_FORWARD|`PAGE_BACKWARD
+ |`HOME|`END|`USER_DEFINED of float ]
+ type progress_bar_style = [ `CONTINUOUS|`DISCRETE ]
+ type progress_bar_orientation =
+ [ `LEFT_TO_RIGHT|`RIGHT_TO_LEFT|`BOTTOM_TO_TOP|`TOP_TO_BOTTOM ]
+ type dest_defaults = [ `MOTION|`HIGHLIGHT|`DROP|`ALL ]
+ type target_flags = [ `SAME_APP|`SAME_WIDGET ]
+ type font_metric_type = [ `PIXELS|`POINTS ]
+ type font_type = [ `BITMAP|`SCALABLE|`SCALABLE_BITMAP|`ALL ]
+ type font_filter_type = [ `BASE|`USER ]
+end
+open Tags
+
+type gtk_type
+type gtk_class
+
+type accel_group
+
+type style
+type 'a group = 'a obj option
+
+type statusbar_message
+type statusbar_context
+
+type color = { red: float; green: float; blue: float; opacity: float }
+type rectangle = { x: int; y: int; width: int; height: int }
+type target_entry = { target: string; flags: target_flags list; info: int }
+
+type data = [`data]
+type adjustment = [`data|`adjustment]
+type tooltips = [`data|`tooltips]
+type widget = [`widget]
+type container = [`widget|`container]
+type alignment = [`widget|`container|`bin|`alignment]
+type event_box = [`widget|`container|`bin|`eventbox]
+type frame = [`widget|`container|`bin|`frame]
+type aspect_frame = [`widget|`container|`bin|`frame|`aspect]
+type handle_box = [`widget|`container|`bin|`handlebox]
+type invisible = [`widget|`container|`bin|`invisible]
+type item = [`widget|`container|`bin|`item]
+type list_item = [`widget|`container|`bin|`item|`listitem]
+type menu_item = [`widget|`container|`bin|`item|`menuitem]
+type check_menu_item = [`widget|`container|`bin|`item|`menuitem|`checkmenuitem]
+type radio_menu_item =
+ [`widget|`container|`bin|`item|`menuitem|`checkmenuitem|`radiomenuitem]
+type tree_item = [`widget|`container|`bin|`item|`treeitem]
+type viewport = [`widget|`container|`bin|`viewport]
+type window = [`widget|`container|`bin|`window]
+type color_selection_dialog = [`widget|`container|`window|`colorseldialog]
+type dialog = [`widget|`container|`bin|`window|`dialog]
+type input_dialog = [`widget|`container|`bin|`window|`dialog|`inputdialog]
+type file_selection = [`widget|`container|`bin|`window|`filesel]
+type font_selection_dialog = [`widget|`container|`bin|`window|`fontseldialog]
+type plug = [`widget|`container|`bin|`window|`plug]
+type box = [`widget|`container|`box]
+type button_box = [`widget|`container|`box|`bbox]
+type gamma_curve = [`widget|`container|`bbox|`gamma]
+type color_selection = [`widget|`container|`box|`colorsel]
+type combo = [`widget|`container|`box|`combo]
+type statusbar = [`widget|`container|`box|`statusbar]
+type button = [`widget|`container|`button]
+type toggle_button = [`widget|`container|`button|`toggle]
+type radio_button = [`widget|`container|`button|`toggle|`radio]
+type option_menu = [`widget|`container|`button|`optionmenu]
+type clist = [`widget|`container|`clist]
+type fixed = [`widget|`container|`fixed]
+type layout = [`widget|`container|`layout]
+type liste = [`widget|`container|`list]
+type menu_shell = [`widget|`container|`menushell]
+type menu = [`widget|`container|`menushell|`menu]
+type menu_bar = [`widget|`container|`menushell|`menubar]
+type notebook = [`widget|`container|`notebook]
+type font_selection = [`widget|`container|`notebook|`fontsel]
+type packer = [`widget|`container|`packer]
+type paned = [`widget|`container|`paned]
+type scrolled_window = [`widget|`container|`scrolled]
+type socket = [`widget|`container|`socket]
+type table = [`widget|`container|`table]
+type toolbar = [`widget|`container|`toolbar]
+type tree = [`widget|`container|`tree]
+type calendar = [`widget|`calendar]
+type drawing_area = [`widget|`drawing]
+type editable = [`widget|`editable]
+type entry = [`widget|`editable|`entry]
+type spin_button = [`widget|`editable|`entry|`spinbutton]
+type text = [`widget|`editable|`text]
+type misc = [`widget|`misc]
+type arrow = [`widget|`misc|`arrow]
+type image = [`widget|`misc|`image]
+type label = [`widget|`misc|`label]
+type tips_query = [`widget|`misc|`label|`tipsquery]
+type pixmap = [`widget|`misc|`pixmap]
+type progress = [`widget|`progress]
+type progress_bar = [`widget|`progress|`progressbar]
+type range = [`widget|`range]
+type scale = [`widget|`range|`scale]
+type scrollbar = [`widget|`range|`scrollbar]
+type ruler = [`widget|`ruler]
+type separator = [`widget|`separator]
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+
+type data =
+ | NONE
+ | CHAR of char
+ | BOOL of bool
+ | INT of int
+ | FLOAT of float
+ | STRING of string option
+ | OBJECT of unit obj option
+ | POINTER of Gpointer.boxed option
+
+type 'a result =
+ [ `NONE
+ | `CHAR of char | `BOOL of bool | `INT of int
+ | `UINT of int32 | `LONG of nativeint | `ULONG of nativeint
+ | `FLOAT of float | `DOUBLE of float
+ | `STRING of string option | `ENUM of int | `FLAGS of int32
+ | `BOXED of Gpointer.boxed option
+ | `POINTER of Gpointer.boxed option
+ | `OBJECT of 'a obj option ]
+
+module Arg = struct
+ type t
+ external shift : t -> pos:int -> t = "ml_gtk_arg_shift"
+ external get_type : t -> gtk_type = "ml_gtk_arg_get_type"
+ external get : t -> data = "ml_gtk_arg_get"
+ external set_retloc : t -> 'a result -> unit = "ml_gtk_arg_set_retloc"
+ external get_pointer : t -> Gpointer.boxed = "ml_gtk_arg_get_pointer"
+ external get_nativeint : t -> nativeint = "ml_gtk_arg_get_nativeint"
+
+ (* Safely get an argument *)
+ (*
+ external get_char : t -> char = "ml_gtk_arg_get_char"
+ external get_bool : t -> bool = "ml_gtk_arg_get_bool"
+ external get_int : t -> int = "ml_gtk_arg_get_int"
+ external get_float : t -> float = "ml_gtk_arg_get_float"
+ external get_string : t -> string option = "ml_gtk_arg_get_string"
+ external get_object : t -> unit obj option = "ml_gtk_arg_get_object"
+ *)
+ (* Safely set a result
+ Beware: this is not the opposite of get, arguments and results
+ are two different ways to use GtkArg. *)
+ (*
+ external set_char : t -> char -> unit = "ml_gtk_arg_set_char"
+ external set_bool : t -> bool -> unit = "ml_gtk_arg_set_bool"
+ external set_int : t -> int -> unit = "ml_gtk_arg_set_int"
+ external set_nativeint : t -> nativeint -> unit = "ml_gtk_arg_set_nativeint"
+ external set_float : t -> float -> unit = "ml_gtk_arg_set_float"
+ external set_string : t -> string -> unit = "ml_gtk_arg_set_string"
+ external set_pointer : t -> Gpointer.boxed -> unit = "ml_gtk_arg_set_pointer"
+ external set_object : t -> 'a obj -> unit = "ml_gtk_arg_set_object"
+ *)
+end
+
+open Arg
+type raw_obj
+type t = { referent: raw_obj; nargs: int; args: Arg.t }
+let nth arg ~pos =
+ if pos < 0 || pos >= arg.nargs then invalid_arg "GtkArg.Vect.nth";
+ shift arg.args ~pos
+let result arg =
+ if arg.nargs < 0 then invalid_arg "GtkArgv.result";
+ shift arg.args ~pos:arg.nargs
+external wrap_object : raw_obj -> unit obj = "Val_GtkObject"
+let referent arg =
+ if arg.referent == Obj.magic (-1) then invalid_arg "GtkArgv.referent";
+ wrap_object arg.referent
+let get_result_type arg = get_type (result arg)
+let get_type arg ~pos = get_type (nth arg ~pos)
+let get arg ~pos = get (nth arg ~pos)
+let set_result arg = set_retloc (result arg)
+
+let get_args arg =
+ let rec loop args ~pos =
+ if pos < 0 then args
+ else loop (get arg ~pos :: args) ~pos:(pos-1)
+ in loop [] ~pos:(arg.nargs - 1)
+
+let get_pointer arg ~pos = get_pointer (nth arg ~pos)
+let get_nativeint arg ~pos = get_nativeint (nth arg ~pos)
+
+(*
+let get_char arg ~pos = get_char (nth arg ~pos)
+let get_bool arg ~pos = get_bool (nth arg ~pos)
+let get_int arg ~pos = get_int (nth arg ~pos)
+let get_float arg ~pos = get_float (nth arg ~pos)
+let get_string arg ~pos = get_string (nth arg ~pos)
+let get_object arg ~pos = get_object (nth arg ~pos)
+let set_result_char arg = set_char (result arg)
+let set_result_bool arg = set_bool (result arg)
+let set_result_int arg = set_int (result arg)
+let set_result_nativeint arg = set_nativeint (result arg)
+let set_result_float arg = set_float (result arg)
+let set_result_string arg = set_string (result arg)
+let set_result_pointer arg = set_pointer (result arg)
+let set_result_object arg = set_object (result arg)
+*)
+
+external string_at_pointer : ?pos:int -> ?len:int -> Gpointer.boxed -> string
+ = "ml_string_at_pointer"
+external int_at_pointer : Gpointer.boxed -> int
+ = "ml_int_at_pointer"
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+
+module Type = struct
+ external name : gtk_type -> string = "ml_gtk_type_name"
+ external from_name : string -> gtk_type = "ml_gtk_type_from_name"
+ external parent : gtk_type -> gtk_type = "ml_gtk_type_parent"
+ external get_class : gtk_type -> gtk_class = "ml_gtk_type_class"
+ external parent_class : gtk_type -> gtk_class = "ml_gtk_type_parent_class"
+ external is_a : gtk_type -> gtk_type -> bool = "ml_gtk_type_is_a"
+ external fundamental : gtk_type -> fundamental_type
+ = "ml_gtk_type_fundamental"
+end
+
+module Object = struct
+ external get_type : 'a obj -> gtk_type = "ml_gtk_object_type"
+ let is_a obj name =
+ Type.is_a (get_type obj) (Type.from_name name)
+ external destroy : 'a obj -> unit = "ml_gtk_object_destroy"
+ external coerce : 'a obj -> unit obj = "%identity"
+ external unsafe_cast : 'a obj -> 'b obj = "%identity"
+ let try_cast w name =
+ if is_a w name then unsafe_cast w
+ else raise (Cannot_cast(Type.name(get_type w), name))
+ let get_id (obj : 'a obj) : int = (snd (Obj.magic obj) lor 0)
+ module Signals = struct
+ open GtkSignal
+ let destroy : (_,_) t =
+ { name = "destroy"; marshaller = marshal_unit }
+ end
+end
+
+module Widget = struct
+ let cast w : widget obj = Object.try_cast w "GtkWidget"
+ external coerce : [>`widget] obj -> widget obj = "%identity"
+ external unparent : [>`widget] obj -> unit = "ml_gtk_widget_unparent"
+ external show : [>`widget] obj -> unit = "ml_gtk_widget_show"
+ external show_now : [>`widget] obj -> unit = "ml_gtk_widget_show_now"
+ external show_all : [>`widget] obj -> unit = "ml_gtk_widget_show_all"
+ external hide : [>`widget] obj -> unit = "ml_gtk_widget_hide"
+ external hide_all : [>`widget] obj -> unit = "ml_gtk_widget_hide_all"
+ external map : [>`widget] obj -> unit = "ml_gtk_widget_map"
+ external unmap : [>`widget] obj -> unit = "ml_gtk_widget_unmap"
+ external realize : [>`widget] obj -> unit = "ml_gtk_widget_realize"
+ external unrealize : [>`widget] obj -> unit = "ml_gtk_widget_unrealize"
+ external queue_draw : [>`widget] obj -> unit = "ml_gtk_widget_queue_draw"
+ external queue_resize : [>`widget] obj -> unit = "ml_gtk_widget_queue_resize"
+ external draw : [>`widget] obj -> Gdk.Rectangle.t option -> unit
+ = "ml_gtk_widget_draw"
+ external draw_focus : [>`widget] obj -> unit
+ = "ml_gtk_widget_draw_focus"
+ external draw_default : [>`widget] obj -> unit
+ = "ml_gtk_widget_draw_default"
+ external event : [>`widget] obj -> 'a Gdk.event -> bool
+ = "ml_gtk_widget_event"
+ external activate : [>`widget] obj -> bool
+ = "ml_gtk_widget_activate"
+ external reparent : [>`widget] obj -> [>`widget] obj -> unit
+ = "ml_gtk_widget_reparent"
+ external popup : [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_widget_popup"
+ external intersect :
+ [>`widget] obj -> Gdk.Rectangle.t -> Gdk.Rectangle.t option
+ = "ml_gtk_widget_intersect"
+ external set_can_default : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_can_default"
+ external set_can_focus : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_can_focus"
+ external grab_focus : [>`widget] obj -> unit
+ = "ml_gtk_widget_grab_focus"
+ external grab_default : [>`widget] obj -> unit
+ = "ml_gtk_widget_grab_default"
+ external set_name : [>`widget] obj -> string -> unit
+ = "ml_gtk_widget_set_name"
+ external get_name : [>`widget] obj -> string
+ = "ml_gtk_widget_get_name"
+ external set_state : [>`widget] obj -> state_type -> unit
+ = "ml_gtk_widget_set_state"
+ external set_sensitive : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_sensitive"
+ external set_uposition : [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_widget_set_uposition"
+ external set_usize : [>`widget] obj -> width:int -> height:int -> unit
+ = "ml_gtk_widget_set_usize"
+ external add_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
+ = "ml_gtk_widget_add_events"
+ external set_events : [>`widget] obj -> Gdk.Tags.event_mask list -> unit
+ = "ml_gtk_widget_set_events"
+ external set_extension_events :
+ [>`widget] obj -> Gdk.Tags.extension_events -> unit
+ = "ml_gtk_widget_set_extension_events"
+ external get_toplevel : [>`widget] obj -> widget obj
+ = "ml_gtk_widget_get_toplevel"
+ external get_ancestor : [>`widget] obj -> gtk_type -> widget obj
+ = "ml_gtk_widget_get_ancestor"
+ external get_colormap : [>`widget] obj -> Gdk.colormap
+ = "ml_gtk_widget_get_colormap"
+ external get_visual : [>`widget] obj -> Gdk.visual
+ = "ml_gtk_widget_get_visual"
+ external get_pointer : [>`widget] obj -> int * int
+ = "ml_gtk_widget_get_pointer"
+ external is_ancestor : [>`widget] obj -> [>`widget] obj -> bool
+ = "ml_gtk_widget_is_ancestor"
+ external set_style : [>`widget] obj -> style -> unit
+ = "ml_gtk_widget_set_style"
+ external set_rc_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_set_rc_style"
+ external ensure_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_ensure_style"
+ external get_style : [>`widget] obj -> style
+ = "ml_gtk_widget_get_style"
+ external restore_default_style : [>`widget] obj -> unit
+ = "ml_gtk_widget_restore_default_style"
+ external add_accelerator :
+ ([>`widget] as 'a) obj -> sgn:('a,unit->unit) GtkSignal.t ->
+ accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list ->
+ ?flags:accel_flag list -> unit
+ = "ml_gtk_widget_add_accelerator_bc" "ml_gtk_widget_add_accelerator"
+ external remove_accelerator :
+ [>`widget] obj -> accel_group ->
+ key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> unit
+ = "ml_gtk_widget_remove_accelerator"
+ external lock_accelerators : [>`widget] obj -> unit
+ = "ml_gtk_widget_lock_accelerators"
+ external unlock_accelerators : [>`widget] obj -> unit
+ = "ml_gtk_widget_unlock_accelerators"
+ external accelerators_locked : [>`widget] obj -> bool
+ = "ml_gtk_widget_accelerators_locked"
+ external window : [>`widget] obj -> Gdk.window
+ = "ml_GtkWidget_window"
+ external visible : [>`widget] obj -> bool
+ = "ml_GTK_WIDGET_VISIBLE"
+ external has_focus : [>`widget] obj -> bool
+ = "ml_GTK_WIDGET_HAS_FOCUS"
+ external parent : [>`widget] obj -> widget obj
+ = "ml_gtk_widget_parent"
+ external set_app_paintable : [>`widget] obj -> bool -> unit
+ = "ml_gtk_widget_set_app_paintable"
+ external allocation : [>`widget] obj -> rectangle
+ = "ml_gtk_widget_allocation"
+ external set_colormap : [>`widget] obj -> Gdk.colormap -> unit
+ = "ml_gtk_widget_set_colormap"
+ external set_visual : [>`widget] obj -> Gdk.visual -> unit
+ = "ml_gtk_widget_set_visual"
+ external set_default_colormap : Gdk.colormap -> unit
+ = "ml_gtk_widget_set_default_colormap"
+ external set_default_visual : Gdk.visual -> unit
+ = "ml_gtk_widget_set_default_visual"
+ external get_default_colormap : unit -> Gdk.colormap
+ = "ml_gtk_widget_get_default_colormap"
+ external get_default_visual : unit -> Gdk.visual
+ = "ml_gtk_widget_get_default_visual"
+ external push_colormap : Gdk.colormap -> unit
+ = "ml_gtk_widget_push_colormap"
+ external push_visual : Gdk.visual -> unit
+ = "ml_gtk_widget_push_visual"
+ external pop_colormap : unit -> unit
+ = "ml_gtk_widget_pop_colormap"
+ external pop_visual : unit -> unit
+ = "ml_gtk_widget_pop_visual"
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let marshal f _ = function
+ | OBJECT(Some p) :: _ -> f (cast p)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal"
+ let marshal_opt f _ = function
+ | OBJECT(Some obj) :: _ -> f (Some (cast obj))
+ | OBJECT None :: _ -> f None
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
+ let marshal_style f _ = function
+ | POINTER p :: _ -> f (Obj.magic p : Gtk.style option)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_opt"
+ let marshal_drag1 f _ = function
+ | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.drag_context)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag1"
+ let marshal_drag2 f _ = function
+ | POINTER(Some p) :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context) ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag2"
+ let marshal_drag3 f argv = function
+ | POINTER(Some p) :: INT x :: INT y :: INT time :: _ ->
+ let res = f (Obj.magic p : Gdk.drag_context) ~x ~y ~time
+ in GtkArgv.set_result argv (`BOOL res)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag3"
+ let show : ([>`widget],_) t =
+ { name = "show"; marshaller = marshal_unit }
+ let hide : ([>`widget],_) t =
+ { name = "hide"; marshaller = marshal_unit }
+ let map : ([>`widget],_) t =
+ { name = "map"; marshaller = marshal_unit }
+ let unmap : ([>`widget],_) t =
+ { name = "unmap"; marshaller = marshal_unit }
+ let realize : ([>`widget],_) t =
+ { name = "realize"; marshaller = marshal_unit }
+ let draw : ([>`widget],_) t =
+ let marshal f _ = function
+ | POINTER(Some p) :: _ -> f (Obj.magic p : Gdk.Rectangle.t)
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_draw"
+ in { name = "draw"; marshaller = marshal }
+ let draw_focus : ([>`widget],_) t =
+ { name = "draw_focus"; marshaller = marshal_unit }
+ let draw_default : ([>`widget],_) t =
+ { name = "draw_default"; marshaller = marshal_unit }
+ external val_state : int -> state_type = "ml_Val_state_type"
+ let state_changed : ([>`widget],_) t =
+ let marshal f = marshal_int (fun x -> f (val_state x)) in
+ { name = "state_changed"; marshaller = marshal }
+ let parent_set : ([>`widget],_) t =
+ { name = "parent_set"; marshaller = marshal_opt }
+ let style_set : ([>`widget],_) t =
+ { name = "style_set"; marshaller = marshal_style }
+ let drag_begin : ([>`widget],_) t =
+ { name = "drag_begin"; marshaller = marshal_drag1 }
+ let drag_end : ([>`widget],_) t =
+ { name = "drag_end"; marshaller = marshal_drag1 }
+ let drag_data_delete : ([>`widget],_) t =
+ { name = "drag_data_delete"; marshaller = marshal_drag1 }
+ let drag_leave : ([>`widget],_) t =
+ { name = "drag_leave"; marshaller = marshal_drag2 }
+ let drag_motion : ([>`widget],_) t =
+ { name = "drag_motion"; marshaller = marshal_drag3 }
+ let drag_drop : ([>`widget],_) t =
+ { name = "drag_drop"; marshaller = marshal_drag3 }
+ let drag_data_get : ([>`widget],_) t =
+ let marshal f argv = function
+ | POINTER(Some p) :: POINTER(Some q) :: INT info :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context)
+ (Obj.magic q : GtkData.Selection.t)
+ ~info
+ ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_get"
+ in
+ { name = "drag_data_get"; marshaller = marshal }
+ let drag_data_received : ([>`widget],_) t =
+ let marshal f _ = function
+ | POINTER(Some p) :: INT x :: INT y :: POINTER(Some q) ::
+ INT info :: INT time :: _ ->
+ f (Obj.magic p : Gdk.drag_context) ~x ~y
+ (Obj.magic q : GtkData.Selection.t)
+ ~info ~time
+ | _ -> invalid_arg "GtkBase.Widget.Signals.marshal_drag_data_received"
+ in
+ { name = "drag_data_received"; marshaller = marshal }
+
+ module Event = struct
+ let marshal f argv = function
+ | [POINTER(Some p)] ->
+ let ev = GdkEvent.unsafe_copy p in
+ GtkArgv.set_result argv (`BOOL(f ev))
+ | _ -> invalid_arg "GtkBase.Widget.Event.marshal"
+ let any : ([>`widget], Gdk.Tags.event_type Gdk.event -> bool) t =
+ { name = "event"; marshaller = marshal }
+ let button_press : ([>`widget], GdkEvent.Button.t -> bool) t =
+ { name = "button_press_event"; marshaller = marshal }
+ let button_release : ([>`widget], GdkEvent.Button.t -> bool) t =
+ { name = "button_release_event"; marshaller = marshal }
+ let motion_notify : ([>`widget], GdkEvent.Motion.t -> bool) t =
+ { name = "motion_notify_event"; marshaller = marshal }
+ let delete : ([>`widget], [`DELETE] Gdk.event -> bool) t =
+ { name = "delete_event"; marshaller = marshal }
+ let destroy : ([>`widget], [`DESTROY] Gdk.event -> bool) t =
+ { name = "destroy_event"; marshaller = marshal }
+ let expose : ([>`widget], GdkEvent.Expose.t -> bool) t =
+ { name = "expose_event"; marshaller = marshal }
+ let key_press : ([>`widget], GdkEvent.Key.t -> bool) t =
+ { name = "key_press_event"; marshaller = marshal }
+ let key_release : ([>`widget], GdkEvent.Key.t -> bool) t =
+ { name = "key_release_event"; marshaller = marshal }
+ let enter_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
+ { name = "enter_notify_event"; marshaller = marshal }
+ let leave_notify : ([>`widget], GdkEvent.Crossing.t -> bool) t =
+ { name = "leave_notify_event"; marshaller = marshal }
+ let configure : ([>`widget], GdkEvent.Configure.t -> bool) t =
+ { name = "configure_event"; marshaller = marshal }
+ let focus_in : ([>`widget], GdkEvent.Focus.t -> bool) t =
+ { name = "focus_in_event"; marshaller = marshal }
+ let focus_out : ([>`widget], GdkEvent.Focus.t -> bool) t =
+ { name = "focus_out_event"; marshaller = marshal }
+ let map : ([>`widget], [`MAP] Gdk.event -> bool) t =
+ { name = "map_event"; marshaller = marshal }
+ let unmap : ([>`widget], [`UNMAP] Gdk.event -> bool) t =
+ { name = "unmap_event"; marshaller = marshal }
+ let property_notify : ([>`widget], GdkEvent.Property.t -> bool) t =
+ { name = "property_notify_event"; marshaller = marshal }
+ let selection_clear : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_clear_event"; marshaller = marshal }
+ let selection_request : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_request_event"; marshaller = marshal }
+ let selection_notify : ([>`widget], GdkEvent.Selection.t -> bool) t =
+ { name = "selection_notify_event"; marshaller = marshal }
+ let proximity_in : ([>`widget], GdkEvent.Proximity.t -> bool) t =
+ { name = "proximity_in_event"; marshaller = marshal }
+ let proximity_out : ([>`widget], GdkEvent.Proximity.t -> bool) t =
+ { name = "proximity_out_event"; marshaller = marshal }
+ end
+ end
+end
+
+module Container = struct
+ let cast w : container obj = Object.try_cast w "GtkContainer"
+ external coerce : [>`container] obj -> container obj = "%identity"
+ external set_border_width : [>`container] obj -> int -> unit
+ = "ml_gtk_container_set_border_width"
+ external set_resize_mode : [>`container] obj -> resize_mode -> unit
+ = "ml_gtk_container_set_resize_mode"
+ external add : [>`container] obj -> [>`widget] obj -> unit
+ = "ml_gtk_container_add"
+ external remove : [>`container] obj -> [>`widget] obj -> unit
+ = "ml_gtk_container_remove"
+ let set ?border_width ?(width = -2) ?(height = -2) w =
+ may border_width ~f:(set_border_width w);
+ if width <> -2 || height <> -2 then
+ Widget.set_usize w ?width ?height
+ external foreach : [>`container] obj -> f:(widget obj-> unit) -> unit
+ = "ml_gtk_container_foreach"
+ let children w =
+ let l = ref [] in
+ foreach w ~f:(fun c -> l := c :: !l);
+ List.rev !l
+ external focus : [>`container] obj -> direction_type -> bool
+ = "ml_gtk_container_focus"
+ (* Called by Widget.grab_focus *)
+ external set_focus_child : [>`container] obj -> [>`widget] optobj -> unit
+ = "ml_gtk_container_set_focus_child"
+ external set_focus_vadjustment :
+ [>`container] obj -> [>`adjustment] optobj -> unit
+ = "ml_gtk_container_set_focus_vadjustment"
+ external set_focus_hadjustment :
+ [>`container] obj -> [>`adjustment] optobj -> unit
+ = "ml_gtk_container_set_focus_hadjustment"
+ module Signals = struct
+ open GtkSignal
+ let add : ([>`container],_) t =
+ { name = "add"; marshaller = Widget.Signals.marshal }
+ let remove : ([>`container],_) t =
+ { name = "remove"; marshaller = Widget.Signals.marshal }
+ let need_resize : ([>`container],_) t =
+ let marshal f argv _ = GtkArgv.set_result argv (`BOOL(f ())) in
+ { name = "need_resize"; marshaller = marshal }
+ external val_direction : int -> direction_type = "ml_Val_direction_type"
+ let focus : ([>`container],_) t =
+ let marshal f argv = function
+ | GtkArgv.INT dir :: _ ->
+ GtkArgv.set_result argv (`BOOL(f (val_direction dir)))
+ | _ -> invalid_arg "GtkBase.Container.Signals.marshal_focus"
+ in { name = "focus"; marshaller = marshal }
+ end
+end
+
+module Item = struct
+ let cast w : item obj = Object.try_cast w "GtkItem"
+ external coerce : [>`item] obj -> item obj = "%identity"
+ external select : [>`item] obj -> unit = "ml_gtk_item_select"
+ external deselect : [>`item] obj -> unit = "ml_gtk_item_deselect"
+ external toggle : [>`item] obj -> unit = "ml_gtk_item_toggle"
+ module Signals = struct
+ open GtkSignal
+ let select : ([>`item],_) t =
+ { name = "select"; marshaller = marshal_unit }
+ let deselect : ([>`item],_) t =
+ { name = "deselect"; marshaller = marshal_unit }
+ let toggle : ([>`item],_) t =
+ { name = "toggle"; marshaller = marshal_unit }
+ end
+end
+
+
+module DnD = struct
+ external dest_set :
+ [>`widget] obj -> flags:dest_defaults list ->
+ targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
+ = "ml_gtk_drag_dest_set"
+ external dest_unset : [>`widget] obj -> unit
+ = "ml_gtk_drag_dest_unset"
+ external finish :
+ Gdk.drag_context -> success:bool -> del:bool -> time:int -> unit
+ = "ml_gtk_drag_finish"
+ external get_data :
+ [>`widget] obj -> Gdk.drag_context -> target:Gdk.atom -> time:int -> unit
+ = "ml_gtk_drag_get_data"
+ external get_source_widget : Gdk.drag_context -> widget obj
+ = "ml_gtk_drag_get_source_widget"
+ external highlight : [>`widget] obj -> unit = "ml_gtk_drag_highlight"
+ external unhighlight : [>`widget] obj -> unit = "ml_gtk_drag_unhighlight"
+ external set_icon_widget :
+ Gdk.drag_context -> [>`widget] obj -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_icon_widget"
+ external set_icon_pixmap :
+ Gdk.drag_context -> colormap:Gdk.colormap ->
+ Gdk.pixmap -> ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_icon_pixmap_bc" "ml_gtk_drag_set_icon_pixmap"
+ external set_icon_default : Gdk.drag_context -> unit
+ = "ml_gtk_drag_set_icon_default"
+ external set_default_icon :
+ colormap:Gdk.colormap -> Gdk.pixmap ->
+ ?mask:Gdk.bitmap -> hot_x:int -> hot_y:int -> unit
+ = "ml_gtk_drag_set_default_icon"
+ external source_set :
+ [>`widget] obj -> ?modi:Gdk.Tags.modifier list ->
+ targets:target_entry array -> actions:Gdk.Tags.drag_action list -> unit
+ = "ml_gtk_drag_source_set"
+ external source_set_icon :
+ [>`widget] obj -> colormap:Gdk.colormap ->
+ Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
+ = "ml_gtk_drag_source_set_icon"
+ external source_unset : [>`widget] obj -> unit
+ = "ml_gtk_drag_source_unset"
+(* external dest_handle_event : [>`widget] -> *)
+end
+
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Alignment = struct
+ let cast w : alignment obj = Object.try_cast w "GtkAlignment"
+ external create :
+ x:clampf -> y:clampf -> xscale:clampf -> yscale:clampf -> alignment obj
+ = "ml_gtk_alignment_new"
+ let create ?(x=0.5) ?(y=0.5) ?(xscale=1.) ?(yscale=1.) () =
+ create ~x ~y ~xscale ~yscale
+ external set :
+ ?x:clampf -> ?y:clampf -> ?xscale:clampf -> ?yscale:clampf ->
+ [>`alignment] obj -> unit
+ = "ml_gtk_alignment_set"
+end
+
+module EventBox = struct
+ let cast w : event_box obj = Object.try_cast w "GtkEventBox"
+ external create : unit -> event_box obj = "ml_gtk_event_box_new"
+end
+
+module Frame = struct
+ let cast w : frame obj = Object.try_cast w "GtkFrame"
+ external coerce : [>`frame] obj -> frame obj = "%identity"
+ external create : string -> frame obj = "ml_gtk_frame_new"
+ external set_label : [>`frame] obj -> string -> unit
+ = "ml_gtk_frame_set_label"
+ external set_label_align : [>`frame] obj -> x:clampf -> y:clampf -> unit
+ = "ml_gtk_frame_set_label_align"
+ external set_shadow_type : [>`frame] obj -> shadow_type -> unit
+ = "ml_gtk_frame_set_shadow_type"
+ external get_label_xalign : [>`frame] obj -> float
+ = "ml_gtk_frame_get_label_xalign"
+ external get_label_yalign : [>`frame] obj -> float
+ = "ml_gtk_frame_get_label_yalign"
+ let set_label_align' ?x ?y w =
+ set_label_align w
+ ~x:(may_default get_label_xalign w ~opt:x)
+ ~y:(may_default get_label_yalign w ~opt:y)
+ let set ?label ?label_xalign ?label_yalign ?shadow_type w =
+ may label ~f:(set_label w);
+ if label_xalign <> None || label_yalign <> None then
+ set_label_align' w ?x:label_xalign ?y:label_yalign;
+ may shadow_type ~f:(set_shadow_type w)
+end
+
+module AspectFrame = struct
+ let cast w : aspect_frame obj = Object.try_cast w "GtkAspectFrame"
+ external create :
+ label:string -> xalign:clampf ->
+ yalign:clampf -> ratio:float -> obey_child:bool -> aspect_frame obj
+ = "ml_gtk_aspect_frame_new"
+ let create ?(label="") ?(xalign=0.5) ?(yalign=0.5)
+ ?(ratio=1.0) ?(obey_child=true) () =
+ create ~label ~xalign ~yalign ~ratio ~obey_child
+ external set :
+ [>`aspect] obj ->
+ xalign:clampf -> yalign:clampf -> ratio:float -> obey_child:bool -> unit
+ = "ml_gtk_aspect_frame_set"
+ external get_xalign : [>`aspect] obj -> clampf
+ = "ml_gtk_aspect_frame_get_xalign"
+ external get_yalign : [>`aspect] obj -> clampf
+ = "ml_gtk_aspect_frame_get_yalign"
+ external get_ratio : [>`aspect] obj -> clampf
+ = "ml_gtk_aspect_frame_get_ratio"
+ external get_obey_child : [>`aspect] obj -> bool
+ = "ml_gtk_aspect_frame_get_obey_child"
+ let set ?xalign ?yalign ?ratio ?obey_child w =
+ if xalign <> None || yalign <> None || ratio <> None || obey_child <> None
+ then set w
+ ~xalign:(may_default get_xalign w ~opt:xalign)
+ ~yalign:(may_default get_yalign w ~opt:yalign)
+ ~ratio:(may_default get_ratio w ~opt:ratio)
+ ~obey_child:(may_default get_obey_child w ~opt:obey_child)
+end
+
+module HandleBox = struct
+ let cast w : handle_box obj = Object.try_cast w "GtkHandleBox"
+ external create : unit -> handle_box obj = "ml_gtk_handle_box_new"
+ external set_shadow_type : [>`handlebox] obj -> shadow_type -> unit =
+ "ml_gtk_handle_box_set_shadow_type"
+ external set_handle_position : [>`handlebox] obj -> position -> unit =
+ "ml_gtk_handle_box_set_handle_position"
+ external set_snap_edge : [>`handlebox] obj -> position -> unit =
+ "ml_gtk_handle_box_set_snap_edge"
+ module Signals = struct
+ open GtkSignal
+ let child_attached : ([>`handlebox],_) t =
+ { name = "child_attached"; marshaller = Widget.Signals.marshal }
+ let child_detached : ([>`handlebox],_) t =
+ { name = "child_detached"; marshaller = Widget.Signals.marshal }
+ end
+end
+
+module Viewport = struct
+ let cast w : viewport obj = Object.try_cast w "GtkViewport"
+ external create :
+ [>`adjustment] optobj -> [>`adjustment] optobj -> viewport obj
+ = "ml_gtk_viewport_new"
+ let create ?hadjustment ?vadjustment () =
+ create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
+ external get_hadjustment : [>`viewport] obj -> adjustment obj
+ = "ml_gtk_viewport_get_hadjustment"
+ external get_vadjustment : [>`viewport] obj -> adjustment obj
+ = "ml_gtk_viewport_get_vadjustment"
+ external set_hadjustment : [>`viewport] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_viewport_set_hadjustment"
+ external set_vadjustment : [>`viewport] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_viewport_set_vadjustment"
+ external set_shadow_type : [>`viewport] obj -> shadow_type -> unit
+ = "ml_gtk_viewport_set_shadow_type"
+ let set ?hadjustment ?vadjustment ?shadow_type w =
+ may hadjustment ~f:(set_hadjustment w);
+ may vadjustment ~f:(set_vadjustment w);
+ may shadow_type ~f:(set_shadow_type w)
+end
+
+module ScrolledWindow = struct
+ let cast w : scrolled_window obj = Object.try_cast w "GtkScrolledWindow"
+ external create :
+ [>`adjustment] optobj -> [>`adjustment] optobj -> scrolled_window obj
+ = "ml_gtk_scrolled_window_new"
+ let create ?hadjustment ?vadjustment () =
+ create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
+ external set_hadjustment : [>`scrolled] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_scrolled_window_set_hadjustment"
+ external set_vadjustment : [>`scrolled] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_scrolled_window_set_vadjustment"
+ external get_hadjustment : [>`scrolled] obj -> adjustment obj
+ = "ml_gtk_scrolled_window_get_hadjustment"
+ external get_vadjustment : [>`scrolled] obj -> adjustment obj
+ = "ml_gtk_scrolled_window_get_vadjustment"
+ external set_policy : [>`scrolled] obj -> policy_type -> policy_type -> unit
+ = "ml_gtk_scrolled_window_set_policy"
+ external add_with_viewport : [>`scrolled] obj -> [>`widget] obj -> unit
+ = "ml_gtk_scrolled_window_add_with_viewport"
+ external get_hscrollbar_policy : [>`scrolled] obj -> policy_type
+ = "ml_gtk_scrolled_window_get_hscrollbar_policy"
+ external get_vscrollbar_policy : [>`scrolled] obj -> policy_type
+ = "ml_gtk_scrolled_window_get_vscrollbar_policy"
+ external set_placement : [>`scrolled] obj -> corner_type -> unit
+ = "ml_gtk_scrolled_window_set_placement"
+ let set_policy' ?hpolicy ?vpolicy w =
+ set_policy w
+ (may_default get_hscrollbar_policy w ~opt:hpolicy)
+ (may_default get_vscrollbar_policy w ~opt:vpolicy)
+ let set ?hpolicy ?vpolicy ?placement w =
+ if hpolicy <> None || vpolicy <> None then
+ set_policy' w ?hpolicy ?vpolicy;
+ may placement ~f:(set_placement w)
+end
+
+module Socket = struct
+ let cast w : socket obj = Object.try_cast w "GtkSocket"
+ external coerce : [>`socket] obj -> socket obj = "%identity"
+ external create : unit -> socket obj = "ml_gtk_socket_new"
+ external steal : [>`socket] obj -> Gdk.xid -> unit = "ml_gtk_socket_steal"
+end
+
+(*
+module Invisible = struct
+ let cast w : socket obj = Object.try_cast w "GtkInvisible"
+ external coerce : [>`invisible] obj -> invisible obj = "%identity"
+ external create : unit -> invisible obj = "ml_gtk_invisible_new"
+end
+*)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Button = struct
+ let cast w : button obj = Object.try_cast w "GtkButton"
+ external coerce : [>`button] obj -> button obj = "%identity"
+ external create : unit -> button obj = "ml_gtk_button_new"
+ external create_with_label : string -> button obj
+ = "ml_gtk_button_new_with_label"
+ let create ?label () =
+ match label with None -> create ()
+ | Some x -> create_with_label x
+ external pressed : [>`button] obj -> unit = "ml_gtk_button_pressed"
+ external released : [>`button] obj -> unit = "ml_gtk_button_released"
+ external clicked : [>`button] obj -> unit = "ml_gtk_button_clicked"
+ external enter : [>`button] obj -> unit = "ml_gtk_button_enter"
+ external leave : [>`button] obj -> unit = "ml_gtk_button_leave"
+ module Signals = struct
+ open GtkSignal
+ let pressed : ([>`button],_) t =
+ { name = "pressed"; marshaller = marshal_unit }
+ let released : ([>`button],_) t =
+ { name = "released"; marshaller = marshal_unit }
+ let clicked : ([>`button],_) t =
+ { name = "clicked"; marshaller = marshal_unit }
+ let enter : ([>`button],_) t =
+ { name = "enter"; marshaller = marshal_unit }
+ let leave : ([>`button],_) t =
+ { name = "leave"; marshaller = marshal_unit }
+ end
+end
+
+module ToggleButton = struct
+ let cast w : toggle_button obj = Object.try_cast w "GtkToggleButton"
+ external coerce : [>`toggle] obj -> toggle_button obj = "%identity"
+ external toggle_button_create : unit -> toggle_button obj
+ = "ml_gtk_toggle_button_new"
+ external toggle_button_create_with_label : string -> toggle_button obj
+ = "ml_gtk_toggle_button_new_with_label"
+ external check_button_create : unit -> toggle_button obj
+ = "ml_gtk_check_button_new"
+ external check_button_create_with_label : string -> toggle_button obj
+ = "ml_gtk_check_button_new_with_label"
+ let create_toggle ?label () =
+ match label with None -> toggle_button_create ()
+ | Some label -> toggle_button_create_with_label label
+ let create_check ?label () =
+ match label with None -> check_button_create ()
+ | Some label -> check_button_create_with_label label
+ external set_mode : [>`toggle] obj -> bool -> unit
+ = "ml_gtk_toggle_button_set_mode"
+ external set_active : [>`toggle] obj -> bool -> unit
+ = "ml_gtk_toggle_button_set_active"
+ let set ?active ?draw_indicator w =
+ may ~f:(set_mode w) draw_indicator;
+ may ~f:(set_active w) active
+ external get_active : [>`toggle] obj -> bool
+ = "ml_gtk_toggle_button_get_active"
+ external toggled : [>`toggle] obj -> unit
+ = "ml_gtk_toggle_button_toggled"
+ module Signals = struct
+ open GtkSignal
+ let toggled : ([>`toggle],_) t =
+ { name = "toggled"; marshaller = marshal_unit }
+ end
+end
+
+module RadioButton = struct
+ let cast w : radio_button obj = Object.try_cast w "GtkRadioButton"
+ external create : radio_button group -> radio_button obj
+ = "ml_gtk_radio_button_new"
+ external create_with_label : radio_button group -> string -> radio_button obj
+ = "ml_gtk_radio_button_new_with_label"
+ external set_group : [>`radio] obj -> radio_button group -> unit
+ = "ml_gtk_radio_button_set_group"
+ let create ?(group = None) ?label () =
+ match label with None -> create group
+ | Some label -> create_with_label group label
+end
+
+module Toolbar = struct
+ let cast w : toolbar obj = Object.try_cast w "GtkToolbar"
+ external create : orientation -> style:toolbar_style -> toolbar obj
+ = "ml_gtk_toolbar_new"
+ let create dir ?(style=`BOTH) () = create dir ~style
+ external insert_space : [>`toolbar] obj -> pos:int -> unit
+ = "ml_gtk_toolbar_insert_space"
+ let insert_space w ?(pos = -1) () = insert_space w ~pos
+ external insert_button :
+ [>`toolbar] obj -> kind:[`BUTTON|`TOGGLEBUTTON|`RADIOBUTTON] ->
+ text:string -> tooltip:string ->
+ tooltip_private:string ->
+ icon:[>`widget] optobj -> pos:int -> button obj
+ = "ml_gtk_toolbar_insert_element_bc" "ml_gtk_toolbar_insert_element"
+ let insert_button w ?(kind=`BUTTON) ?(text="") ?(tooltip="")
+ ?(tooltip_private="") ?icon ?(pos = -1) ?callback () =
+ let b =insert_button w ~kind ~text ~tooltip ~tooltip_private ~pos
+ ~icon:(Gpointer.optboxed icon)
+ in
+ match callback with
+ | None -> b
+ | Some c -> GtkSignal.connect b ~sgn:Button.Signals.clicked
+ ~callback: c; b
+ external insert_widget :
+ [>`toolbar] obj -> [>`widget] obj ->
+ tooltip:string -> tooltip_private:string -> pos:int -> unit
+ = "ml_gtk_toolbar_insert_widget"
+ let insert_widget w ?(tooltip="") ?(tooltip_private="") ?(pos = -1) w' =
+ insert_widget w w' ~tooltip ~tooltip_private ~pos
+ external set_orientation : [>`toolbar] obj -> orientation -> unit =
+ "ml_gtk_toolbar_set_orientation"
+ external set_style : [>`toolbar] obj -> toolbar_style -> unit =
+ "ml_gtk_toolbar_set_style"
+ external set_space_size : [>`toolbar] obj -> int -> unit =
+ "ml_gtk_toolbar_set_space_size"
+ external set_space_style : [>`toolbar] obj -> [ `EMPTY|`LINE ] -> unit =
+ "ml_gtk_toolbar_set_space_style"
+ external set_tooltips : [>`toolbar] obj -> bool -> unit =
+ "ml_gtk_toolbar_set_tooltips"
+ external set_button_relief : [>`toolbar] obj -> relief_style -> unit =
+ "ml_gtk_toolbar_set_button_relief"
+ external get_button_relief : [>`toolbar] obj -> relief_style =
+ "ml_gtk_toolbar_get_button_relief"
+ let set ?orientation ?style ?space_size
+ ?space_style ?tooltips ?button_relief w =
+ may orientation ~f:(set_orientation w);
+ may style ~f:(set_style w);
+ may space_size ~f:(set_space_size w);
+ may space_style ~f:(set_space_style w);
+ may tooltips ~f:(set_tooltips w);
+ may button_relief ~f:(set_button_relief w)
+ module Signals = struct
+ open GtkSignal
+ external val_orientation : int -> orientation = "ml_Val_orientation"
+ external val_toolbar_style : int -> toolbar_style
+ = "ml_Val_toolbar_style"
+ let orientation_changed : ([>`toolbar],_) t =
+ let marshal f = marshal_int (fun x -> f (val_orientation x)) in
+ { name = "orientation_changed"; marshaller = marshal }
+ let style_changed : ([>`toolbar],_) t =
+ let marshal f = marshal_int (fun x -> f (val_toolbar_style x)) in
+ { name = "style_changed"; marshaller = marshal }
+ end
+end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+
+module AccelGroup = struct
+ external create : unit -> accel_group = "ml_gtk_accel_group_new"
+ external activate :
+ accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> bool
+ = "ml_gtk_accel_group_activate"
+ external groups_activate :
+ 'a obj -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> bool
+ = "ml_gtk_accel_groups_activate"
+ external attach : accel_group -> 'a obj -> unit
+ = "ml_gtk_accel_group_attach"
+ external detach : accel_group -> 'a obj -> unit
+ = "ml_gtk_accel_group_detach"
+ external lock : accel_group -> unit
+ = "ml_gtk_accel_group_lock"
+ external unlock : accel_group -> unit
+ = "ml_gtk_accel_group_unlock"
+ external lock_entry :
+ accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> bool
+ = "ml_gtk_accel_group_lock_entry"
+ external add :
+ accel_group -> key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list ->
+ ?flags:accel_flag list ->
+ call:'a obj -> sgn:('a,unit->unit) GtkSignal.t -> unit
+ = "ml_gtk_accel_group_add_bc" "ml_gtk_accel_group_add"
+ external remove :
+ accel_group ->
+ key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> call:'a obj -> unit
+ = "ml_gtk_accel_group_remove"
+ external valid : key:Gdk.keysym -> ?modi:Gdk.Tags.modifier list -> bool
+ = "ml_gtk_accelerator_valid"
+ external set_default_mod_mask : Gdk.Tags.modifier list option -> unit
+ = "ml_gtk_accelerator_set_default_mod_mask"
+end
+
+module Style = struct
+ external create : unit -> style = "ml_gtk_style_new"
+ external copy : style -> style = "ml_gtk_style_copy"
+ external attach : style -> Gdk.window -> style = "ml_gtk_style_attach"
+ external detach : style -> unit = "ml_gtk_style_detach"
+ external set_background : style -> Gdk.window -> state_type -> unit
+ = "ml_gtk_style_set_background"
+ external draw_hline :
+ style -> Gdk.window -> state_type -> x:int -> x:int -> y:int -> unit
+ = "ml_gtk_draw_hline_bc" "ml_gtk_draw_hline"
+ external draw_vline :
+ style -> Gdk.window -> state_type -> y:int -> y:int -> x:int -> unit
+ = "ml_gtk_draw_vline_bc" "ml_gtk_draw_vline"
+ external get_bg : style -> state:state_type -> Gdk.Color.t
+ = "ml_gtk_style_get_bg"
+ external set_bg : style -> state:state_type -> color:Gdk.Color.t -> unit
+ = "ml_gtk_style_set_bg"
+ external get_dark_gc : style -> state:state_type -> Gdk.gc
+ = "ml_gtk_style_get_dark_gc"
+ external get_light_gc : style -> state:state_type -> Gdk.gc
+ = "ml_gtk_style_get_light_gc"
+ external get_colormap : style -> Gdk.colormap = "ml_gtk_style_get_colormap"
+ external get_font : style -> Gdk.font = "ml_gtk_style_get_font"
+ external set_font : style -> Gdk.font -> unit = "ml_gtk_style_set_font"
+(*
+ let set st ?:background ?:font =
+ let may_set f = may fun:(f st) in
+ may_set set_background background;
+ may_set set_font font
+*)
+end
+
+module Data = struct
+ module Signals = struct
+ open GtkSignal
+ let disconnect : ([>`data],_) t =
+ { name = "disconnect"; marshaller = marshal_unit }
+ end
+end
+
+module Adjustment = struct
+ external create :
+ value:float -> lower:float -> upper:float ->
+ step_incr:float -> page_incr:float -> page_size:float -> adjustment obj
+ = "ml_gtk_adjustment_new_bc" "ml_gtk_adjustment_new"
+ external set_value : [>`adjustment] obj -> float -> unit
+ = "ml_gtk_adjustment_set_value"
+ external clamp_page :
+ [>`adjustment] obj -> lower:float -> upper:float -> unit
+ = "ml_gtk_adjustment_clamp_page"
+ external get_lower : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_lower"
+ external get_upper : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_upper"
+ external get_value : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_value"
+ external get_step_increment : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_step_increment"
+ external get_page_increment : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_page_increment"
+ external get_page_size : [>`adjustment] obj -> float
+ = "ml_gtk_adjustment_get_page_size"
+ module Signals = struct
+ open GtkSignal
+ let changed : ([>`adjustment],_) t =
+ { name = "changed"; marshaller = marshal_unit }
+ let value_changed : ([>`adjustment],_) t =
+ { name = "value_changed"; marshaller = marshal_unit }
+ end
+end
+
+module Tooltips = struct
+ external create : unit -> tooltips obj = "ml_gtk_tooltips_new"
+ external enable : [>`tooltips] obj -> unit = "ml_gtk_tooltips_enable"
+ external disable : [>`tooltips] obj -> unit = "ml_gtk_tooltips_disable"
+ external set_delay : [>`tooltips] obj -> int -> unit
+ = "ml_gtk_tooltips_set_delay"
+ external set_tip :
+ [>`tooltips] obj ->
+ [>`widget] obj -> ?text:string -> ?privat:string -> unit
+ = "ml_gtk_tooltips_set_tip"
+ external set_colors :
+ [>`tooltips] obj ->
+ ?foreground:Gdk.Color.t -> ?background:Gdk.Color.t -> unit -> unit
+ = "ml_gtk_tooltips_set_colors"
+ let set ?delay ?foreground ?background tt =
+ may ~f:(set_delay tt) delay;
+ if foreground <> None || background <> None then
+ set_colors tt ?foreground ?background ()
+end
+
+
+module Selection = struct
+ type t
+ external selection : t -> Gdk.atom
+ = "ml_gtk_selection_data_selection"
+ external target : t -> Gdk.atom
+ = "ml_gtk_selection_data_target"
+ external seltype : t -> Gdk.atom
+ = "ml_gtk_selection_data_type"
+ external format : t -> int
+ = "ml_gtk_selection_data_format"
+ external get_data : t -> string
+ = "ml_gtk_selection_data_get_data" (* May raise Gpointer.null *)
+ external set :
+ t -> typ:Gdk.atom -> format:int -> ?data:string -> unit
+ = "ml_gtk_selection_data_set"
+end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Editable = struct
+ let cast w : editable obj = Object.try_cast w "GtkEditable"
+ external coerce : [>`editable] obj -> editable obj = "%identity"
+ external select_region : [>`editable] obj -> start:int -> stop:int -> unit
+ = "ml_gtk_editable_select_region"
+ external insert_text : [>`editable] obj -> string -> pos:int -> int
+ = "ml_gtk_editable_insert_text"
+ external delete_text : [>`editable] obj -> start:int -> stop:int -> unit
+ = "ml_gtk_editable_delete_text"
+ external get_chars : [>`editable] obj -> start:int -> stop:int -> string
+ = "ml_gtk_editable_get_chars"
+ external cut_clipboard : [>`editable] obj -> unit
+ = "ml_gtk_editable_cut_clipboard"
+ external copy_clipboard : [>`editable] obj -> unit
+ = "ml_gtk_editable_copy_clipboard"
+ external paste_clipboard : [>`editable] obj -> unit
+ = "ml_gtk_editable_paste_clipboard"
+ external claim_selection :
+ [>`editable] obj -> claim:bool -> time:int -> unit
+ = "ml_gtk_editable_claim_selection"
+ external delete_selection : [>`editable] obj -> unit
+ = "ml_gtk_editable_delete_selection"
+ external changed : [>`editable] obj -> unit = "ml_gtk_editable_changed"
+ external set_position : [>`editable] obj -> int -> unit
+ = "ml_gtk_editable_set_position"
+ external get_position : [>`editable] obj -> int
+ = "ml_gtk_editable_get_position"
+ external set_editable : [>`editable] obj -> bool -> unit
+ = "ml_gtk_editable_set_editable"
+ external selection_start_pos : [>`editable] obj -> int
+ = "ml_gtk_editable_selection_start_pos"
+ external selection_end_pos : [>`editable] obj -> int
+ = "ml_gtk_editable_selection_end_pos"
+ external has_selection : [>`editable] obj -> bool
+ = "ml_gtk_editable_has_selection"
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let activate : ([>`editable],_) t =
+ { name = "activate"; marshaller = marshal_unit }
+ let changed : ([>`editable],_) t =
+ { name = "changed"; marshaller = marshal_unit }
+ let marshal_insert f argv = function
+ | STRING _ :: INT len :: POINTER(Some pos) :: _ ->
+ (* XXX These two accesses are implementation-dependent *)
+ let s = string_at_pointer (get_pointer argv ~pos:0) ~len
+ and pos = int_at_pointer pos in
+ f s ~pos
+ | _ -> invalid_arg "GtkEdit.Editable.Signals.marshal_insert"
+ let insert_text : ([>`editable],_) t =
+ { name = "insert_text"; marshaller = marshal_insert }
+ let marshal_delete f _ = function
+ | INT start :: INT stop :: _ ->
+ f ~start ~stop
+ | _ -> invalid_arg "GtkEdit.Editable.Signals.marshal_delete"
+ let delete_text : ([>`editable],_) t =
+ { name = "delete_text"; marshaller = marshal_delete }
+ end
+end
+
+module Entry = struct
+ let cast w : entry obj = Object.try_cast w "GtkEntry"
+ external coerce : [>`entry] obj -> entry obj = "%identity"
+ external create : unit -> entry obj = "ml_gtk_entry_new"
+ external create_with_max_length : int -> entry obj
+ = "ml_gtk_entry_new_with_max_length"
+ let create ?max_length () =
+ match max_length with None -> create ()
+ | Some len -> create_with_max_length len
+ external set_text : [>`entry] obj -> string -> unit
+ = "ml_gtk_entry_set_text"
+ external append_text : [>`entry] obj -> string -> unit
+ = "ml_gtk_entry_append_text"
+ external prepend_text : [>`entry] obj -> string -> unit
+ = "ml_gtk_entry_prepend_text"
+ external get_text : [>`entry] obj -> string = "ml_gtk_entry_get_text"
+ external set_visibility : [>`entry] obj -> bool -> unit
+ = "ml_gtk_entry_set_visibility"
+ external set_max_length : [>`entry] obj -> int -> unit
+ = "ml_gtk_entry_set_max_length"
+ let set ?text ?visibility ?max_length w =
+ let may_set f = may ~f:(f w) in
+ may_set set_text text;
+ may_set set_visibility visibility;
+ may_set set_max_length max_length
+ external text_length : [>`entry] obj -> int
+ = "ml_GtkEntry_text_length"
+end
+
+module SpinButton = struct
+ let cast w : spin_button obj = Object.try_cast w "GtkSpinButton"
+ external create :
+ [>`adjustment] optobj -> rate:float -> digits:int -> spin_button obj
+ = "ml_gtk_spin_button_new"
+ let create ?adjustment ?(rate=0.5) ?(digits=0) () =
+ create (Gpointer.optboxed adjustment) ~rate ~digits
+ external configure :
+ [>`spinbutton] obj -> adjustment:[>`adjustment] obj ->
+ rate:float -> digits:int -> unit
+ = "ml_gtk_spin_button_configure"
+ external set_adjustment : [>`spinbutton] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_spin_button_set_adjustment"
+ external get_adjustment : [>`spinbutton] obj -> adjustment obj
+ = "ml_gtk_spin_button_get_adjustment"
+ external set_digits : [>`spinbutton] obj -> int -> unit
+ = "ml_gtk_spin_button_set_digits"
+ external get_value : [>`spinbutton] obj -> float
+ = "ml_gtk_spin_button_get_value_as_float"
+ let get_value_as_int w = truncate (get_value w +. 0.5)
+ external set_value : [>`spinbutton] obj -> float -> unit
+ = "ml_gtk_spin_button_set_value"
+ external set_update_policy :
+ [>`spinbutton] obj -> [`ALWAYS|`IF_VALID] -> unit
+ = "ml_gtk_spin_button_set_update_policy"
+ external set_numeric : [>`spinbutton] obj -> bool -> unit
+ = "ml_gtk_spin_button_set_numeric"
+ external spin : [>`spinbutton] obj -> spin_type -> unit
+ = "ml_gtk_spin_button_spin"
+ external set_wrap : [>`spinbutton] obj -> bool -> unit
+ = "ml_gtk_spin_button_set_wrap"
+ external set_shadow_type : [>`spinbutton] obj -> shadow_type -> unit
+ = "ml_gtk_spin_button_set_shadow_type"
+ external set_snap_to_ticks : [>`spinbutton] obj -> bool -> unit
+ = "ml_gtk_spin_button_set_snap_to_ticks"
+ external update : [>`spinbutton] obj -> unit
+ = "ml_gtk_spin_button_update"
+ let set ?adjustment ?digits ?value ?update_policy
+ ?numeric ?wrap ?shadow_type ?snap_to_ticks w =
+ let may_set f = may ~f:(f w) in
+ may_set set_adjustment adjustment;
+ may_set set_digits digits;
+ may_set set_value value;
+ may_set set_update_policy update_policy;
+ may_set set_numeric numeric;
+ may_set set_wrap wrap;
+ may_set set_shadow_type shadow_type;
+ may_set set_snap_to_ticks snap_to_ticks
+end
+
+module Text = struct
+ let cast w : text obj = Object.try_cast w "GtkText"
+ external create : [>`adjustment] optobj -> [>`adjustment] optobj -> text obj
+ = "ml_gtk_text_new"
+ let create ?hadjustment ?vadjustment () =
+ create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
+ external set_word_wrap : [>`text] obj -> bool -> unit
+ = "ml_gtk_text_set_word_wrap"
+ external set_line_wrap : [>`text] obj -> bool -> unit
+ = "ml_gtk_text_set_line_wrap"
+ external set_adjustment :
+ [>`text] obj -> ?horizontal:[>`adjustment] obj ->
+ ?vertical:[>`adjustment] obj -> unit -> unit
+ = "ml_gtk_text_set_adjustments"
+ external get_hadjustment : [>`text] obj -> adjustment obj
+ = "ml_gtk_text_get_hadj"
+ external get_vadjustment : [>`text] obj -> adjustment obj
+ = "ml_gtk_text_get_vadj"
+ external set_point : [>`text] obj -> int -> unit
+ = "ml_gtk_text_set_point"
+ external get_point : [>`text] obj -> int = "ml_gtk_text_get_point"
+ external get_length : [>`text] obj -> int = "ml_gtk_text_get_length"
+ external freeze : [>`text] obj -> unit = "ml_gtk_text_freeze"
+ external thaw : [>`text] obj -> unit = "ml_gtk_text_thaw"
+ external insert :
+ [>`text] obj -> ?font:Gdk.font -> ?foreground:Gdk.Color.t ->
+ ?background:Gdk.Color.t -> string -> unit
+ = "ml_gtk_text_insert"
+ let set ?hadjustment ?vadjustment ?word_wrap w =
+ if hadjustment <> None || vadjustment <> None then
+ set_adjustment w ?horizontal: hadjustment ?vertical: vadjustment ();
+ may word_wrap ~f:(set_word_wrap w)
+end
+
+module Combo = struct
+ let cast w : combo obj = Object.try_cast w "GtkCombo"
+ external create : unit -> combo obj = "ml_gtk_combo_new"
+ external set_value_in_list :
+ [>`combo] obj -> ?required:bool -> ?ok_if_empty:bool -> unit -> unit
+ = "ml_gtk_combo_set_value_in_list"
+ external set_use_arrows : [>`combo] obj -> bool -> unit
+ = "ml_gtk_combo_set_use_arrows"
+ external set_use_arrows_always : [>`combo] obj -> bool -> unit
+ = "ml_gtk_combo_set_use_arrows_always"
+ external set_case_sensitive : [>`combo] obj -> bool -> unit
+ = "ml_gtk_combo_set_case_sensitive"
+ external set_item_string : [>`combo] obj -> [>`item] obj -> string -> unit
+ = "ml_gtk_combo_set_item_string"
+ external entry : [>`combo] obj -> entry obj= "ml_gtk_combo_entry"
+ external list : [>`combo] obj -> liste obj= "ml_gtk_combo_list"
+ let set_popdown_strings combo strings =
+ GtkList.Liste.clear_items (list combo) ~start:0 ~stop:(-1);
+ List.iter strings ~f:
+ begin fun s ->
+ let li = GtkList.ListItem.create_with_label s in
+ Widget.show li;
+ Container.add (list combo) li
+ end
+ let set_use_arrows' w (mode : [`NEVER|`DEFAULT|`ALWAYS]) =
+ let def,always =
+ match mode with
+ `NEVER -> false, false
+ | `DEFAULT -> true, false
+ | `ALWAYS -> true, true
+ in
+ set_use_arrows w def;
+ set_use_arrows_always w always
+ let set ?popdown_strings ?use_arrows
+ ?case_sensitive ?value_in_list ?ok_if_empty w =
+ may popdown_strings ~f:(set_popdown_strings w);
+ may use_arrows ~f:(set_use_arrows' w);
+ may case_sensitive ~f:(set_case_sensitive w);
+ if value_in_list <> None || ok_if_empty <> None then
+ set_value_in_list w ?required:value_in_list ?ok_if_empty ()
+ external disable_activate : [>`combo] obj -> unit
+ = "ml_gtk_combo_disable_activate"
+end
--- /dev/null
+(* $Id$ *)
+
+(* Does the initialization for toplevels *)
+
+let locale = GtkMain.Main.init ()
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module ListItem = struct
+ let cast w : list_item obj = Object.try_cast w "GtkListItem"
+ external create : unit -> list_item obj = "ml_gtk_list_item_new"
+ external create_with_label : string -> list_item obj
+ = "ml_gtk_list_item_new_with_label"
+ let create ?label () =
+ match label with None -> create ()
+ | Some label -> create_with_label label
+end
+
+module Liste = struct
+ let cast w : liste obj = Object.try_cast w "GtkList"
+ external create : unit -> liste obj = "ml_gtk_list_new"
+ external insert_item :
+ [>`list] obj -> [>`listitem] obj -> pos:int -> unit
+ = "ml_gtk_list_insert_item"
+ let insert_items l wl ~pos =
+ let wl = if pos < 0 then wl else List.rev wl in
+ List.iter wl ~f:(insert_item l ~pos)
+ let append_items l = insert_items l ~pos:(-1)
+ let prepend_items l = insert_items l ~pos:0
+ external clear_items : [>`list] obj -> start:int -> stop:int -> unit =
+ "ml_gtk_list_clear_items"
+ external select_item : [>`list] obj -> pos:int -> unit
+ = "ml_gtk_list_select_item"
+ external unselect_item : [>`list] obj -> pos:int -> unit
+ = "ml_gtk_list_unselect_item"
+ external select_child : [>`list] obj -> [>`listitem] obj -> unit
+ = "ml_gtk_list_select_child"
+ external unselect_child : [>`list] obj -> [>`listitem] obj -> unit
+ = "ml_gtk_list_unselect_child"
+ external child_position : [>`list] obj -> [>`listitem] obj -> int
+ = "ml_gtk_list_child_position"
+ external set_selection_mode : [>`list] obj -> selection_mode -> unit
+ = "ml_gtk_list_set_selection_mode"
+ module Signals = struct
+ open GtkSignal
+ let selection_changed : ([>`list],_) t =
+ { name = "selection_changed"; marshaller = marshal_unit }
+ let select_child : ([>`list],_) t =
+ { name = "select_child"; marshaller = Widget.Signals.marshal }
+ let unselect_child : ([>`list],_) t =
+ { name = "unselect_child"; marshaller = Widget.Signals.marshal }
+ end
+end
+
+module CList = struct
+ let cast w : clist obj = Object.try_cast w "GtkCList"
+ external create : cols:int -> clist obj = "ml_gtk_clist_new"
+ external create_with_titles : string array -> clist obj
+ = "ml_gtk_clist_new_with_titles"
+ external get_rows : [>`clist] obj -> int = "ml_gtk_clist_get_rows"
+ external get_columns : [>`clist] obj -> int = "ml_gtk_clist_get_columns"
+ external get_focus_row : [>`clist] obj -> int
+ = "ml_gtk_clist_get_focus_row"
+ external set_hadjustment : [>`clist] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_clist_set_hadjustment"
+ external set_vadjustment : [>`clist] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_clist_set_vadjustment"
+ external get_hadjustment : [>`clist] obj -> adjustment obj
+ = "ml_gtk_clist_get_hadjustment"
+ external get_vadjustment : [>`clist] obj -> adjustment obj
+ = "ml_gtk_clist_get_vadjustment"
+ external set_shadow_type : [>`clist] obj -> shadow_type -> unit
+ = "ml_gtk_clist_set_shadow_type"
+ external set_selection_mode : [>`clist] obj -> selection_mode -> unit
+ = "ml_gtk_clist_set_selection_mode"
+ external set_reorderable : [>`clist] obj -> bool -> unit
+ = "ml_gtk_clist_set_reorderable"
+ external set_use_drag_icons : [>`clist] obj -> bool -> unit
+ = "ml_gtk_clist_set_use_drag_icons"
+ external set_button_actions :
+ [>`clist] obj -> int -> button_action list -> unit
+ = "ml_gtk_clist_set_button_actions"
+ external freeze : [>`clist] obj -> unit = "ml_gtk_clist_freeze"
+ external thaw : [>`clist] obj -> unit = "ml_gtk_clist_thaw"
+ external column_titles_show : [>`clist] obj -> unit
+ = "ml_gtk_clist_column_titles_show"
+ external column_titles_hide : [>`clist] obj -> unit
+ = "ml_gtk_clist_column_titles_hide"
+ external column_title_active : [>`clist] obj -> int -> unit
+ = "ml_gtk_clist_column_title_active"
+ external column_title_passive : [>`clist] obj -> int -> unit
+ = "ml_gtk_clist_column_title_passive"
+ external column_titles_active : [>`clist] obj -> unit
+ = "ml_gtk_clist_column_titles_active"
+ external column_titles_passive : [>`clist] obj -> unit
+ = "ml_gtk_clist_column_titles_passive"
+ external set_column_title : [>`clist] obj -> int -> string -> unit
+ = "ml_gtk_clist_set_column_title"
+ external get_column_title : [>`clist] obj -> int -> string
+ = "ml_gtk_clist_get_column_title"
+ external set_column_widget : [>`clist] obj -> int -> [>`widget] obj -> unit
+ = "ml_gtk_clist_set_column_widget"
+ external get_column_widget : [>`clist] obj -> int -> widget obj
+ = "ml_gtk_clist_get_column_widget"
+ external set_column_justification :
+ [>`clist] obj -> int -> justification -> unit
+ = "ml_gtk_clist_set_column_justification"
+ external set_column_visibility : [>`clist] obj -> int -> bool -> unit
+ = "ml_gtk_clist_set_column_visibility"
+ external set_column_resizeable : [>`clist] obj -> int -> bool -> unit
+ = "ml_gtk_clist_set_column_resizeable"
+ external set_column_auto_resize : [>`clist] obj -> int -> bool -> unit
+ = "ml_gtk_clist_set_column_auto_resize"
+ external columns_autosize : [>`clist] obj -> unit
+ = "ml_gtk_clist_columns_autosize"
+ external optimal_column_width : [>`clist] obj -> int -> int
+ = "ml_gtk_clist_optimal_column_width"
+ external set_column_width : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_set_column_width"
+ external set_column_min_width : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_set_column_min_width"
+ external set_column_max_width : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_set_column_max_width"
+ external set_row_height : [>`clist] obj -> int -> unit
+ = "ml_gtk_clist_set_row_height"
+ external moveto :
+ [>`clist] obj ->
+ int -> int -> row_align:clampf -> col_align:clampf -> unit
+ = "ml_gtk_clist_moveto"
+ external row_is_visible : [>`clist] obj -> int -> visibility
+ = "ml_gtk_clist_row_is_visible"
+ external get_cell_type : [>`clist] obj -> int -> int -> cell_type
+ = "ml_gtk_clist_get_cell_type"
+ external set_text : [>`clist] obj -> int -> int -> string -> unit
+ = "ml_gtk_clist_set_text"
+ external get_text : [>`clist] obj -> int -> int -> string
+ = "ml_gtk_clist_get_text"
+ external set_pixmap :
+ [>`clist] obj ->
+ int -> int -> Gdk.pixmap -> Gdk.bitmap Gpointer.optboxed -> unit
+ = "ml_gtk_clist_set_pixmap"
+ external get_pixmap :
+ [>`clist] obj -> int -> int -> Gdk.pixmap option * Gdk.bitmap option
+ = "ml_gtk_clist_get_pixmap"
+ external set_pixtext :
+ [>`clist] obj -> int -> int ->
+ string -> int -> Gdk.pixmap -> Gdk.bitmap Gpointer.optboxed -> unit
+ = "ml_gtk_clist_set_pixtext_bc" "ml_gtk_clist_set_pixtext"
+ external set_foreground :
+ [>`clist] obj -> row:int -> Gdk.Color.t Gpointer.optboxed -> unit
+ = "ml_gtk_clist_set_foreground"
+ external set_background :
+ [>`clist] obj -> row:int -> Gdk.Color.t Gpointer.optboxed -> unit
+ = "ml_gtk_clist_set_background"
+ external get_cell_style : [>`clist] obj -> int -> int -> Gtk.style
+ = "ml_gtk_clist_get_cell_style"
+ external set_cell_style : [>`clist] obj -> int -> int -> Gtk.style -> unit
+ = "ml_gtk_clist_set_cell_style"
+ external get_row_style : [>`clist] obj -> row:int -> Gtk.style
+ = "ml_gtk_clist_get_row_style"
+ external set_row_style : [>`clist] obj -> row:int -> Gtk.style -> unit
+ = "ml_gtk_clist_set_row_style"
+ external set_selectable : [>`clist] obj -> row:int -> bool -> unit
+ = "ml_gtk_clist_set_selectable"
+ external get_selectable : [>`clist] obj -> row:int -> bool
+ = "ml_gtk_clist_get_selectable"
+ external set_shift :
+ [>`clist] obj -> int -> int -> vertical:int -> horizontal:int -> unit
+ = "ml_gtk_clist_set_shift"
+ external insert : [>`clist] obj -> row:int -> Gpointer.optstring array -> int
+ = "ml_gtk_clist_insert"
+ let insert w ~row texts =
+ let len = get_columns w in
+ if List.length texts > len then invalid_arg "CList.insert";
+ let arr = Array.create (get_columns w) None in
+ List.fold_left texts ~init:0
+ ~f:(fun pos text -> arr.(pos) <- text; pos+1);
+ let r = insert w ~row (Array.map ~f:Gpointer.optstring arr) in
+ if r = -1 then invalid_arg "GtkCList::insert";
+ r
+ external remove : [>`clist] obj -> row:int -> unit
+ = "ml_gtk_clist_remove"
+ external set_row_data : [>`clist] obj -> row:int -> Obj.t -> unit
+ = "ml_gtk_clist_set_row_data"
+ external get_row_data : [>`clist] obj -> row:int -> Obj.t
+ = "ml_gtk_clist_get_row_data"
+ external select : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_select_row"
+ external unselect : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_unselect_row"
+ external clear : [>`clist] obj -> unit = "ml_gtk_clist_clear"
+ external get_row_column : [>`clist] obj -> x:int -> y:int -> int * int
+ = "ml_gtk_clist_get_selection_info"
+ external select_all : [>`clist] obj -> unit = "ml_gtk_clist_select_all"
+ external unselect_all : [>`clist] obj -> unit = "ml_gtk_clist_unselect_all"
+ external swap_rows : [>`clist] obj -> int -> int -> unit
+ = "ml_gtk_clist_swap_rows"
+ external row_move : [>`clist] obj -> int -> dst:int -> unit
+ = "ml_gtk_clist_row_move"
+ external set_sort_column : [>`clist] obj -> int -> unit
+ = "ml_gtk_clist_set_sort_column"
+ external set_sort_type : [>`clist] obj -> sort_type -> unit
+ = "ml_gtk_clist_set_sort_type"
+ external sort : [>`clist] obj -> unit
+ = "ml_gtk_clist_sort"
+ external set_auto_sort : [>`clist] obj -> bool -> unit
+ = "ml_gtk_clist_set_auto_sort"
+ let set_titles_show w = function
+ true -> column_titles_show w
+ | false -> column_titles_hide w
+ let set_titles_active w = function
+ true -> column_titles_active w
+ | false -> column_titles_passive w
+ let set ?hadjustment ?vadjustment ?shadow_type
+ ?(button_actions=[]) ?selection_mode ?reorderable
+ ?use_drag_icons ?row_height ?titles_show ?titles_active w =
+ let may_set f param = may param ~f:(f w) in
+ may_set set_hadjustment hadjustment;
+ may_set set_vadjustment vadjustment;
+ may_set set_shadow_type shadow_type;
+ List.iter button_actions ~f:(fun (n,act) -> set_button_actions w n act);
+ may_set set_selection_mode selection_mode;
+ may_set set_reorderable reorderable;
+ may_set set_use_drag_icons use_drag_icons;
+ may_set set_row_height row_height;
+ may_set set_titles_show titles_show;
+ may_set set_titles_active titles_active
+ let set_sort w ?auto ?column ?dir:sort_type () =
+ may auto ~f:(set_auto_sort w);
+ may column ~f:(set_sort_column w);
+ may sort_type ~f:(set_sort_type w)
+ let set_cell w ?text ?pixmap ?mask ?(spacing=0) ?style row col =
+ begin match text, pixmap with
+ | Some text, None ->
+ set_text w row col text
+ | None, Some pm ->
+ set_pixmap w row col pm (Gpointer.optboxed mask)
+ | Some text, Some pm ->
+ set_pixtext w row col text spacing pm (Gpointer.optboxed mask)
+ | _ -> ()
+ end;
+ may style ~f:(set_cell_style w row col)
+ let set_column w ?widget ?title ?title_active ?justification
+ ?visibility ?resizeable ?auto_resize ?width ?min_width ?max_width
+ col =
+ let may_set f param = may param ~f:(f w col) in
+ may_set set_column_widget widget;
+ may_set set_column_title title;
+ may title_active
+ ~f:(fun active -> if active then column_title_active w col
+ else column_title_passive w col);
+ may_set set_column_justification justification;
+ may_set set_column_visibility visibility;
+ may_set set_column_resizeable resizeable;
+ may_set set_column_auto_resize auto_resize;
+ may_set set_column_width width;
+ may_set set_column_min_width min_width;
+ may_set set_column_max_width max_width
+ let set_row w ?foreground ?background ?selectable ?style row =
+ let may_set f = may ~f:(f w ~row) in
+ may_set set_foreground foreground;
+ may_set set_background background;
+ may_set set_selectable selectable;
+ may_set set_row_style style
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let marshal_select f argv = function
+ | INT row :: INT column :: POINTER p :: _ ->
+ let event : GdkEvent.Button.t option =
+ may_map ~f:GdkEvent.unsafe_copy p
+ in
+ f ~row ~column ~event
+ | _ -> invalid_arg "GtkList.CList.Signals.marshal_select"
+ let select_row : ([>`clist],_) t =
+ { name = "select_row"; marshaller = marshal_select }
+ let unselect_row : ([>`clist],_) t =
+ { name = "unselect_row"; marshaller = marshal_select }
+ let click_column : ([>`clist],_) t =
+ { name = "click_column"; marshaller = marshal_int }
+ external val_scroll_type : int -> scroll_type = "ml_Val_scroll_type"
+ let marshal_scroll f argv = function
+ | INT st :: FLOAT (pos : clampf) :: _ ->
+ f (val_scroll_type st) ~pos
+ | _ -> invalid_arg "GtkList.CList.Signals.marshal_scroll"
+ let scroll_horizontal : ([>`clist],_) t =
+ { name = "scroll_horizontal"; marshaller = marshal_scroll }
+ let scroll_vertical : ([>`clist],_) t =
+ { name = "scroll_vertical"; marshaller = marshal_scroll }
+ external emit_scroll :
+ 'a obj -> name:string -> Tags.scroll_type -> pos:clampf -> unit
+ = "ml_gtk_signal_emit_scroll"
+ let emit_scroll = emit ~emitter:emit_scroll
+ end
+end
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+let _ = Callback.register_exception "gtkerror" (Error"")
+
+module Timeout = struct
+ type id
+ external add : ms:int -> callback:(GtkArgv.t -> unit) -> id
+ = "ml_gtk_timeout_add"
+ let add ~ms ~callback =
+ add ~ms ~callback:(fun arg -> GtkArgv.set_result arg (`BOOL(callback ())))
+ external remove : id -> unit = "ml_gtk_timeout_remove"
+end
+
+module Main = struct
+ external init : string array -> string array = "ml_gtk_init"
+ (* external exit : int -> unit = "ml_gtk_exit" *)
+ external set_locale : unit -> string = "ml_gtk_set_locale"
+ (* external main : unit -> unit = "ml_gtk_main" *)
+ let init () =
+ let locale = set_locale () in
+ let argv = init Sys.argv in
+ Array.blit ~src:argv ~dst:Sys.argv ~len:(Array.length argv)
+ ~src_pos:0 ~dst_pos:0;
+ Obj.truncate (Obj.repr Sys.argv) ~len:(Array.length argv);
+ locale
+ open Glib
+ let loops = ref []
+ let main () =
+ let loop = (Main.create true) in
+ loops := loop :: !loops;
+ while Main.is_running loop do Main.iteration true done;
+ loops := List.tl !loops
+ and quit () = Main.quit (List.hd !loops)
+ external get_version : unit -> int * int * int = "ml_gtk_get_version"
+ let version = get_version ()
+
+ let flush = Gdk.X.flush
+end
+
+module Grab = struct
+ external add : [>`widget] obj -> unit = "ml_gtk_grab_add"
+ external remove : [>`widget] obj -> unit = "ml_gtk_grab_remove"
+ external get_current : unit -> widget obj= "ml_gtk_grab_get_current"
+end
+
+let _ = Glib.set_warning_handler (fun msg -> raise (Warning msg))
+let _ = Glib.set_print_handler (fun msg -> print_string msg)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GtkBase
+
+module MenuItem = struct
+ let cast w : menu_item obj = Object.try_cast w "GtkMenuItem"
+ external coerce : [>`menuitem] obj -> menu_item obj = "%identity"
+ external create : unit -> menu_item obj = "ml_gtk_menu_item_new"
+ external create_with_label : string -> menu_item obj
+ = "ml_gtk_menu_item_new_with_label"
+ external tearoff_create : unit -> menu_item obj
+ = "ml_gtk_tearoff_menu_item_new"
+ let create ?label () =
+ match label with None -> create ()
+ | Some label -> create_with_label label
+ external set_submenu : [>`menuitem] obj -> [>`menu] obj -> unit
+ = "ml_gtk_menu_item_set_submenu"
+ external remove_submenu : [>`menuitem] obj -> unit
+ = "ml_gtk_menu_item_remove_submenu"
+ external configure :
+ [>`menuitem] obj -> show_toggle:bool -> show_indicator:bool -> unit
+ = "ml_gtk_menu_item_configure"
+ external activate : [>`menuitem] obj -> unit
+ = "ml_gtk_menu_item_activate"
+ external right_justify : [>`menuitem] obj -> unit
+ = "ml_gtk_menu_item_right_justify"
+ module Signals = struct
+ open GtkSignal
+ let activate : ([>`menuitem],_) t =
+ { name = "activate"; marshaller = marshal_unit }
+ let activate_item : ([>`menuitem],_) t =
+ { name = "activate_item"; marshaller = marshal_unit }
+ end
+end
+
+module CheckMenuItem = struct
+ let cast w : check_menu_item obj = Object.try_cast w "GtkCheckMenuItem"
+ external coerce : [>`checkmenuitem] obj -> check_menu_item obj = "%identity"
+ external create : unit -> check_menu_item obj = "ml_gtk_check_menu_item_new"
+ external create_with_label : string -> check_menu_item obj
+ = "ml_gtk_check_menu_item_new_with_label"
+ let create ?label () =
+ match label with None -> create ()
+ | Some label -> create_with_label label
+ external set_active : [>`checkmenuitem] obj -> bool -> unit
+ = "ml_gtk_check_menu_item_set_active"
+ external get_active : [>`checkmenuitem] obj -> bool
+ = "ml_gtk_check_menu_item_get_active"
+ external set_show_toggle : [>`checkmenuitem] obj -> bool -> unit
+ = "ml_gtk_check_menu_item_set_show_toggle"
+ let set ?active ?show_toggle w =
+ may active ~f:(set_active w);
+ may show_toggle ~f:(set_show_toggle w)
+ external toggled : [>`checkmenuitem] obj -> unit
+ = "ml_gtk_check_menu_item_toggled"
+ module Signals = struct
+ open GtkSignal
+ let toggled : ([>`checkmenuitem],_) t =
+ { name = "toggled"; marshaller = marshal_unit }
+ end
+end
+
+module RadioMenuItem = struct
+ let cast w : radio_menu_item obj = Object.try_cast w "GtkRadioMenuItem"
+ external create : radio_menu_item group -> radio_menu_item obj
+ = "ml_gtk_radio_menu_item_new"
+ external create_with_label :
+ radio_menu_item group -> string -> radio_menu_item obj
+ = "ml_gtk_radio_menu_item_new_with_label"
+ let create ?(group = None) ?label () =
+ match label with None -> create group
+ | Some label -> create_with_label group label
+ external set_group : [>`radiomenuitem] obj -> radio_menu_item group -> unit
+ = "ml_gtk_radio_menu_item_set_group"
+end
+
+module OptionMenu = struct
+ let cast w : option_menu obj = Object.try_cast w "GtkOptionMenu"
+ external create : unit -> option_menu obj = "ml_gtk_option_menu_new"
+ external get_menu : [>`optionmenu] obj -> menu obj
+ = "ml_gtk_option_menu_get_menu"
+ external set_menu : [>`optionmenu] obj -> [>`menu] obj -> unit
+ = "ml_gtk_option_menu_set_menu"
+ external remove_menu : [>`optionmenu] obj -> unit
+ = "ml_gtk_option_menu_remove_menu"
+ external set_history : [>`optionmenu] obj -> int -> unit
+ = "ml_gtk_option_menu_set_history"
+ let set ?menu ?history w =
+ may menu ~f:(set_menu w);
+ may history ~f:(set_history w)
+end
+
+module MenuShell = struct
+ let cast w : menu_shell obj = Object.try_cast w "GtkMenuShell"
+ external coerce : [>`menushell] obj -> menu_shell obj = "%identity"
+ external append : [>`menushell] obj -> [>`widget] obj -> unit
+ = "ml_gtk_menu_shell_append"
+ external prepend : [>`menushell] obj -> [>`widget] obj -> unit
+ = "ml_gtk_menu_shell_prepend"
+ external insert : [>`menushell] obj -> [>`widget] obj -> pos:int -> unit
+ = "ml_gtk_menu_shell_insert"
+ external deactivate : [>`menushell] obj -> unit
+ = "ml_gtk_menu_shell_deactivate"
+ module Signals = struct
+ open GtkSignal
+ let deactivate : ([>`menushell],_) t =
+ { name = "deactivate"; marshaller = marshal_unit }
+ end
+end
+
+module Menu = struct
+ let cast w : menu obj = Object.try_cast w "GtkMenu"
+ external create : unit -> menu obj = "ml_gtk_menu_new"
+ external popup :
+ [>`menu] obj -> [>`menushell] optobj ->
+ [>`menuitem] optobj -> button:int -> time:int -> unit
+ = "ml_gtk_menu_popup"
+ let popup ?parent_menu ?parent_item w =
+ popup w (Gpointer.optboxed parent_menu) (Gpointer.optboxed parent_item)
+ external popdown : [>`menu] obj -> unit = "ml_gtk_menu_popdown"
+ external get_active : [>`menu] obj -> widget obj= "ml_gtk_menu_get_active"
+ external set_active : [>`menu] obj -> int -> unit = "ml_gtk_menu_set_active"
+ external set_accel_group : [>`menu] obj -> accel_group -> unit
+ = "ml_gtk_menu_set_accel_group"
+ external get_accel_group : [>`menu] obj -> accel_group
+ = "ml_gtk_menu_get_accel_group"
+ external ensure_uline_accel_group : [>`menu] obj -> accel_group
+ = "ml_gtk_menu_ensure_uline_accel_group"
+ external attach_to_widget : [>`menu] obj -> [>`widget] obj -> unit
+ = "ml_gtk_menu_attach_to_widget"
+ external get_attach_widget : [>`menu] obj -> widget obj
+ = "ml_gtk_menu_get_attach_widget"
+ external detach : [>`menu] obj -> unit = "ml_gtk_menu_detach"
+ let set ?active ?accel_group w =
+ may active ~f:(set_active w);
+ may accel_group ~f:(set_accel_group w)
+end
+
+module MenuBar = struct
+ let cast w : menu_bar obj = Object.try_cast w "GtkMenuBar"
+ external create : unit -> menu_bar obj = "ml_gtk_menu_bar_new"
+end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module GammaCurve = struct
+ let cast w : gamma_curve obj = Object.try_cast w "GtkGammaCurve"
+ external create : unit -> gamma_curve obj = "ml_gtk_gamma_curve_new"
+ external get_gamma : [>`gamma] obj -> float = "ml_gtk_gamma_curve_get_gamma"
+end
+
+module ColorSelection = struct
+ let cast w : color_selection obj = Object.try_cast w "GtkColorSelection"
+ external create : unit -> color_selection obj = "ml_gtk_color_selection_new"
+ external create_dialog : string -> color_selection_dialog obj
+ = "ml_gtk_color_selection_dialog_new"
+ external set_update_policy : [>`colorsel] obj -> update_type -> unit
+ = "ml_gtk_color_selection_set_update_policy"
+ external set_opacity : [>`colorsel] obj -> bool -> unit
+ = "ml_gtk_color_selection_set_opacity"
+ let set ?update_policy ?opacity w =
+ may update_policy ~f:(set_update_policy w);
+ may opacity ~f:(set_opacity w)
+ external set_color :
+ [>`colorsel] obj ->
+ red:float -> green:float -> blue:float -> ?opacity:float -> unit
+ = "ml_gtk_color_selection_set_color"
+ external get_color : [>`colorsel] obj -> color
+ = "ml_gtk_color_selection_get_color"
+
+ external ok_button : [>`colorseldialog] obj -> button obj =
+ "ml_gtk_color_selection_dialog_ok_button"
+ external cancel_button : [>`colorseldialog] obj -> button obj =
+ "ml_gtk_color_selection_dialog_cancel_button"
+ external help_button : [>`colorseldialog] obj -> button obj =
+ "ml_gtk_color_selection_dialog_help_button"
+ external colorsel : [>`colorseldialog] obj -> color_selection obj =
+ "ml_gtk_color_selection_dialog_colorsel"
+ module Signals = struct
+ open GtkSignal
+ let color_changed : ([>`colorsel],_) t =
+ { name = "color_changed"; marshaller = marshal_unit }
+ end
+end
+
+module Statusbar = struct
+ let cast w : statusbar obj = Object.try_cast w "GtkStatusbar"
+ external create : unit -> statusbar obj = "ml_gtk_statusbar_new"
+ external get_context : [>`statusbar] obj -> string -> statusbar_context
+ = "ml_gtk_statusbar_get_context_id"
+ external push :
+ [>`statusbar] obj ->
+ statusbar_context -> text:string -> statusbar_message
+ = "ml_gtk_statusbar_push"
+ external pop : [>`statusbar] obj -> statusbar_context -> unit
+ = "ml_gtk_statusbar_pop"
+ external remove :
+ [>`statusbar] obj -> statusbar_context -> statusbar_message -> unit
+ = "ml_gtk_statusbar_remove"
+ module Signals = struct
+ open GtkSignal
+ let text_pushed : ([>`statusbar],_) t =
+ let marshal f _ = function
+ | GtkArgv.INT ctx :: GtkArgv.STRING s :: _ ->
+ f (Obj.magic ctx : statusbar_context) s
+ | _ -> invalid_arg "GtkMisc.Statusbar.Signals.marshal_text"
+ in
+ { name = "text_pushed"; marshaller = marshal }
+ end
+end
+
+module Calendar = struct
+ let cast w : calendar obj = Object.try_cast w "GtkCalendar"
+ external create : unit -> calendar obj = "ml_gtk_calendar_new"
+ external select_month : [>`calendar] obj -> month:int -> year:int -> unit
+ = "ml_gtk_calendar_select_month"
+ external select_day : [>`calendar] obj -> int -> unit
+ = "ml_gtk_calendar_select_day"
+ external mark_day : [>`calendar] obj -> int -> unit
+ = "ml_gtk_calendar_mark_day"
+ external unmark_day : [>`calendar] obj -> int -> unit
+ = "ml_gtk_calendar_unmark_day"
+ external clear_marks : [>`calendar] obj -> unit
+ = "ml_gtk_calendar_clear_marks"
+ external display_options :
+ [>`calendar] obj -> Tags.calendar_display_options list -> unit
+ = "ml_gtk_calendar_display_options"
+ external get_date : [>`calendar] obj -> int * int * int
+ = "ml_gtk_calendar_get_date" (* year * month * day *)
+ external freeze : [>`calendar] obj -> unit
+ = "ml_gtk_calendar_freeze"
+ external thaw : [>`calendar] obj -> unit
+ = "ml_gtk_calendar_thaw"
+ module Signals = struct
+ open GtkSignal
+ let month_changed : ([>`calendar],_) t =
+ { name = "month_changed"; marshaller = marshal_unit }
+ let day_selected : ([>`calendar],_) t =
+ { name = "day_selected"; marshaller = marshal_unit }
+ let day_selected_double_click : ([>`calendar],_) t =
+ { name = "day_selected_double_click"; marshaller = marshal_unit }
+ let prev_month : ([>`calendar],_) t =
+ { name = "prev_month"; marshaller = marshal_unit }
+ let next_month : ([>`calendar],_) t =
+ { name = "next_month"; marshaller = marshal_unit }
+ let prev_year : ([>`calendar],_) t =
+ { name = "prev_year"; marshaller = marshal_unit }
+ let next_year : ([>`calendar],_) t =
+ { name = "next_year"; marshaller = marshal_unit }
+ end
+end
+
+module DrawingArea = struct
+ let cast w : drawing_area obj = Object.try_cast w "GtkDrawingArea"
+ external create : unit -> drawing_area obj = "ml_gtk_drawing_area_new"
+ external size : [>`drawing] obj -> width:int -> height:int -> unit
+ = "ml_gtk_drawing_area_size"
+end
+
+(* Does not seem very useful ...
+module Curve = struct
+ type t = [widget drawing curve] obj
+ let cast w : t = Object.try_cast w "GtkCurve"
+ external create : unit -> t = "ml_gtk_curve_new"
+ external reset : [>`curve] obj -> unit = "ml_gtk_curve_reset"
+ external set_gamma : [>`curve] obj -> float -> unit
+ = "ml_gtk_curve_set_gamma"
+ external set_range :
+ [>`curve] obj -> min_x:float -> max_x:float ->
+ min_y:float -> max_y:float -> unit
+ = "ml_gtk_curve_set_gamma"
+end
+*)
+
+module Misc = struct
+ let cast w : misc obj = Object.try_cast w "GtkMisc"
+ external coerce : [>`misc] obj -> misc obj = "%identity"
+ external set_alignment : [>`misc] obj -> x:float -> y:float -> unit
+ = "ml_gtk_misc_set_alignment"
+ external set_padding : [>`misc] obj -> x:int -> y:int -> unit
+ = "ml_gtk_misc_set_padding"
+ external get_xalign : [>`misc] obj -> float = "ml_gtk_misc_get_xalign"
+ external get_yalign : [>`misc] obj -> float = "ml_gtk_misc_get_yalign"
+ external get_xpad : [>`misc] obj -> int = "ml_gtk_misc_get_xpad"
+ external get_ypad : [>`misc] obj -> int = "ml_gtk_misc_get_ypad"
+ let set_alignment w ?x ?y () =
+ set_alignment w ~x:(may_default get_xalign w ~opt:x)
+ ~y:(may_default get_yalign w ~opt:y)
+ let set_padding w ?x ?y () =
+ set_padding w ~x:(may_default get_xpad w ~opt:x)
+ ~y:(may_default get_ypad w ~opt:y)
+ let set ?xalign ?yalign ?xpad ?ypad ?(width = -2) ?(height = -2) w =
+ if xalign <> None || yalign <> None then
+ set_alignment w ?x:xalign ?y:yalign ();
+ if xpad <> None || ypad <> None then
+ set_padding w ?x:xpad ?y:ypad ();
+ if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
+end
+
+module Arrow = struct
+ let cast w : arrow obj = Object.try_cast w "GtkArrow"
+ external create : kind:arrow_type -> shadow:shadow_type -> arrow obj
+ = "ml_gtk_arrow_new"
+ external set : [>`arrow] obj -> kind:arrow_type -> shadow:shadow_type -> unit
+ = "ml_gtk_arrow_set"
+end
+
+module Image = struct
+ let cast w : image obj = Object.try_cast w "GtkImage"
+ external create : Gdk.image -> ?mask:Gdk.bitmap -> image obj
+ = "ml_gtk_image_new"
+ let create ?mask img = create img ?mask
+ external set : [>`image] obj -> Gdk.image -> ?mask:Gdk.bitmap -> unit
+ = "ml_gtk_image_set"
+end
+
+module Label = struct
+ let cast w : label obj = Object.try_cast w "GtkLabel"
+ external coerce : [>`label] obj -> label obj = "%identity"
+ external create : string -> label obj = "ml_gtk_label_new"
+ external set_text : [>`label] obj -> string -> unit = "ml_gtk_label_set_text"
+ external set_justify : [>`label] obj -> justification -> unit
+ = "ml_gtk_label_set_justify"
+ external set_pattern : [>`label] obj -> string -> unit
+ = "ml_gtk_label_set_pattern"
+ external set_line_wrap : [>`label] obj -> bool -> unit
+ = "ml_gtk_label_set_line_wrap"
+ let set ?text ?justify ?line_wrap ?pattern w =
+ may ~f:(set_text w) text;
+ may ~f:(set_justify w) justify;
+ may ~f:(set_line_wrap w) line_wrap;
+ may ~f:(set_pattern w) pattern
+ external get_text : [>`label] obj -> string = "ml_gtk_label_get_label"
+end
+
+module TipsQuery = struct
+ let cast w : tips_query obj = Object.try_cast w "GtkTipsQuery"
+ external create : unit -> tips_query obj = "ml_gtk_tips_query_new"
+ external start : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_start_query"
+ external stop : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_stop_query"
+ external set_caller : [>`tipsquery] obj -> [>`widget] obj -> unit
+ = "ml_gtk_tips_query_set_caller"
+ external set_labels :
+ [>`tipsquery] obj -> inactive:string -> no_tip:string -> unit
+ = "ml_gtk_tips_query_set_labels"
+ external set_emit_always : [>`tipsquery] obj -> bool -> unit
+ = "ml_gtk_tips_query_set_emit_always"
+ external get_caller : [>`tipsquery] obj -> widget obj
+ = "ml_gtk_tips_query_get_caller"
+ external get_label_inactive : [>`tipsquery] obj -> string
+ = "ml_gtk_tips_query_get_label_inactive"
+ external get_label_no_tip : [>`tipsquery] obj -> string
+ = "ml_gtk_tips_query_get_label_no_tip"
+ external get_emit_always : [>`tipsquery] obj -> bool
+ = "ml_gtk_tips_query_get_emit_always"
+ let set_labels ?inactive ?no_tip w =
+ set_labels w
+ ~inactive:(may_default get_label_inactive w ~opt:inactive)
+ ~no_tip:(may_default get_label_no_tip w ~opt:no_tip)
+ let set ?caller ?emit_always ?label_inactive ?label_no_tip w =
+ may caller ~f:(set_caller w);
+ may emit_always ~f:(set_emit_always w);
+ if label_inactive <> None || label_no_tip <> None then
+ set_labels w ?inactive:label_inactive ?no_tip:label_no_tip
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let start_query : ([>`tipsquery],_) t =
+ { name = "start_query"; marshaller = marshal_unit }
+ let stop_query : ([>`tipsquery],_) t =
+ { name = "stop_query"; marshaller = marshal_unit }
+ let widget_entered :
+ ([>`tipsquery],
+ widget obj option ->
+ text:string option -> privat:string option -> unit) t =
+ let marshal f _ = function
+ | OBJECT opt :: STRING text :: STRING privat :: _ ->
+ f (may_map ~f:Widget.cast opt) ~text ~privat
+ | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_entered"
+ in
+ { name = "widget_entered"; marshaller = marshal }
+ let widget_selected :
+ ([>`tipsquery],
+ widget obj option ->
+ text:string option ->
+ privat:string option -> GdkEvent.Button.t option -> bool) t =
+ let marshal f argv = function
+ | OBJECT obj :: STRING text :: STRING privat :: POINTER p :: _ ->
+ let stop =
+ f (may_map ~f:Widget.cast obj) ~text ~privat
+ (may_map ~f:GdkEvent.unsafe_copy p)
+ in set_result argv (`BOOL stop)
+ | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_selected"
+ in
+ { name = "widget_selected"; marshaller = marshal }
+ end
+end
+
+module Pixmap = struct
+ let cast w : pixmap obj = Object.try_cast w "GtkPixmap"
+ external create : Gdk.pixmap -> ?mask:Gdk.bitmap -> pixmap obj
+ = "ml_gtk_pixmap_new"
+ let create ?mask img = create img ?mask
+ external set :
+ [>`pixmap] obj -> ?pixmap:Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
+ = "ml_gtk_pixmap_set"
+ external pixmap : [>`pixmap] obj -> Gdk.pixmap = "ml_GtkPixmap_pixmap"
+ external mask : [>`pixmap] obj -> Gdk.bitmap = "ml_GtkPixmap_mask"
+end
+
+module Separator = struct
+ let cast w : separator obj = Object.try_cast w "GtkSeparator"
+ external hseparator_new : unit -> separator obj = "ml_gtk_hseparator_new"
+ external vseparator_new : unit -> separator obj = "ml_gtk_vseparator_new"
+ let create (dir : Tags.orientation) =
+ if dir = `HORIZONTAL then hseparator_new () else vseparator_new ()
+end
+
+module FontSelection = struct
+ type null_terminated
+ let null_terminated arg : null_terminated =
+ match arg with None -> Obj.magic Gpointer.raw_null
+ | Some l ->
+ let len = List.length l in
+ let arr = Array.create (len + 1) "" in
+ let rec loop i = function
+ [] -> arr.(i) <- Obj.magic Gpointer.raw_null
+ | s::l -> arr.(i) <- s; loop (i+1) l
+ in loop 0 l;
+ Obj.magic (arr : string array)
+ let cast w : font_selection obj =
+ Object.try_cast w "GtkFontSelection"
+ external create : unit -> font_selection obj
+ = "ml_gtk_font_selection_new"
+ external get_font : [>`fontsel] obj -> Gdk.font
+ = "ml_gtk_font_selection_get_font"
+ let get_font w =
+ try Some (get_font w) with Gpointer.Null -> None
+ external get_font_name : [>`fontsel] obj -> string
+ = "ml_gtk_font_selection_get_font_name"
+ let get_font_name w =
+ try Some (get_font_name w) with Gpointer.Null -> None
+ external set_font_name : [>`fontsel] obj -> string -> unit
+ = "ml_gtk_font_selection_set_font_name"
+ external set_filter :
+ [>`fontsel] obj -> font_filter_type -> font_type list ->
+ null_terminated -> null_terminated -> null_terminated ->
+ null_terminated -> null_terminated -> null_terminated -> unit
+ = "ml_gtk_font_selection_set_filter_bc"
+ "ml_gtk_font_selection_set_filter"
+ let set_filter w ?kind:(tl=[`ALL]) ?foundry
+ ?weight ?slant ?setwidth ?spacing ?charset filter =
+ set_filter w filter tl (null_terminated foundry)
+ (null_terminated weight) (null_terminated slant)
+ (null_terminated setwidth) (null_terminated spacing)
+ (null_terminated charset)
+ external get_preview_text : [>`fontsel] obj -> string
+ = "ml_gtk_font_selection_get_preview_text"
+ external set_preview_text : [>`fontsel] obj -> string -> unit
+ = "ml_gtk_font_selection_set_preview_text"
+end
--- /dev/null
+(* $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 *)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Box = struct
+ let cast w : box obj = Object.try_cast w "GtkBox"
+ external coerce : [>`box] obj -> box obj = "%identity"
+ external pack_start :
+ [>`box] obj -> [>`widget] obj ->
+ expand:bool -> fill:bool -> padding:int -> unit
+ = "ml_gtk_box_pack_start"
+ external pack_end :
+ [>`box] obj -> [>`widget] obj ->
+ expand:bool -> fill:bool -> padding:int -> unit
+ = "ml_gtk_box_pack_end"
+ let pack box ?from:( dir = (`START : pack_type))
+ ?(expand=false) ?(fill=true) ?(padding=0) child =
+ (match dir with `START -> pack_start | `END -> pack_end)
+ box child ~expand ~fill ~padding
+ external reorder_child : [>`box] obj -> [>`widget] obj -> pos:int -> unit
+ = "ml_gtk_box_reorder_child"
+ external set_homogeneous : [>`box] obj -> bool -> unit
+ = "ml_gtk_box_set_homogeneous"
+ external set_spacing : [>`box] obj -> int -> unit
+ = "ml_gtk_box_set_spacing"
+ let set ?homogeneous ?spacing w =
+ may homogeneous ~f:(set_homogeneous w);
+ may spacing ~f:(set_spacing w)
+ type packing =
+ { expand: bool; fill: bool; padding: int; pack_type: pack_type }
+ external query_child_packing : [>`box] obj -> [>`widget] obj -> packing
+ = "ml_gtk_box_query_child_packing"
+ external set_child_packing :
+ [>`box] obj -> [>`widget] obj ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> ?from:pack_type -> unit
+ = "ml_gtk_box_set_child_packing_bc" "ml_gtk_box_set_child_packing"
+ external hbox_new : homogeneous:bool -> spacing:int -> box obj
+ = "ml_gtk_hbox_new"
+ external vbox_new : homogeneous:bool -> spacing:int -> box obj
+ = "ml_gtk_vbox_new"
+ let create (dir : orientation) ?(homogeneous=false) ?(spacing=0) () =
+ (match dir with `HORIZONTAL -> hbox_new | `VERTICAL -> vbox_new)
+ ~homogeneous ~spacing
+end
+
+module BBox = struct
+ (* Omitted defaults setting *)
+ let cast w : button_box obj = Object.try_cast w "GtkBBox"
+ external coerce : [>`bbox] obj -> button_box obj = "%identity"
+ type bbox_style = [ `DEFAULT_STYLE|`SPREAD|`EDGE|`START|`END ]
+ external get_spacing : [>`bbox] obj -> int = "ml_gtk_button_box_get_spacing"
+ external get_child_width : [>`bbox] obj -> int
+ = "ml_gtk_button_box_get_child_min_width"
+ external get_child_height : [>`bbox] obj -> int
+ = "ml_gtk_button_box_get_child_min_height"
+ external get_child_ipadx : [>`bbox] obj -> int
+ = "ml_gtk_button_box_get_child_ipad_x"
+ external get_child_ipady : [>`bbox] obj -> int
+ = "ml_gtk_button_box_get_child_ipad_y"
+ external get_layout : [>`bbox] obj -> bbox_style
+ = "ml_gtk_button_box_get_layout_style"
+ external set_spacing : [>`bbox] obj -> int -> unit
+ = "ml_gtk_button_box_set_spacing"
+ external set_child_size : [>`bbox] obj -> width:int -> height:int -> unit
+ = "ml_gtk_button_box_set_child_size"
+ external set_child_ipadding : [>`bbox] obj -> x:int -> y:int -> unit
+ = "ml_gtk_button_box_set_child_ipadding"
+ external set_layout : [>`bbox] obj -> bbox_style -> unit
+ = "ml_gtk_button_box_set_layout"
+ let set_child_size w ?width ?height () =
+ set_child_size w ~width:(may_default get_child_width w ~opt:width)
+ ~height:(may_default get_child_height w ~opt:height)
+ let set_child_ipadding w ?x ?y () =
+ set_child_ipadding w
+ ~x:(may_default get_child_ipadx w ~opt:x)
+ ~y:(may_default get_child_ipady w ~opt:y)
+ let set ?spacing ?child_width ?child_height ?child_ipadx
+ ?child_ipady ?layout w =
+ may spacing ~f:(set_spacing w);
+ if child_width <> None || child_height <> None then
+ set_child_size w ?width:child_width ?height:child_height ();
+ if child_ipadx <> None || child_ipady <> None then
+ set_child_ipadding w ?x:child_ipadx ?y:child_ipady ();
+ may layout ~f:(set_layout w)
+ external set_child_size_default : width:int -> height:int -> unit
+ = "ml_gtk_button_box_set_child_size_default"
+ external set_child_ipadding_default : x:int -> y:int -> unit
+ = "ml_gtk_button_box_set_child_ipadding_default"
+ external create_hbbox : unit -> button_box obj = "ml_gtk_hbutton_box_new"
+ external create_vbbox : unit -> button_box obj = "ml_gtk_vbutton_box_new"
+ let create (dir : orientation) =
+ if dir = `HORIZONTAL then create_hbbox () else create_vbbox ()
+end
+
+module Fixed = struct
+ let cast w : fixed obj = Object.try_cast w "GtkFixed"
+ external create : unit -> fixed obj = "ml_gtk_fixed_new"
+ external put : [>`fixed] obj -> [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_fixed_put"
+ external move : [>`fixed] obj -> [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_fixed_move"
+end
+
+module Layout = struct
+ let cast w : layout obj = Object.try_cast w "GtkLayout"
+ external create :
+ [>`adjustment] optobj -> [>`adjustment] optobj -> layout obj
+ = "ml_gtk_layout_new"
+ external put : [>`layout] obj -> [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_layout_put"
+ external move : [>`layout] obj -> [>`widget] obj -> x:int -> y:int -> unit
+ = "ml_gtk_layout_move"
+ external set_size : [>`layout] obj -> width:int -> height:int -> unit
+ = "ml_gtk_layout_set_size"
+ external get_hadjustment : [>`layout] obj -> adjustment obj
+ = "ml_gtk_layout_get_hadjustment"
+ external get_vadjustment : [>`layout] obj -> adjustment obj
+ = "ml_gtk_layout_get_vadjustment"
+ external set_hadjustment : [>`layout] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_layout_set_hadjustment"
+ external set_vadjustment : [>`layout] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_layout_set_vadjustment"
+ external freeze : [>`layout] obj -> unit
+ = "ml_gtk_layout_freeze"
+ external thaw : [>`layout] obj -> unit
+ = "ml_gtk_layout_thaw"
+ external get_height : [>`layout] obj -> int
+ = "ml_gtk_layout_get_height"
+ external get_width : [>`layout] obj -> int
+ = "ml_gtk_layout_get_width"
+ let set_size ?width ?height w =
+ set_size w ~width:(may_default get_width w ~opt:width)
+ ~height:(may_default get_height w ~opt:height)
+end
+
+
+module Packer = struct
+ let cast w : packer obj = Object.try_cast w "GtkPacker"
+ external create : unit -> packer obj = "ml_gtk_packer_new"
+ external add :
+ [>`packer] obj -> [>`widget] obj ->
+ ?side:side_type -> ?anchor:anchor_type ->
+ ?options:packer_options list ->
+ ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
+ ?i_pad_x:int -> ?i_pad_y:int -> unit
+ = "ml_gtk_packer_add_bc" "ml_gtk_packer_add"
+ external add_defaults :
+ [>`packer] obj -> [>`widget] obj ->
+ ?side:side_type -> ?anchor:anchor_type ->
+ ?options:packer_options list -> unit
+ = "ml_gtk_packer_add_defaults"
+ external set_child_packing :
+ [>`packer] obj -> [>`widget] obj ->
+ ?side:side_type -> ?anchor:anchor_type ->
+ ?options:packer_options list ->
+ ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
+ ?i_pad_x:int -> ?i_pad_y:int -> unit
+ = "ml_gtk_packer_set_child_packing_bc" "ml_gtk_packer_set_child_packing"
+ external reorder_child : [>`packer] obj -> [>`widget] obj -> pos:int -> unit
+ = "ml_gtk_packer_reorder_child"
+ external set_spacing : [>`packer] obj -> int -> unit
+ = "ml_gtk_packer_set_spacing"
+ external set_defaults :
+ [>`packer] obj -> ?border_width:int -> ?pad_x:int -> ?pad_y:int ->
+ ?i_pad_x:int -> ?i_pad_y:int -> unit -> unit
+ = "ml_gtk_packer_set_defaults_bc" "ml_gtk_packer_set_defaults"
+
+ let build_options ?(expand=false) ?(fill=`BOTH) () =
+ (if expand then [`PACK_EXPAND] else []) @
+ (match (fill : expand_type) with `NONE -> []
+ | `X -> [`FILL_X]
+ | `Y -> [`FILL_Y]
+ | `BOTH -> [`FILL_X;`FILL_Y])
+end
+
+module Paned = struct
+ let cast w : paned obj = Object.try_cast w "GtkPaned"
+ external add1 : [>`paned] obj -> [>`widget] obj -> unit
+ = "ml_gtk_paned_add1"
+ external add2 : [>`paned] obj -> [>`widget] obj -> unit
+ = "ml_gtk_paned_add2"
+ external set_handle_size : [>`paned] obj -> int -> unit
+ = "ml_gtk_paned_set_handle_size"
+ external set_gutter_size : [>`paned] obj -> int -> unit
+ = "ml_gtk_paned_set_gutter_size"
+ let set ?handle_size ?gutter_size w =
+ may ~f:(set_handle_size w) handle_size;
+ may ~f:(set_gutter_size w) gutter_size
+ external child1 : [>`paned] obj -> widget obj = "ml_gtk_paned_child1"
+ external child2 : [>`paned] obj -> widget obj = "ml_gtk_paned_child2"
+ external handle_size : [>`paned] obj -> int = "ml_gtk_paned_handle_size"
+ external gutter_size : [>`paned] obj -> int = "ml_gtk_paned_handle_size"
+ external hpaned_new : unit -> paned obj = "ml_gtk_hpaned_new"
+ external vpaned_new : unit -> paned obj = "ml_gtk_vpaned_new"
+ let create (dir : orientation) =
+ if dir = `HORIZONTAL then hpaned_new () else vpaned_new ()
+end
+
+module Table = struct
+ let cast w : table obj = Object.try_cast w "GtkTable"
+ external create : int -> int -> homogeneous:bool -> table obj
+ = "ml_gtk_table_new"
+ let create ~rows:r ~columns:c ?(homogeneous=false) () =
+ create r c ~homogeneous
+ external attach :
+ [>`table] obj -> [>`widget] obj -> left:int -> right:int ->
+ top:int -> bottom:int -> xoptions:attach_options list ->
+ yoptions:attach_options list -> xpadding:int -> ypadding:int -> unit
+ = "ml_gtk_table_attach_bc" "ml_gtk_table_attach"
+ let has_x : expand_type -> bool =
+ function `X|`BOTH -> true | `Y|`NONE -> false
+ let has_y : expand_type -> bool =
+ function `Y|`BOTH -> true | `X|`NONE -> false
+ let attach t ~left ~top ?(right=left+1) ?(bottom=top+1)
+ ?(expand=`NONE) ?(fill=`BOTH) ?(shrink=`NONE)
+ ?(xpadding=0) ?(ypadding=0) w =
+ let xoptions = if has_x shrink then [`SHRINK] else [] in
+ let xoptions = if has_x fill then `FILL::xoptions else xoptions in
+ let xoptions = if has_x expand then `EXPAND::xoptions else xoptions in
+ let yoptions = if has_y shrink then [`SHRINK] else [] in
+ let yoptions = if has_y fill then `FILL::yoptions else yoptions in
+ let yoptions = if has_y expand then `EXPAND::yoptions else yoptions in
+ attach t w ~left ~top ~right ~bottom ~xoptions ~yoptions
+ ~xpadding ~ypadding
+ external set_row_spacing : [>`table] obj -> int -> int -> unit
+ = "ml_gtk_table_set_row_spacing"
+ external set_col_spacing : [>`table] obj -> int -> int -> unit
+ = "ml_gtk_table_set_col_spacing"
+ external set_row_spacings : [>`table] obj -> int -> unit
+ = "ml_gtk_table_set_row_spacings"
+ external set_col_spacings : [>`table] obj -> int -> unit
+ = "ml_gtk_table_set_col_spacings"
+ external set_homogeneous : [>`table] obj -> bool -> unit
+ = "ml_gtk_table_set_homogeneous"
+ let set ?homogeneous ?row_spacings ?col_spacings w =
+ may row_spacings ~f:(set_row_spacings w);
+ may col_spacings ~f:(set_col_spacings w);
+ may homogeneous ~f:(set_homogeneous w)
+end
+
+module Notebook = struct
+ let cast w : notebook obj = Object.try_cast w "GtkNotebook"
+ external create : unit -> notebook obj = "ml_gtk_notebook_new"
+ external insert_page :
+ [>`notebook] obj -> [>`widget] obj -> tab_label:[>`widget] optobj ->
+ menu_label:[>`widget] optobj -> pos:int -> unit
+ = "ml_gtk_notebook_insert_page_menu"
+ (* default is append to end *)
+ external remove_page : [>`notebook] obj -> int -> unit
+ = "ml_gtk_notebook_remove_page"
+ external get_current_page : [>`notebook] obj -> int
+ = "ml_gtk_notebook_get_current_page"
+ external set_page : [>`notebook] obj -> int -> unit
+ = "ml_gtk_notebook_set_page"
+ external set_tab_pos : [>`notebook] obj -> position -> unit
+ = "ml_gtk_notebook_set_tab_pos"
+ external set_homogeneous_tabs : [>`notebook] obj -> bool -> unit
+ = "ml_gtk_notebook_set_homogeneous_tabs"
+ external set_show_tabs : [>`notebook] obj -> bool -> unit
+ = "ml_gtk_notebook_set_show_tabs"
+ external set_show_border : [>`notebook] obj -> bool -> unit
+ = "ml_gtk_notebook_set_show_border"
+ external set_scrollable : [>`notebook] obj -> bool -> unit
+ = "ml_gtk_notebook_set_scrollable"
+ external set_tab_border : [>`notebook] obj -> int -> unit
+ = "ml_gtk_notebook_set_tab_border"
+ external popup_enable : [>`notebook] obj -> unit
+ = "ml_gtk_notebook_popup_enable"
+ external popup_disable : [>`notebook] obj -> unit
+ = "ml_gtk_notebook_popup_disable"
+ external get_nth_page : [>`notebook] obj -> int -> widget obj
+ = "ml_gtk_notebook_get_nth_page"
+ external page_num : [>`notebook] obj -> [>`widget] obj -> int
+ = "ml_gtk_notebook_page_num"
+ external next_page : [>`notebook] obj -> unit
+ = "ml_gtk_notebook_next_page"
+ external prev_page : [>`notebook] obj -> unit
+ = "ml_gtk_notebook_prev_page"
+ external get_tab_label : [>`notebook] obj -> [>`widget] obj -> widget obj
+ = "ml_gtk_notebook_get_tab_label"
+ external set_tab_label :
+ [>`notebook] obj -> [>`widget] obj -> [>`widget] obj -> unit
+ = "ml_gtk_notebook_set_tab_label"
+ external get_menu_label : [>`notebook] obj -> [>`widget] obj -> widget obj
+ = "ml_gtk_notebook_get_menu_label"
+ external set_menu_label :
+ [>`notebook] obj -> [>`widget] obj -> [>`widget] obj -> unit
+ = "ml_gtk_notebook_set_menu_label"
+ external reorder_child : [>`notebook] obj -> [>`widget] obj -> int -> unit
+ = "ml_gtk_notebook_reorder_child"
+
+ let set_popup w = function
+ true -> popup_enable w
+ | false -> popup_disable w
+ let set ?page ?tab_pos ?show_tabs ?homogeneous_tabs
+ ?show_border ?scrollable ?tab_border ?popup w =
+ let may_set f = may ~f:(f w) in
+ may_set set_page page;
+ may_set set_tab_pos tab_pos;
+ may_set set_show_tabs show_tabs;
+ may_set set_homogeneous_tabs homogeneous_tabs;
+ may_set set_show_border show_border;
+ may_set set_scrollable scrollable;
+ may_set set_tab_border tab_border;
+ may_set set_popup popup
+ module Signals = struct
+ open GtkArgv
+ open GtkSignal
+ let marshal_page f argv = function
+ | _ :: INT page :: _ -> f page
+ | _ -> invalid_arg "GtkPack.Notebook.Signals.marshal_page"
+ let switch_page : ([>`notebook],_) t =
+ { name = "switch_page"; marshaller = marshal_page }
+ end
+end
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Progress = struct
+ let cast w : progress obj = Object.try_cast w "GtkProgress"
+ external set_show_text : [>`progress] obj -> bool -> unit
+ = "ml_gtk_progress_set_show_text"
+ external set_text_alignment :
+ [>`progress] obj -> ?x:float -> ?y:float -> unit -> unit
+ = "ml_gtk_progress_set_show_text"
+ external set_format_string : [>`progress] obj -> string -> unit
+ = "ml_gtk_progress_set_format_string"
+ external set_adjustment : [>`progress] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_progress_set_adjustment"
+ external configure :
+ [>`progress] obj -> current:float -> min:float -> max:float -> unit
+ = "ml_gtk_progress_configure"
+ external set_percentage : [>`progress] obj -> float -> unit
+ = "ml_gtk_progress_set_percentage"
+ external set_value : [>`progress] obj -> float -> unit
+ = "ml_gtk_progress_set_value"
+ external get_value : [>`progress] obj -> float
+ = "ml_gtk_progress_get_value"
+ external get_percentage : [>`progress] obj -> float
+ = "ml_gtk_progress_get_current_percentage"
+ external set_activity_mode : [>`progress] obj -> bool -> unit
+ = "ml_gtk_progress_set_activity_mode"
+ external get_current_text : [>`progress] obj -> string
+ = "ml_gtk_progress_get_current_text"
+ external get_adjustment : [>`progress] obj -> adjustment obj
+ = "ml_gtk_progress_get_adjustment"
+ let set ?value ?percentage ?activity_mode
+ ?show_text ?format_string ?text_xalign ?text_yalign w =
+ may value ~f:(set_value w);
+ may percentage ~f:(set_percentage w);
+ may activity_mode ~f:(set_activity_mode w);
+ may show_text ~f:(set_show_text w);
+ may format_string ~f:(set_format_string w);
+ if text_xalign <> None || text_yalign <> None then
+ set_text_alignment w ?x:text_xalign ?y:text_yalign ()
+end
+
+module ProgressBar = struct
+ let cast w : progress_bar obj = Object.try_cast w "GtkProgressBar"
+ external create : unit -> progress_bar obj = "ml_gtk_progress_bar_new"
+ external create_with_adjustment : [>`adjustment] obj -> progress_bar obj
+ = "ml_gtk_progress_bar_new_with_adjustment"
+ external set_bar_style :
+ [>`progressbar] obj -> [`CONTINUOUS|`DISCRETE] -> unit
+ = "ml_gtk_progress_bar_set_bar_style"
+ external set_discrete_blocks : [>`progressbar] obj -> int -> unit
+ = "ml_gtk_progress_bar_set_discrete_blocks"
+ external set_activity_step : [>`progressbar] obj -> int -> unit
+ = "ml_gtk_progress_bar_set_activity_step"
+ external set_activity_blocks : [>`progressbar] obj -> int -> unit
+ = "ml_gtk_progress_bar_set_activity_blocks"
+ external set_orientation :
+ [>`progressbar] obj -> Tags.progress_bar_orientation -> unit
+ = "ml_gtk_progress_bar_set_orientation"
+ let set ?bar_style ?discrete_blocks ?activity_step ?activity_blocks w =
+ let may_set f opt = may opt ~f:(f w) in
+ may_set set_bar_style bar_style;
+ may_set set_discrete_blocks discrete_blocks;
+ may_set set_activity_step activity_step;
+ may_set set_activity_blocks activity_blocks
+end
+
+module Range = struct
+ let cast w : range obj = Object.try_cast w "GtkRange"
+ external coerce : [>`range] obj -> range obj = "%identity"
+ external get_adjustment : [>`range] obj -> adjustment obj
+ = "ml_gtk_range_get_adjustment"
+ external set_adjustment : [>`range] obj -> [>`adjustment] obj -> unit
+ = "ml_gtk_range_set_adjustment"
+ external set_update_policy : [>`range] obj -> update_type -> unit
+ = "ml_gtk_range_set_update_policy"
+ let set ?adjustment ?update_policy w =
+ may adjustment ~f:(set_adjustment w);
+ may update_policy ~f:(set_update_policy w)
+end
+
+module Scale = struct
+ let cast w : scale obj = Object.try_cast w "GtkScale"
+ external hscale_new : [>`adjustment] optobj -> scale obj
+ = "ml_gtk_hscale_new"
+ external vscale_new : [>`adjustment] optobj -> scale obj
+ = "ml_gtk_vscale_new"
+ let create ?adjustment (dir : orientation) =
+ let create = if dir = `HORIZONTAL then hscale_new else vscale_new in
+ create (Gpointer.optboxed adjustment)
+ external set_digits : [>`scale] obj -> int -> unit
+ = "ml_gtk_scale_set_digits"
+ external set_draw_value : [>`scale] obj -> bool -> unit
+ = "ml_gtk_scale_set_draw_value"
+ external set_value_pos : [>`scale] obj -> position -> unit
+ = "ml_gtk_scale_set_value_pos"
+ external get_value_width : [>`scale] obj -> int
+ = "ml_gtk_scale_get_value_width"
+ external draw_value : [>`scale] obj -> unit
+ = "ml_gtk_scale_draw_value"
+ let set ?digits ?draw_value ?value_pos w =
+ may digits ~f:(set_digits w);
+ may draw_value ~f:(set_draw_value w);
+ may value_pos ~f:(set_value_pos w)
+end
+
+module Scrollbar = struct
+ let cast w : scrollbar obj = Object.try_cast w "GtkScrollbar"
+ external hscrollbar_new : [>`adjustment] optobj -> scrollbar obj
+ = "ml_gtk_hscrollbar_new"
+ external vscrollbar_new : [>`adjustment] optobj -> scrollbar obj
+ = "ml_gtk_vscrollbar_new"
+ let create ?adjustment (dir : orientation) =
+ let create = if dir = `HORIZONTAL then hscrollbar_new else vscrollbar_new
+ in create (Gpointer.optboxed adjustment)
+end
+
+module Ruler = struct
+ let cast w : ruler obj = Object.try_cast w "GtkRuler"
+ external hruler_new : unit -> ruler obj = "ml_gtk_hruler_new"
+ external vruler_new : unit -> ruler obj = "ml_gtk_vruler_new"
+ let create (dir : orientation) =
+ if dir = `HORIZONTAL then hruler_new () else vruler_new ()
+ external set_metric : [>`ruler] obj -> metric_type -> unit
+ = "ml_gtk_ruler_set_metric"
+ external set_range :
+ [>`ruler] obj ->
+ lower:float -> upper:float -> position:float -> max_size:float -> unit
+ = "ml_gtk_ruler_set_range"
+ external get_lower : [>`ruler] obj -> float = "ml_gtk_ruler_get_lower"
+ external get_upper : [>`ruler] obj -> float = "ml_gtk_ruler_get_upper"
+ external get_position : [>`ruler] obj -> float = "ml_gtk_ruler_get_position"
+ external get_max_size : [>`ruler] obj -> float = "ml_gtk_ruler_get_max_size"
+ let set_range ?lower ?upper ?position ?max_size w =
+ set_range w ~lower:(may_default get_lower w ~opt:lower)
+ ~upper:(may_default get_upper w ~opt:upper)
+ ~position:(may_default get_position w ~opt:position)
+ ~max_size:(may_default get_max_size w ~opt:max_size)
+ let set ?metric ?lower ?upper ?position ?max_size w =
+ may metric ~f:(set_metric w);
+ if lower <> None || upper <> None || position <> None || max_size <> None
+ then set_range w ?lower ?upper ?position ?max_size
+end
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+type id
+type ('a,'b) t =
+ { name: string;
+ marshaller: ('b -> GtkArgv.t -> GtkArgv.data list -> unit) }
+
+let enter_callback = ref (fun () -> ())
+and exit_callback = ref (fun () -> ())
+
+let stop_emit_ref = ref false
+let stop_emit () = stop_emit_ref := true
+
+type saved_state = State of bool
+let push_callback () =
+ !enter_callback ();
+ let old = !stop_emit_ref in
+ stop_emit_ref := false;
+ State old
+
+let pop_callback (State old) =
+ let res = !stop_emit_ref in
+ stop_emit_ref := old;
+ !exit_callback ();
+ res
+
+external connect :
+ 'a obj -> name:string -> callback:(GtkArgv.t -> unit) -> after:bool -> id
+ = "ml_gtk_signal_connect"
+external emit_stop_by_name : 'a obj -> name:string -> unit
+ = "ml_gtk_signal_emit_stop_by_name"
+let connect ~(sgn : ('a, _) t) ~callback ?(after=false) (obj : 'a obj) =
+ let callback argv =
+ let old = push_callback () in
+ let exn =
+ try sgn.marshaller callback argv (GtkArgv.get_args argv); None
+ with exn -> Some exn
+ in
+ if pop_callback old then emit_stop_by_name obj ~name:sgn.name;
+ Gaux.may ~f:raise exn
+ in
+ connect obj ~name:sgn.name ~callback ~after
+external disconnect : 'a obj -> id -> unit
+ = "ml_gtk_signal_disconnect"
+external handler_block : 'a obj -> id -> unit
+ = "ml_gtk_signal_handler_block"
+external handler_unblock : 'a obj -> id -> unit
+ = "ml_gtk_signal_handler_unblock"
+
+let marshal_unit f _ _ = f ()
+let marshal_int f _ = function
+ | GtkArgv.INT n :: _ -> f n
+ | _ -> invalid_arg "GtkSignal.marshal_int"
+
+let emit (obj : 'a obj) ~(sgn : ('a, 'b) t)
+ ~(emitter : 'a obj -> name:string -> 'b) =
+ emitter obj ~name:sgn.name
+external emit_none : 'a obj -> name:string -> unit -> unit
+ = "ml_gtk_signal_emit_none"
+let emit_unit obj ~sgn = emit obj ~emitter:emit_none ~sgn ()
+external emit_int : 'a obj -> name:string -> int -> unit
+ = "ml_gtk_signal_emit_int"
+let emit_int = emit ~emitter:emit_int
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+type id
+type ('a,'b) t =
+ { name: string;
+ marshaller: ('b -> GtkArgv.t -> GtkArgv.data list -> unit) }
+
+val stop_emit : unit -> unit
+ (* Call [stop_emit ()] in a callback to prohibit further handling
+ of the current signal invocation, by calling [emit_stop_by_name].
+ Be careful about where you use it, since the concept of current
+ signal may be tricky. *)
+
+val connect :
+ sgn:('a, 'b) t -> callback:'b -> ?after:bool -> 'a obj -> id
+ (* You may use [stop_emit] inside the callback *)
+
+external disconnect : 'a obj -> id -> unit
+ = "ml_gtk_signal_disconnect"
+external emit_stop_by_name : 'a obj -> name:string -> unit
+ = "ml_gtk_signal_emit_stop_by_name"
+ (* Unsafe: use [stop_emit] instead. *)
+external handler_block : 'a obj -> id -> unit
+ = "ml_gtk_signal_handler_block"
+external handler_unblock : 'a obj -> id -> unit
+ = "ml_gtk_signal_handler_unblock"
+
+(* Some marshaller functions, to build signals *)
+val marshal_unit : (unit -> unit) -> GtkArgv.t -> GtkArgv.data list -> unit
+val marshal_int : (int -> unit) -> GtkArgv.t -> GtkArgv.data list -> unit
+
+(* Emitter functions *)
+val emit :
+ 'a obj -> sgn:('a, 'b) t -> emitter:('a obj -> name:string -> 'b) -> 'b
+val emit_unit : 'a obj -> sgn:('a, unit -> unit) t -> unit
+val emit_int : 'a obj -> sgn:('a, int -> unit) t -> int -> unit
+
+(* Internal functions. *)
+val enter_callback : (unit -> unit) ref
+val exit_callback : (unit -> unit) ref
+type saved_state
+val push_callback : unit -> saved_state
+val pop_callback : saved_state -> bool
--- /dev/null
+(* $Id$ *)
+
+(* Start the main thread in a threaded toplevel *)
+
+let thread = GtkThread.start ()
--- /dev/null
+(* $Id$ *)
+
+open GtkMain
+
+(* We check first whether there are some event pending, and run
+ some iterations. We then need to delay, thus focing a thread switch. *)
+
+let main () =
+ try
+ let loop = (Glib.Main.create true) in
+ Main.loops := loop :: !Main.loops;
+ while Glib.Main.is_running loop do
+ let i = ref 0 in
+ while !i < 100 && Glib.Main.pending () do
+ Glib.Main.iteration true;
+ incr i
+ done;
+ Thread.delay 0.001
+ done;
+ Main.loops := List.tl !Main.loops
+ with exn ->
+ Main.loops := List.tl !Main.loops;
+ raise exn
+
+let start = Thread.create main
+
+let _ =
+ let mutex = Mutex.create () in
+ let depth = ref 0 in
+ GtkSignal.enter_callback :=
+ (fun () -> if !depth = 0 then Mutex.lock mutex; incr depth);
+ GtkSignal.exit_callback :=
+ (fun () -> decr depth; if !depth = 0 then Mutex.unlock mutex)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module TreeItem = struct
+ let cast w : tree_item obj = Object.try_cast w "GtkTreeItem"
+ external create : unit -> tree_item obj = "ml_gtk_tree_item_new"
+ external create_with_label : string -> tree_item obj
+ = "ml_gtk_tree_item_new_with_label"
+ let create ?label () =
+ match label with None -> create ()
+ | Some label -> create_with_label label
+ external set_subtree : [>`treeitem] obj -> [>`widget] obj -> unit
+ = "ml_gtk_tree_item_set_subtree"
+ external remove_subtree : [>`treeitem] obj -> unit
+ = "ml_gtk_tree_item_remove_subtree"
+ external expand : [>`treeitem] obj -> unit
+ = "ml_gtk_tree_item_expand"
+ external collapse : [>`treeitem] obj -> unit
+ = "ml_gtk_tree_item_collapse"
+ external subtree : [>`treeitem] obj -> tree obj
+ = "ml_GTK_TREE_ITEM_SUBTREE"
+ module Signals = struct
+ open GtkSignal
+ let expand : ([>`treeitem],_) t =
+ { name = "expand"; marshaller = marshal_unit }
+ let collapse : ([>`treeitem],_) t =
+ { name = "collapse"; marshaller = marshal_unit }
+ end
+end
+
+module Tree = struct
+ let cast w : tree obj = Object.try_cast w "GtkTree"
+ external coerce : [>`tree] obj -> tree obj = "%identity"
+ external create : unit -> tree obj = "ml_gtk_tree_new"
+ external insert : [>`tree] obj -> [>`treeitem] obj -> pos:int -> unit
+ = "ml_gtk_tree_insert"
+ external remove_items : [>`tree] obj -> [>`treeitem] obj list -> unit
+ = "ml_gtk_tree_remove_items"
+ external clear_items : [>`tree] obj -> start:int -> stop:int -> unit
+ = "ml_gtk_tree_clear_items"
+ external select_item : [>`tree] obj -> pos:int -> unit
+ = "ml_gtk_tree_select_item"
+ external unselect_item : [>`tree] obj -> pos:int -> unit
+ = "ml_gtk_tree_unselect_item"
+ external child_position : [>`tree] obj -> [>`treeitem] obj -> int
+ = "ml_gtk_tree_child_position"
+ external set_selection_mode : [>`tree] obj -> selection_mode -> unit
+ = "ml_gtk_tree_set_selection_mode"
+ external set_view_mode : [>`tree] obj -> [`LINE|`ITEM] -> unit
+ = "ml_gtk_tree_set_view_mode"
+ external set_view_lines : [>`tree] obj -> bool -> unit
+ = "ml_gtk_tree_set_view_lines"
+ external selection : [>`tree] obj -> tree_item obj list =
+ "ml_gtk_tree_selection"
+ let set ?selection_mode ?view_mode ?view_lines w =
+ let may_set f = may ~f:(f w) in
+ may_set set_selection_mode selection_mode;
+ may_set set_view_mode view_mode;
+ may_set set_view_lines view_lines
+ module Signals = struct
+ open GtkSignal
+ let selection_changed : ([>`tree],_) t =
+ { name = "selection_changed"; marshaller = marshal_unit }
+ let select_child : ([>`tree],_) t =
+ { name = "select_child"; marshaller = Widget.Signals.marshal }
+ let unselect_child : ([>`tree],_) t =
+ { name = "unselect_child"; marshaller = Widget.Signals.marshal }
+ end
+end
+(*
+module CTree = struct
+ type t
+ type node = [`ctree] obj * t
+ let cast w : ctree obj = Object.try_cast w "GtkCTree"
+ external create : cols:int -> treecol:int -> ctree obj = "ml_gtk_ctree_new"
+ external insert_node :
+ [>`ctree] obj -> ?parent:node -> ?sibling:node ->
+ titles:optstring array ->
+ spacing:int -> ?pclosed:Gdk.pixmap -> ?mclosed:Gdk.bitmap obj ->
+ ?popened:Gdk.pixmap -> ?mopened:Gdk.bitmap obj ->
+ is_leaf:bool -> expanded:bool -> node
+ = "ml_gtk_ctree_insert_node_bc" "ml_gtk_ctree_insert_node"
+ let insert_node'
+ w ?parent ?sibling ?(spacing = 0) ?(is_leaf = true)
+ ?(expanded = false)
+ ?pclosed ?mclosed ?popened ?mopened titles =
+ let len = GtkList.CList.get_columns w in
+ if List.length titles > len then invalid_arg "CTree.insert_node";
+ let arr = Array.create ~len None in
+ List.fold_left titles ~acc:0
+ ~f:(fun ~acc text -> arr.(acc) <- Some text; acc+1);
+ insert_node w
+ ?parent ?sibling ~titles:(Array.map ~f:optstring arr)
+ ~spacing ~is_leaf ~expanded
+ ?pclosed ?mclosed ?popened ?mopened
+ external node_set_row_data : [>`ctree] obj -> node:node -> Obj.t -> unit
+ = "ml_gtk_ctree_node_set_row_data"
+ external node_get_row_data : [>`ctree] obj -> node:node -> Obj.t
+ = "ml_gtk_ctree_node_get_row_data"
+ external set_indent : [>`ctree] obj -> int -> unit
+ = "ml_gtk_ctree_set_indent"
+ module Signals = struct
+ open GtkSignal
+ let marshal_select f argv =
+ let node : node =
+ match GtkArgv.get_pointer argv ~pos:0 with
+ Some p -> Obj.magic p
+ | None -> invalid_arg "GtkTree.CTree.Signals.marshal_select"
+ in
+ f ~node ~column:(GtkArgv.get_int argv ~pos:1)
+
+ let tree_select_row : ([>`ctree],_) t =
+ { name = "tree_select_row"; marshaller = marshal_select }
+ let tree_unselect_row : ([>`ctree],_) t =
+ { name = "tree_unselect_row"; marshaller = marshal_select }
+ end
+end
+*)
--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open Tags
+open GtkBase
+
+module Window = struct
+ let cast w : window obj = Object.try_cast w "GtkWindow"
+ external coerce : [>`window] obj -> window obj = "%identity"
+ external create : window_type -> window obj = "ml_gtk_window_new"
+ external set_title : [>`window] obj -> string -> unit
+ = "ml_gtk_window_set_title"
+ external set_wmclass : [>`window] obj -> name:string -> clas:string -> unit
+ = "ml_gtk_window_set_title"
+ external get_wmclass_name : [>`window] obj -> string
+ = "ml_gtk_window_get_wmclass_name"
+ external get_wmclass_class : [>`window] obj -> string
+ = "ml_gtk_window_get_wmclass_class"
+ (* set_focus/default are called by Widget.grab_focus/default *)
+ external set_focus : [>`window] obj -> [>`widget] obj -> unit
+ = "ml_gtk_window_set_focus"
+ external set_default : [>`window] obj -> [>`widget] obj -> unit
+ = "ml_gtk_window_set_default"
+ external set_policy :
+ [>`window] obj ->
+ allow_shrink:bool -> allow_grow:bool -> auto_shrink:bool -> unit
+ = "ml_gtk_window_set_policy"
+ external get_allow_shrink : [>`window] obj -> bool
+ = "ml_gtk_window_get_allow_shrink"
+ external get_allow_grow : [>`window] obj -> bool
+ = "ml_gtk_window_get_allow_grow"
+ external get_auto_shrink : [>`window] obj -> bool
+ = "ml_gtk_window_get_auto_shrink"
+ external activate_focus : [>`window] obj -> bool
+ = "ml_gtk_window_activate_focus"
+ external activate_default : [>`window] obj -> bool
+ = "ml_gtk_window_activate_default"
+ external set_modal : [>`window] obj -> bool -> unit
+ = "ml_gtk_window_set_modal"
+ external set_default_size :
+ [>`window] obj -> width:int -> height:int -> unit
+ = "ml_gtk_window_set_default_size"
+ external set_position : [>`window] obj -> window_position -> unit
+ = "ml_gtk_window_set_position"
+ external set_transient_for : [>`window] obj ->[>`window] obj -> unit
+ = "ml_gtk_window_set_transient_for"
+
+ let set_wmclass ?name ?clas:wm_class w =
+ set_wmclass w ~name:(may_default get_wmclass_name w ~opt:name)
+ ~clas:(may_default get_wmclass_class w ~opt:wm_class)
+ let set_policy ?allow_shrink ?allow_grow ?auto_shrink w =
+ set_policy w
+ ~allow_shrink:(may_default get_allow_shrink w ~opt:allow_shrink)
+ ~allow_grow:(may_default get_allow_grow w ~opt:allow_grow)
+ ~auto_shrink:(may_default get_auto_shrink w ~opt:auto_shrink)
+ let set ?title ?wm_name ?wm_class ?position ?allow_shrink ?allow_grow
+ ?auto_shrink ?modal ?(x = -2) ?(y = -2) w =
+ may title ~f:(set_title w);
+ if wm_name <> None || wm_class <> None then
+ set_wmclass w ?name:wm_name ?clas:wm_class;
+ may position ~f:(set_position w);
+ if allow_shrink <> None || allow_grow <> None || auto_shrink <> None then
+ set_policy w ?allow_shrink ?allow_grow ?auto_shrink;
+ may ~f:(set_modal w) modal;
+ if x <> -2 || y <> -2 then Widget.set_uposition w ~x ~y
+ external add_accel_group : [>`window] obj -> accel_group -> unit
+ = "ml_gtk_window_add_accel_group"
+ external remove_accel_group :
+ [>`window] obj -> accel_group -> unit
+ = "ml_gtk_window_remove_accel_group"
+ external activate_focus : [>`window] obj -> unit
+ = "ml_gtk_window_activate_focus"
+ external activate_default : [>`window] obj -> unit
+ = "ml_gtk_window_activate_default"
+ module Signals = struct
+ open GtkSignal
+ let move_resize : ([>`window],_) t =
+ { name = "move_resize"; marshaller = marshal_unit }
+ let set_focus : ([>`window],_) t =
+ { name = "set_focus"; marshaller = Widget.Signals.marshal_opt }
+ end
+end
+
+module Dialog = struct
+ let cast w : dialog obj = Object.try_cast w "GtkDialog"
+ external coerce : [>`dialog] obj -> dialog obj = "%identity"
+ external create : unit -> dialog obj = "ml_gtk_dialog_new"
+ external action_area : [>`dialog] obj -> box obj
+ = "ml_GtkDialog_action_area"
+ external vbox : [>`dialog] obj -> box obj
+ = "ml_GtkDialog_vbox"
+end
+
+module InputDialog = struct
+ let cast w : input_dialog obj = Object.try_cast w "GtkInputDialog"
+ external create : unit -> input_dialog obj = "ml_gtk_input_dialog_new"
+ module Signals = struct
+ open GtkSignal
+ let enable_device : ([>`inputdialog],_) t =
+ { name = "enable_device"; marshaller = marshal_int }
+ let disable_device : ([>`inputdialog],_) t =
+ { name = "disable_device"; marshaller = marshal_int }
+ end
+end
+
+module FileSelection = struct
+ let cast w : file_selection obj = Object.try_cast w "GtkFileSelection"
+ external create : string -> file_selection obj = "ml_gtk_file_selection_new"
+ external set_filename : [>`filesel] obj -> string -> unit
+ = "ml_gtk_file_selection_set_filename"
+ external get_filename : [>`filesel] obj -> string
+ = "ml_gtk_file_selection_get_filename"
+ external show_fileop_buttons : [>`filesel] obj -> unit
+ = "ml_gtk_file_selection_show_fileop_buttons"
+ external hide_fileop_buttons : [>`filesel] obj -> unit
+ = "ml_gtk_file_selection_hide_fileop_buttons"
+ external get_ok_button : [>`filesel] obj -> button obj
+ = "ml_gtk_file_selection_get_ok_button"
+ external get_cancel_button : [>`filesel] obj -> button obj
+ = "ml_gtk_file_selection_get_cancel_button"
+ external get_help_button : [>`filesel] obj -> button obj
+ = "ml_gtk_file_selection_get_help_button"
+ let set_fileop_buttons w = function
+ true -> show_fileop_buttons w
+ | false -> hide_fileop_buttons w
+ let set ?filename ?fileop_buttons w =
+ may filename ~f:(set_filename w);
+ may fileop_buttons ~f:(set_fileop_buttons w)
+end
+
+module FontSelectionDialog = struct
+ let cast w : font_selection_dialog obj =
+ Object.try_cast w "GtkFontSelectionDialog"
+ external create : ?title:string -> unit -> font_selection_dialog obj
+ = "ml_gtk_font_selection_dialog_new"
+ external font_selection : [>`fontseldialog] obj -> font_selection obj
+ = "ml_gtk_font_selection_dialog_fontsel"
+ external ok_button : [>`fontseldialog] obj -> button obj
+ = "ml_gtk_font_selection_dialog_ok_button"
+ external apply_button : [>`fontseldialog] obj -> button obj
+ = "ml_gtk_font_selection_dialog_apply_button"
+ external cancel_button : [>`fontseldialog] obj -> button obj
+ = "ml_gtk_font_selection_dialog_cancel_button"
+(*
+ type null_terminated
+ let null_terminated arg : null_terminated =
+ match arg with None -> Obj.magic Gpointer.raw_null
+ | Some l ->
+ let len = List.length l in
+ let arr = Array.create (len + 1) "" in
+ let rec loop i = function
+ [] -> arr.(i) <- Obj.magic Gpointer.raw_null
+ | s::l -> arr.(i) <- s; loop (i+1) l
+ in loop 0 l;
+ Obj.magic (arr : string array)
+ external get_font : [>`fontseldialog] obj -> Gdk.font
+ = "ml_gtk_font_selection_dialog_get_font"
+ let get_font w =
+ try Some (get_font w) with Gpointer.Null -> None
+ external get_font_name : [>`fontseldialog] obj -> string
+ = "ml_gtk_font_selection_dialog_get_font_name"
+ let get_font_name w =
+ try Some (get_font_name w) with Gpointer.Null -> None
+ external set_font_name : [>`fontseldialog] obj -> string -> unit
+ = "ml_gtk_font_selection_dialog_set_font_name"
+ external set_filter :
+ [>`fontseldialog] obj -> font_filter_type -> font_type list ->
+ null_terminated -> null_terminated -> null_terminated ->
+ null_terminated -> null_terminated -> null_terminated -> unit
+ = "ml_gtk_font_selection_dialog_set_filter_bc"
+ "ml_gtk_font_selection_dialog_set_filter"
+ let set_filter w ?kind:(tl=[`ALL]) ?foundry
+ ?weight ?slant ?setwidth ?spacing ?charset filter =
+ set_filter w filter tl (null_terminated foundry)
+ (null_terminated weight) (null_terminated slant)
+ (null_terminated setwidth) (null_terminated spacing)
+ (null_terminated charset)
+ external get_preview_text : [>`fontseldialog] obj -> string
+ = "ml_gtk_font_selection_dialog_get_preview_text"
+ external set_preview_text : [>`fontseldialog] obj -> string -> unit
+ = "ml_gtk_font_selection_dialog_set_preview_text"
+*)
+end
+
+module Plug = struct
+ let cast w : plug obj = Object.try_cast w "GtkPlug"
+ external create : Gdk.xid -> plug obj = "ml_gtk_plug_new"
+end
--- /dev/null
+(* $Id$ *)
+
+open Gtk
+
+type string_direction = [
+ | `R_TO_L
+ | `L_TO_R
+]
+
+type position = [
+ | `END
+ | `CENTER
+ | `BEGINNING
+]
+
+type line_type = [
+ | `SOLID
+ | `DASHED
+ | `SINGLE
+ | `DOUBLE
+ | `STRIKE
+ | `UNDER
+ | `NONE
+]
+
+type dither_type = [
+ | `QUICK
+ | `BEST
+ | `FAST
+ | `SLOW
+ | `DISABLED
+]
+
+type xmhtml = [`widget|`container|`xmhtml]
+
+external create : unit -> xmhtml obj = "ml_gtk_xmhtml_new"
+external freeze : [> `xmhtml] obj -> unit = "ml_gtk_xmhtml_freeze"
+external thaw : [> `xmhtml] obj -> unit = "ml_gtk_xmhtml_thaw"
+external source : [> `xmhtml] obj -> string -> unit = "ml_gtk_xmhtml_source"
+(* external get_source : [> `xmhtml] obj -> string = "ml_gtk_xmhtml_get_source" *)
+external set_string_direction : [> `xmhtml] obj -> string_direction -> unit
+ = "ml_gtk_xmhtml_set_string_direction"
+external set_alignment : [> `xmhtml] obj -> position -> unit
+ = "ml_gtk_xmhtml_set_alignment"
+(* external set_outline : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_outline" *)
+external set_font_familty :
+ [> `xmhtml] obj -> family:string -> sizes:string -> unit
+ = "ml_gtk_xmhtml_set_font_familty"
+external set_font_familty_fixed :
+ [> `xmhtml] obj -> family:string -> sizes:string -> unit
+ = "ml_gtk_xmhtml_set_font_familty_fixed"
+external set_font_charset : [> `xmhtml] obj -> string -> unit
+ = "ml_gtk_xmhtml_set_font_charset"
+external set_allow_body_colors : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_allow_body_colors"
+external set_hilight_on_enter : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_hilight_on_enter"
+external set_anchor_underline_type : [> `xmhtml] obj -> line_type list -> unit
+ = "ml_gtk_xmhtml_set_anchor_underline_type"
+external set_anchor_visited_underline_type :
+ [> `xmhtml] obj -> line_type list -> unit
+ = "ml_gtk_xmhtml_set_anchor_visited_underline_type"
+external set_anchor_target_underline_type :
+ [> `xmhtml] obj -> line_type list -> unit
+ = "ml_gtk_xmhtml_set_anchor_target_underline_type"
+external set_allow_color_switching : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_allow_color_switching"
+external set_dithering : [> `xmhtml] obj -> dither_type -> unit
+ = "ml_gtk_xmhtml_set_dithering"
+external set_allow_font_switching : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_allow_font_switching"
+external set_max_image_colors : [> `xmhtml] obj -> int -> unit
+ = "ml_gtk_xmhtml_set_max_image_colors"
+external set_allow_images : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_allow_images"
+external set_plc_intervals :
+ [> `xmhtml] obj -> min:int -> max:int -> default:int -> unit
+ = "ml_gtk_xmhtml_set_plc_intervals"
+(*
+external set_def_body_image_url : [> `xmhtml] obj -> string -> unit
+ = "ml_gtk_xmhtml_set_def_body_image_url"
+*)
+external set_anchor_buttons : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_anchor_buttons"
+external set_anchor_cursor : [> `xmhtml] obj -> Gdk.cursor option -> unit
+ = "ml_gtk_xmhtml_set_anchor_cursor"
+external set_topline : [> `xmhtml] obj -> int -> unit
+ = "ml_gtk_xmhtml_set_topline"
+external get_topline : [> `xmhtml] obj -> int
+ = "ml_gtk_xmhtml_get_topline"
+external set_freeze_animations : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_freeze_animations"
+external set_screen_gamma : [> `xmhtml] obj -> float -> unit
+ = "ml_gtk_xmhtml_set_screen_gamma"
+external set_perfect_colors : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_perfect_colors"
+external set_uncompress_command : [> `xmhtml] obj -> string -> unit
+ = "ml_gtk_xmhtml_set_uncompress_command"
+external set_strict_checking : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_strict_checking"
+external set_bad_html_warnings : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_bad_html_warnings"
+external set_allow_form_coloring : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_allow_form_coloring"
+external set_imagemap_draw : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_imagemap_draw"
+external set_alpha_processing : [> `xmhtml] obj -> bool -> unit
+ = "ml_gtk_xmhtml_set_alpha_processing"
--- /dev/null
+(* $Id$ *)
+
+type arrow_type = "GTK_ARROW_"
+ [ `UP | `DOWN | `LEFT | `RIGHT ]
+
+type attach_options = "GTK_"
+ [ `EXPAND | `SHRINK | `FILL ]
+
+type button_box_style = "GTK_BUTTONBOX_"
+ [ `DEFAULT_STYLE | `SPREAD | `EDGE | `START | `END ]
+
+type direction_type = "GTK_DIR_"
+ [ `TAB_FORWARD | `TAB_BACKWARD | `UP | `DOWN | `LEFT | `RIGHT ]
+
+type justification = "GTK_JUSTIFY_"
+ [ `LEFT | `RIGHT | `CENTER | `FILL ]
+
+type match_type = "GTK_MATCH_"
+ [ `ALL | `ALL_TAIL | `HEAD | `TAIL | `EXACT | `LAST ]
+
+type metric_type = "GTK_"
+ [ `PIXELS | `INCHES | `CENTIMETERS ]
+
+type orientation = "GTK_ORIENTATION_"
+ [ `HORIZONTAL | `VERTICAL ]
+
+type corner_type = "GTK_CORNER_"
+ [ `TOP_LEFT | `BOTTOM_LEFT | `TOP_RIGHT | `BOTTOM_RIGHT ]
+
+type pack_type = "GTK_PACK_"
+ [ `START | `END ]
+
+type path_type = "GTK_PATH_"
+ [ `WIDGET | `WIDGET_CLASS | `CLASS ]
+
+type policy_type = "GTK_POLICY_"
+ [ `ALWAYS | `AUTOMATIC | `NEVER ]
+
+type position = "GTK_POS_"
+ [ `LEFT | `RIGHT | `TOP | `BOTTOM ]
+
+type preview_type = "GTK_PREVIEW_"
+ [ `COLOR | `GRAYSCALE ]
+
+type relief_style = "GTK_RELIEF_"
+ [ `NORMAL | `HALF | `NONE ]
+
+type resize_mode = "GTK_RESIZE_"
+ [ `PARENT | `QUEUE | `IMMEDIATE ]
+
+type signal_run_type = "GTK_RUN_"
+ [ `FIRST | `LAST | `BOTH | `NO_RECURSE | `ACTION | `NO_HOOKS ]
+
+type scroll_type = "GTK_SCROLL_"
+ [ `NONE | `STEP_FORWARD | `STEP_BACKWARD | `PAGE_BACKWARD
+ | `PAGE_FORWARD | `JUMP ]
+
+type selection_mode = "GTK_SELECTION_"
+ [ `SINGLE | `BROWSE | `MULTIPLE | `EXTENDED ]
+
+type shadow_type = "GTK_SHADOW_"
+ [ `NONE | `IN | `OUT | `ETCHED_IN | `ETCHED_OUT ]
+
+type state_type = "GTK_STATE_"
+ [ `NORMAL | `ACTIVE | `PRELIGHT | `SELECTED | `INSENSITIVE ]
+
+type submenu_direction = "GTK_DIRECTION_"
+ [ `LEFT | `RIGHT ]
+
+type submenu_placement = "GTK_"
+ [ `TOP_BOTTOM | `LEFT_RIGHT ]
+
+type toolbar_style = "GTK_TOOLBAR_"
+ [ `ICONS | `TEXT | `BOTH ]
+
+type trough_type = "GTK_TROUGH_"
+ [ `NONE | `START | `END | `JUMP ]
+
+type update_type = "GTK_UPDATE_"
+ [ `CONTINUOUS | `DISCONTINUOUS | `DELAYED ]
+
+type visibility = "GTK_VISIBILITY_"
+ [ `NONE | `PARTIAL | `FULL ]
+
+type window_position = "GTK_WIN_POS_"
+ [ `NONE | `CENTER | `MOUSE | `CENTER_ALWAYS ]
+
+type window_type = "GTK_WINDOW_"
+ [ `TOPLEVEL | `DIALOG | `POPUP ]
+
+type sort_type = "GTK_SORT_"
+ [ `ASCENDING | `DESCENDING ]
+
+
+type fundamental_type = "GTK_TYPE_"
+ [ `INVALID | `NONE | `CHAR | `BOOL | `INT | `UINT | `LONG | `ULONG
+ | `FLOAT | `DOUBLE | `STRING | `ENUM | `FLAGS | `BOXED | `FOREIGN
+ | `CALLBACK | `ARGS | `POINTER | `SIGNAL | `C_CALLBACK | `OBJECT ]
+
+type cell_type = "GTK_CELL_"
+ [ `EMPTY | `TEXT | `PIXMAP | `PIXTEXT | `WIDGET ]
+
+type toolbar_child = "GTK_TOOLBAR_CHILD_"
+ [ `SPACE | `BUTTON | `TOGGLEBUTTON | `RADIOBUTTON | `WIDGET ]
+
+type toolbar_space_style = "GTK_TOOLBAR_SPACE_"
+ [ `EMPTY | `LINE ]
+
+type tree_view_mode = "GTK_TREE_VIEW_"
+ [ `LINE | `ITEM ]
+
+type spin_type = "GTK_SPIN_"
+ [ `STEP_FORWARD | `STEP_BACKWARD | `PAGE_FORWARD | `PAGE_BACKWARD
+ | `HOME | `END | `USER_DEFINED ]
+
+type accel_flag = "GTK_ACCEL_"
+ [ `VISIBLE | `SIGNAL_VISIBLE | `LOCKED ]
+
+type packer_options = "GTK_"
+ [ `PACK_EXPAND | `FILL_X | `FILL_Y ]
+
+type side_type = "GTK_SIDE_"
+ [ `TOP | `BOTTOM | `LEFT | `RIGHT ]
+
+type anchor_type = "GTK_ANCHOR_"
+ [ `CENTER | `NORTH | `NW | `NE | `SOUTH | `SW | `SE | `WEST | `EAST ]
+
+type button_action = "GTK_BUTTON_"
+ [ `SELECTS | `DRAGS | `EXPANDS ]
+
+type calendar_display_options = "GTK_CALENDAR_"
+ [ `SHOW_HEADING | `SHOW_DAY_NAMES | `NO_MONTH_CHANGE | `SHOW_WEEK_NUMBERS
+ | `WEEK_START_MONDAY ]
+
+type progress_bar_style = "GTK_PROGRESS_"
+ [ `CONTINUOUS | `DISCRETE ]
+
+type progress_bar_orientation = "GTK_PROGRESS_"
+ [ `LEFT_TO_RIGHT | `RIGHT_TO_LEFT | `BOTTOM_TO_TOP | `TOP_TO_BOTTOM ]
+
+type dest_defaults = "GTK_DEST_DEFAULT_"
+ [ `MOTION | `HIGHLIGHT | `DROP | `ALL ]
+
+type target_flags = "GTK_TARGET_"
+ [ `SAME_APP | `SAME_WIDGET ]
+
+type font_metric_type = "GTK_FONT_METRIC_"
+ [ `PIXELS | `POINTS ]
+
+type font_type = "GTK_FONT_"
+ [ `BITMAP | `SCALABLE | `SCALABLE_BITMAP | `ALL ]
+
+type font_filter_type = "GTK_FONT_FILTER_"
+ [ `BASE | `USER ]
+
+(*
+type tree_pos = "GTK_CTREE_POS_"
+ [ `BEFORE | `AS_CHILD | `AFTER ]
+
+type tree_line_style = "GTK_CTREE_LINES_"
+ [ `NONE | `SOLID | `DOTTED | `TABBED ]
+
+type tree_expander_style = "GTK_CTREE_EXPANDER_"
+ [ `NONE | `SQUARE | `TRIANGLE | `CIRCULAR ]
+
+type tree_expansion_type = "GTK_CTREE_EXPANSION_"
+ [ `EXPAND | `EXPAND_RECURSIVE | `COLLAPSE | `COLLAPSE_RECURSIVE
+ | `TOGGLE | `TOGGLE_RECURSIVE ]
+*)
--- /dev/null
+(* $Id$ *)
+
+type visual_options = "GDK_GL_" [
+ | `USE_GL
+ | `BUFFER_SIZE
+ | `LEVEL
+ | `RGBA
+ | `DOUBLEBUFFER
+ | `STEREO
+ | `AUX_BUFFERS
+ | `RED_SIZE
+ | `GREEN_SIZE
+ | `BLUE_SIZE
+ | `ALPHA_SIZE
+ | `DEPTH_SIZE
+ | `STENCIL_SIZE
+ | `ACCUM_GREEN_SIZE
+ | `ACCUM_ALPHA_SIZE
+]
--- /dev/null
+(* $Id$ *)
+
+type string_direction = "TSTRING_DIRECTION_" [
+ | `R_TO_L
+ | `L_TO_R
+]
+
+type alignment = "TALIGNMENT_" [
+ | `END
+ | `CENTER
+ | `BEGINNING
+]
+
+type line_type = "LINE_" [
+ | `SOLID
+ | `DASHED
+ | `SINGLE
+ | `DOUBLE
+ | `STRIKE
+ | `UNDER
+ | `NONE "NO_LINE"
+]
+
+type dither_type = "Xm" [
+ | `QUICK
+ | `BEST
+ | `FAST
+ | `SLOW
+ | `DISABLED
+]
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gdk/gdk.h>
+#ifdef _WIN32
+#include <gdk/win32/gdkwin32.h>
+#else
+#include <gdk/gdkx.h>
+#endif
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "gdk_tags.h"
+
+void ml_raise_gdk (const char *errmsg)
+{
+ static value * exn = NULL;
+ if (exn == NULL)
+ exn = caml_named_value ("gdkerror");
+ raise_with_string (*exn, (char*)errmsg);
+}
+
+#include "gdk_tags.c"
+
+Make_OptFlags_val (GdkModifier_val)
+Make_Flags_val (Event_mask_val)
+
+#define Make_test(conv) \
+value ml_test_##conv (value mask, value test) \
+{ return Val_bool (conv(mask) & Int_val(test)); }
+
+Make_test(GdkModifier_val)
+
+/* Colormap */
+
+Make_Val_final_pointer (GdkColormap, gdk_colormap_ref, gdk_colormap_unref, 0)
+ML_0 (gdk_colormap_get_system, Val_GdkColormap)
+
+/* Screen geometry */
+ML_0 (gdk_screen_width, Val_int)
+ML_0 (gdk_screen_height, Val_int)
+
+/* Visual */
+value ml_gdk_visual_get_best (value depth, value type)
+{
+ GdkVisual *vis;
+ if (type == Val_unit)
+ if (depth == Val_unit) vis = gdk_visual_get_best ();
+ else vis = gdk_visual_get_best_with_depth (Int_val(Field(depth,0)));
+ else
+ if (depth == Val_unit)
+ vis = gdk_visual_get_best_with_type
+ (GdkVisualType_val(Field(type,0)));
+ else vis = gdk_visual_get_best_with_both
+ (Int_val(Field(depth,0)),GdkVisualType_val(Field(type,0)));
+ if (!vis) ml_raise_gdk("Gdk.Visual.get_best");
+ return Val_GdkVisual(vis);
+}
+
+Make_Extractor (GdkVisual,GdkVisual_val,type,Val_gdkVisualType)
+Make_Extractor (GdkVisual,GdkVisual_val,depth,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,red_mask,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,red_shift,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,red_prec,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,green_mask,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,green_shift,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,green_prec,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,blue_mask,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,blue_shift,Val_int)
+Make_Extractor (GdkVisual,GdkVisual_val,blue_prec,Val_int)
+
+/* Image */
+
+Make_Val_final_pointer (GdkImage, Ignore, gdk_image_destroy, 0)
+GdkImage *GdkImage_val(value val)
+{
+ if (!Field(val,1)) ml_raise_gdk ("attempt to use destroyed GdkImage");
+ return (GdkImage*)(Field(val,1));
+}
+value ml_gdk_image_destroy (value val)
+{
+ if (Field(val,1)) gdk_image_destroy((GdkImage*)(Field(val,1)));
+ Field(val,1) = 0;
+ return Val_unit;
+}
+ML_4 (gdk_image_new_bitmap, GdkVisual_val, String_val, Int_val, Int_val,
+ Val_GdkImage)
+ML_4 (gdk_image_new, GdkImageType_val, GdkVisual_val, Int_val, Int_val,
+ Val_GdkImage)
+ML_5 (gdk_image_get, GdkWindow_val, Int_val, Int_val, Int_val, Int_val,
+ Val_GdkImage)
+ML_4 (gdk_image_put_pixel, GdkImage_val, Int_val, Int_val, Int_val, Unit)
+ML_3 (gdk_image_get_pixel, GdkImage_val, Int_val, Int_val, Val_int)
+
+/* Color */
+
+ML_2 (gdk_colormap_new, GdkVisual_val, Bool_val, Val_GdkColormap)
+
+value ml_gdk_color_white (value cmap)
+{
+ GdkColor color;
+ gdk_color_white (GdkColormap_val(cmap), &color);
+ return Val_copy(color);
+}
+
+value ml_gdk_color_black (value cmap)
+{
+ GdkColor color;
+ gdk_color_black (GdkColormap_val(cmap), &color);
+ return Val_copy(color);
+}
+
+value ml_gdk_color_parse (char *spec)
+{
+ GdkColor color;
+ if (!gdk_color_parse (spec, &color))
+ ml_raise_gdk ("color_parse");
+ return Val_copy(color);
+}
+
+ML_2 (gdk_color_alloc, GdkColormap_val, GdkColor_val, Val_bool)
+
+value ml_GdkColor (value red, value green, value blue)
+{
+ GdkColor color;
+ color.red = Int_val(red);
+ color.green = Int_val(green);
+ color.blue = Int_val(blue);
+ color.pixel = 0;
+ return Val_copy(color);
+}
+
+Make_Extractor (GdkColor, GdkColor_val, red, Val_int)
+Make_Extractor (GdkColor, GdkColor_val, green, Val_int)
+Make_Extractor (GdkColor, GdkColor_val, blue, Val_int)
+Make_Extractor (GdkColor, GdkColor_val, pixel, Val_int)
+
+/* Rectangle */
+
+value ml_GdkRectangle (value x, value y, value width, value height)
+{
+ GdkRectangle rectangle;
+ rectangle.x = Int_val(x);
+ rectangle.y = Int_val(y);
+ rectangle.width = Int_val(width);
+ rectangle.height = Int_val(height);
+ return Val_copy(rectangle);
+}
+
+Make_Extractor (GdkRectangle, GdkRectangle_val, x, Val_int)
+Make_Extractor (GdkRectangle, GdkRectangle_val, y, Val_int)
+Make_Extractor (GdkRectangle, GdkRectangle_val, width, Val_int)
+Make_Extractor (GdkRectangle, GdkRectangle_val, height, Val_int)
+
+/* Window */
+
+Make_Val_final_pointer (GdkWindow, gdk_window_ref, gdk_window_unref, 0)
+Make_Extractor (gdk_visual_get, GdkVisual_val, depth, Val_int)
+ML_1 (gdk_window_get_visual, GdkWindow_val, Val_GdkVisual)
+ML_3 (gdk_window_set_back_pixmap, GdkWindow_val, GdkPixmap_val, Int_val, Unit)
+ML_1 (gdk_window_clear, GdkWindow_val, Unit)
+ML_0 (GDK_ROOT_PARENT, Val_GdkWindow)
+ML_1 (gdk_window_get_parent, GdkWindow_val, Val_GdkWindow)
+ML_1 (GDK_WINDOW_XWINDOW, GdkWindow_val, Val_XID)
+value ml_gdk_window_get_position (value window)
+{
+ int x, y;
+ value ret;
+
+ gdk_window_get_position (GdkWindow_val(window), &x, &y);
+
+ ret = alloc_small (2,0);
+ Field(ret,0) = Val_int(x);
+ Field(ret,1) = Val_int(y);
+ return ret;
+}
+
+value ml_gdk_window_get_size (value window)
+{
+ int x, y;
+ value ret;
+
+ gdk_window_get_size (GdkWindow_val(window), &x, &y);
+
+ ret = alloc_small (2,0);
+ Field(ret,0) = Val_int(x);
+ Field(ret,1) = Val_int(y);
+ return ret;
+}
+
+/* Cursor */
+
+ML_1 (gdk_cursor_new, GdkCursorType_val, Val_GdkCursor)
+ML_6 (gdk_cursor_new_from_pixmap, GdkPixmap_val, GdkPixmap_val,
+ GdkColor_val, GdkColor_val, Int_val, Int_val, Val_GdkCursor)
+ML_bc6 (ml_gdk_cursor_new_from_pixmap)
+ML_1 (gdk_cursor_destroy, GdkCursor_val, Unit)
+
+/* Pixmap */
+
+Make_Val_final_pointer (GdkPixmap, gdk_pixmap_ref, gdk_pixmap_unref, 0)
+Make_Val_final_pointer (GdkBitmap, gdk_bitmap_ref, gdk_bitmap_unref, 0)
+Make_Val_final_pointer_ext (GdkPixmap, _no_ref, Ignore, gdk_pixmap_unref, 20)
+Make_Val_final_pointer_ext (GdkBitmap, _no_ref, Ignore, gdk_bitmap_unref, 20)
+ML_4 (gdk_pixmap_new, GdkWindow_val, Int_val, Int_val, Int_val,
+ Val_GdkPixmap_no_ref)
+ML_4 (gdk_bitmap_create_from_data, GdkWindow_val,
+ String_val, Int_val, Int_val, Val_GdkBitmap_no_ref)
+ML_7 (gdk_pixmap_create_from_data, GdkWindow_val, String_val,
+ Int_val, Int_val, Int_val, GdkColor_val, GdkColor_val,
+ Val_GdkPixmap_no_ref)
+ML_bc7 (ml_gdk_pixmap_create_from_data)
+
+value ml_gdk_pixmap_colormap_create_from_xpm
+ (value window, value colormap, value transparent, char *filename)
+{
+ CAMLparam0();
+ GdkBitmap *mask;
+ CAMLlocal2(vpixmap, vmask);
+ value ret;
+
+ vpixmap = Val_GdkPixmap_no_ref
+ (gdk_pixmap_colormap_create_from_xpm
+ (GdkWindow_val(window), Option_val(colormap,GdkColormap_val,NULL),
+ &mask, Option_val(transparent,GdkColor_val,NULL), filename));
+ vmask = Val_GdkBitmap_no_ref (mask);
+
+ ret = alloc_small (2,0);
+ Field(ret,0) = vpixmap;
+ Field(ret,1) = vmask;
+ CAMLreturn(ret);
+}
+
+value ml_gdk_pixmap_colormap_create_from_xpm_d
+ (value window, value colormap, value transparent, char **data)
+{
+ CAMLparam0();
+ GdkBitmap *mask;
+ CAMLlocal2(vpixmap, vmask);
+ value ret;
+
+ vpixmap = Val_GdkPixmap_no_ref
+ (gdk_pixmap_colormap_create_from_xpm_d
+ (GdkWindow_val(window), Option_val(colormap,GdkColormap_val,NULL),
+ &mask, Option_val(transparent,GdkColor_val,NULL), data));
+ vmask = Val_GdkBitmap_no_ref (mask);
+
+ ret = alloc_small (2, 0);
+ Field(ret,0) = vpixmap;
+ Field(ret,1) = vmask;
+ CAMLreturn(ret);
+}
+
+/* Font */
+
+Make_Val_final_pointer (GdkFont, gdk_font_ref, gdk_font_unref, 0)
+Make_Val_final_pointer_ext (GdkFont, _no_ref, Ignore, gdk_font_unref, 20)
+ML_1 (gdk_font_load, String_val, Val_GdkFont_no_ref)
+ML_1 (gdk_fontset_load, String_val, Val_GdkFont_no_ref)
+ML_2 (gdk_string_width, GdkFont_val, String_val, Val_int)
+ML_2 (gdk_char_width, GdkFont_val, (gchar)Long_val, Val_int)
+ML_2 (gdk_string_height, GdkFont_val, String_val, Val_int)
+ML_2 (gdk_char_height, GdkFont_val, (gchar)Long_val, Val_int)
+ML_2 (gdk_string_measure, GdkFont_val, String_val, Val_int)
+ML_2 (gdk_char_measure, GdkFont_val, (char)Long_val, Val_int)
+Make_Extractor (GdkFont, GdkFont_val, type, Val_gdkFontType)
+Make_Extractor (GdkFont, GdkFont_val, ascent, Val_int)
+Make_Extractor (GdkFont, GdkFont_val, descent, Val_int)
+
+/* Region */
+
+#define PointArray_val(val) ((GdkPoint*)&Field(val,1))
+#define PointArrayLen_val(val) Int_val(Field(val,0))
+Make_Val_final_pointer (GdkRegion, Ignore, gdk_region_destroy, 0)
+GdkRegion *GdkRegion_val(value val)
+{
+ if (!Field(val,1)) ml_raise_gdk ("attempt to use destroyed GdkRegion");
+ return (GdkRegion*)(Field(val,1));
+}
+value ml_gdk_region_destroy (value val)
+{
+ if (Field(val,1)) gdk_region_destroy((GdkRegion*)(Field(val,1)));
+ Field(val,1) = 0;
+ return Val_unit;
+}
+ML_0 (gdk_region_new, Val_GdkRegion)
+ML_2 (gdk_region_polygon, Insert(PointArray_val(arg1)) PointArrayLen_val,
+ GdkFillRule_val, Val_GdkRegion)
+ML_2 (gdk_regions_intersect, GdkRegion_val, GdkRegion_val, Val_GdkRegion)
+ML_2 (gdk_regions_union, GdkRegion_val, GdkRegion_val, Val_GdkRegion)
+ML_2 (gdk_regions_subtract, GdkRegion_val, GdkRegion_val, Val_GdkRegion)
+ML_2 (gdk_regions_xor, GdkRegion_val, GdkRegion_val, Val_GdkRegion)
+ML_2 (gdk_region_union_with_rect, GdkRegion_val, GdkRectangle_val,
+ Val_GdkRegion)
+ML_3 (gdk_region_offset, GdkRegion_val, Int_val, Int_val, Unit)
+ML_3 (gdk_region_shrink, GdkRegion_val, Int_val, Int_val, Unit)
+ML_1 (gdk_region_empty, GdkRegion_val, Val_bool)
+ML_2 (gdk_region_equal, GdkRegion_val, GdkRegion_val, Val_bool)
+ML_3 (gdk_region_point_in, GdkRegion_val, Int_val, Int_val, Val_bool)
+ML_2 (gdk_region_rect_in, GdkRegion_val, GdkRectangle_val, Val_gdkOverlapType)
+ML_2 (gdk_region_get_clipbox, GdkRegion_val, GdkRectangle_val, Unit)
+
+
+/* GC */
+
+Make_Val_final_pointer (GdkGC, gdk_gc_ref, gdk_gc_unref, 0)
+Make_Val_final_pointer_ext (GdkGC, _no_ref, Ignore, gdk_gc_unref, 20)
+ML_1 (gdk_gc_new, GdkWindow_val, Val_GdkGC_no_ref)
+ML_2 (gdk_gc_set_foreground, GdkGC_val, GdkColor_val, Unit)
+ML_2 (gdk_gc_set_background, GdkGC_val, GdkColor_val, Unit)
+ML_2 (gdk_gc_set_font, GdkGC_val, GdkFont_val, Unit)
+ML_2 (gdk_gc_set_function, GdkGC_val, GdkFunction_val, Unit)
+ML_2 (gdk_gc_set_fill, GdkGC_val, GdkFill_val, Unit)
+ML_2 (gdk_gc_set_tile, GdkGC_val, GdkPixmap_val, Unit)
+ML_2 (gdk_gc_set_stipple, GdkGC_val, GdkPixmap_val, Unit)
+ML_3 (gdk_gc_set_ts_origin, GdkGC_val, Int_val, Int_val, Unit)
+ML_3 (gdk_gc_set_clip_origin, GdkGC_val, Int_val, Int_val, Unit)
+ML_2 (gdk_gc_set_clip_mask, GdkGC_val, GdkBitmap_val, Unit)
+ML_2 (gdk_gc_set_clip_rectangle, GdkGC_val, GdkRectangle_val, Unit)
+ML_2 (gdk_gc_set_clip_region, GdkGC_val, GdkRegion_val, Unit)
+ML_2 (gdk_gc_set_subwindow, GdkGC_val, GdkSubwindowMode_val, Unit)
+ML_2 (gdk_gc_set_exposures, GdkGC_val, Bool_val, Unit)
+ML_5 (gdk_gc_set_line_attributes, GdkGC_val, Int_val, GdkLineStyle_val,
+ GdkCapStyle_val, GdkJoinStyle_val, Unit)
+ML_2 (gdk_gc_copy, GdkGC_val, GdkGC_val, Unit)
+value ml_gdk_gc_get_values (value gc)
+{
+ CAMLparam0();
+ GdkGCValues values;
+ int i;
+ CAMLlocal2(ret, tmp);
+
+ gdk_gc_get_values (GdkGC_val(gc), &values);
+ ret = alloc (18, 0);
+ tmp = Val_copy(values.foreground); Store_field(ret, 0, tmp);
+ tmp = Val_copy(values.background); Store_field(ret, 1, tmp);
+ if (values.font) {
+ tmp = ml_some(Val_GdkFont(values.font));
+ Store_field(ret, 2, tmp);
+ }
+ Field(ret,3) = Val_gdkFunction(values.function);
+ Field(ret,4) = Val_gdkFill(values.fill);
+ if (values.tile) {
+ tmp = ml_some(Val_GdkPixmap(values.tile));
+ Store_field(ret, 5, tmp);
+ }
+ if (values.tile) {
+ tmp = ml_some(Val_GdkPixmap(values.stipple));
+ Store_field(ret, 6, tmp);
+ }
+ if (values.tile) {
+ tmp = ml_some(Val_GdkPixmap(values.clip_mask));
+ Store_field(ret, 7, tmp);
+ }
+ Field(ret,8) = Val_gdkSubwindowMode(values.subwindow_mode);
+ Field(ret,9) = Val_int(values.ts_x_origin);
+ Field(ret,10) = Val_int(values.ts_y_origin);
+ Field(ret,11) = Val_int(values.clip_x_origin);
+ Field(ret,12) = Val_int(values.clip_y_origin);
+ Field(ret,13) = Val_bool(values.graphics_exposures);
+ Field(ret,14) = Val_int(values.line_width);
+ Field(ret,15) = Val_gdkLineStyle(values.line_style);
+ Field(ret,16) = Val_gdkCapStyle(values.cap_style);
+ Field(ret,17) = Val_gdkJoinStyle(values.join_style);
+ CAMLreturn(ret);
+}
+
+/* Draw */
+
+value ml_point_array_new (value len)
+{
+ value ret = alloc (1 + Wosize_asize(Int_val(len)*sizeof(GdkPoint)),
+ Abstract_tag);
+ Field(ret,0) = len;
+ return ret;
+}
+value ml_point_array_set (value arr, value pos, value x, value y)
+{
+ GdkPoint *pt = PointArray_val(arr) + Int_val(pos);
+ pt->x = Int_val(x);
+ pt->y = Int_val(y);
+ return Val_unit;
+}
+
+ML_4 (gdk_draw_point, GdkDrawable_val, GdkGC_val, Int_val, Int_val, Unit)
+ML_6 (gdk_draw_line, GdkDrawable_val, GdkGC_val, Int_val, Int_val,
+ Int_val, Int_val, Unit)
+ML_bc6 (ml_gdk_draw_line)
+ML_7 (gdk_draw_rectangle, GdkDrawable_val, GdkGC_val, Bool_val,
+ Int_val, Int_val, Int_val, Int_val, Unit)
+ML_bc7 (ml_gdk_draw_rectangle)
+ML_9 (gdk_draw_arc, GdkDrawable_val, GdkGC_val, Bool_val, Int_val, Int_val,
+ Int_val, Int_val, Int_val, Int_val, Unit)
+ML_bc9 (ml_gdk_draw_arc)
+ML_4 (gdk_draw_polygon, GdkDrawable_val, GdkGC_val, Bool_val,
+ Insert(PointArray_val(arg4)) PointArrayLen_val, Unit)
+ML_6 (gdk_draw_string, GdkDrawable_val, GdkFont_val, GdkGC_val, Int_val, Int_val, String_val, Unit)
+ML_bc6 (ml_gdk_draw_string)
+
+ML_9 (gdk_draw_image, GdkDrawable_val, GdkGC_val, GdkImage_val, Int_val, Int_val, Int_val, Int_val, Int_val, Int_val, Unit)
+ML_bc9 (ml_gdk_draw_image)
+
+/* RGB */
+
+ML_0 (gdk_rgb_init, Unit)
+ML_0 (gdk_rgb_get_visual, Val_GdkVisual)
+ML_0 (gdk_rgb_get_cmap, Val_GdkColormap)
+
+/* Events */
+
+/* Have a major collection every 1000 events */
+Make_Val_final_pointer (GdkEvent, Ignore, gdk_event_free, 1)
+ML_1 (gdk_event_copy, GdkEvent_val, Val_GdkEvent)
+
+value ml_gdk_event_new (value event_type)
+{
+ GdkEvent event;
+ memset (&event, 0, sizeof(GdkEvent));
+ event.type = GdkEventType_val(event_type);
+ event.any.send_event = TRUE;
+ return Val_copy(event);
+}
+
+#define GdkEvent_arg(type) (GdkEvent##type*)GdkEvent_val
+
+Make_Extractor (GdkEventAny, GdkEvent_arg(Any), type, Val_gdkEventType)
+Make_Extractor (GdkEventAny, GdkEvent_arg(Any), window, Val_GdkWindow)
+Make_Extractor (GdkEventAny, GdkEvent_arg(Any), send_event, Val_bool)
+Make_Setter (gdk_event_set, GdkEvent_arg(Any), GdkEventType_val, type)
+Make_Setter (gdk_event_set, GdkEvent_arg(Any), GdkWindow_val, window)
+
+Make_Extractor (GdkEventExpose, GdkEvent_arg(Expose), area, Val_copy)
+Make_Extractor (GdkEventExpose, GdkEvent_arg(Expose), count, Val_int)
+
+Make_Extractor (GdkEventVisibility, GdkEvent_arg(Visibility), state,
+ Val_gdkVisibilityState)
+
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), time, Val_int)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), x, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), y, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), pressure, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), xtilt, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), ytilt, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), state, Val_int)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), is_hint, Val_int)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), source, Val_gdkInputSource)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), deviceid, Val_int)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), x_root, copy_double)
+Make_Extractor (GdkEventMotion, GdkEvent_arg(Motion), y_root, copy_double)
+
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), time, Val_int)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), x, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), y, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), pressure, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), xtilt, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), ytilt, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), state, Val_int)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), button, Val_int)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), source, Val_gdkInputSource)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), deviceid, Val_int)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), x_root, copy_double)
+Make_Extractor (GdkEventButton, GdkEvent_arg(Button), y_root, copy_double)
+
+Make_Setter (gdk_event_button_set, GdkEvent_arg(Button), Int_val, button)
+
+Make_Extractor (GdkEventKey, GdkEvent_arg(Key), time, Val_int)
+Make_Extractor (GdkEventKey, GdkEvent_arg(Key), state, Val_int)
+Make_Extractor (GdkEventKey, GdkEvent_arg(Key), keyval, Val_int)
+Make_Extractor (GdkEventKey, GdkEvent_arg(Key), string, Val_string)
+
+Make_Extractor (GdkEventCrossing, GdkEvent_arg(Crossing), subwindow,
+ Val_GdkWindow)
+Make_Extractor (GdkEventCrossing, GdkEvent_arg(Crossing), detail,
+ Val_gdkNotifyType)
+
+Make_Extractor (GdkEventFocus, GdkEvent_arg(Focus), in, Val_int)
+
+Make_Extractor (GdkEventConfigure, GdkEvent_arg(Configure), x, Val_int)
+Make_Extractor (GdkEventConfigure, GdkEvent_arg(Configure), y, Val_int)
+Make_Extractor (GdkEventConfigure, GdkEvent_arg(Configure), width, Val_int)
+Make_Extractor (GdkEventConfigure, GdkEvent_arg(Configure), height, Val_int)
+
+Make_Extractor (GdkEventProperty, GdkEvent_arg(Property), atom, Val_int)
+Make_Extractor (GdkEventProperty, GdkEvent_arg(Property), time, Val_int)
+Make_Extractor (GdkEventProperty, GdkEvent_arg(Property), state, Val_int)
+
+Make_Extractor (GdkEventSelection, GdkEvent_arg(Selection), selection, Val_int)
+Make_Extractor (GdkEventSelection, GdkEvent_arg(Selection), target, Val_int)
+Make_Extractor (GdkEventSelection, GdkEvent_arg(Selection), property, Val_int)
+Make_Extractor (GdkEventSelection, GdkEvent_arg(Selection), requestor, Val_int)
+Make_Extractor (GdkEventSelection, GdkEvent_arg(Selection), time, Val_int)
+
+Make_Extractor (GdkEventProximity, GdkEvent_arg(Proximity), time, Val_int)
+Make_Extractor (GdkEventProximity, GdkEvent_arg(Proximity), source,
+ Val_gdkInputSource)
+Make_Extractor (GdkEventProximity, GdkEvent_arg(Proximity), deviceid, Val_int)
+
+/* DnD */
+Make_Val_final_pointer (GdkDragContext, gdk_drag_context_ref, gdk_drag_context_unref, 0)
+Make_Flags_val (GdkDragAction_val)
+ML_3 (gdk_drag_status, GdkDragContext_val, Flags_GdkDragAction_val, Int_val, Unit)
+Make_Extractor (GdkDragContext, GdkDragContext_val, suggested_action, Val_gdkDragAction)
+value val_int(gpointer i)
+{
+ return Val_int (GPOINTER_TO_INT(i));
+}
+value ml_GdkDragContext_targets (value c)
+{
+ GList *t;
+
+ t = (GdkDragContext_val(c))->targets;
+ return Val_GList (t, val_int);
+}
+
+/* Misc */
+ML_0 (gdk_flush, Unit)
+ML_0 (gdk_beep, Unit)
--- /dev/null
+/* $Id$ */
+
+#define GdkColormap_val(val) ((GdkColormap*)Pointer_val(val))
+extern value Val_GdkColormap (GdkColormap *);
+
+#define GdkColor_val(val) ((GdkColor*)MLPointer_val(val))
+#define Val_GdkColor Val_pointer
+
+#define GdkRectangle_val(val) ((GdkRectangle*)MLPointer_val(val))
+#define Val_GdkRectangle Val_pointer
+
+#define GdkDrawable_val(val) ((GdkDrawable*)Pointer_val(val))
+
+#define GdkWindow_val(val) ((GdkWindow*)Pointer_val(val))
+extern value Val_GdkWindow (GdkWindow *);
+
+#define GdkCursor_val(val) ((GdkCursor*)Pointer_val(val))
+#define Val_GdkCursor Val_pointer
+
+#define GdkPixmap_val(val) ((GdkPixmap*)Pointer_val(val))
+extern value Val_GdkPixmap (GdkPixmap *);
+
+#define GdkBitmap_val(val) ((GdkBitmap*)Pointer_val(val))
+extern value Val_GdkBitmap (GdkBitmap *);
+
+extern GdkImage *GdkImage_val (value); /* check argument */
+extern value Val_GdkImage (GdkImage *); /* finalizer is destroy! */
+
+#define GdkFont_val(val) ((GdkFont*)Pointer_val(val))
+extern value Val_GdkFont (GdkFont *);
+
+extern GdkRegion *GdkRegion_val (value); /* check argument */
+extern value Val_GdkRegion (GdkRegion *); /* finalizer is destroy! */
+
+#define GdkGC_val(val) ((GdkGC*)Pointer_val(val))
+extern value Val_GdkGC (GdkGC *);
+
+#define GdkEvent_val (GdkEvent*)MLPointer_val
+
+#define GdkVisual_val(val) ((GdkVisual*) val)
+#define Val_GdkVisual(visual) ((value) visual)
+
+#define Val_XID copy_int32
+#define XID_val Int32_val
+
+extern int OptFlags_GdkModifier_val (value);
+extern int Flags_Event_mask_val (value);
+extern lookup_info ml_table_extension_events[];
+#define Extension_events_val(key) ml_lookup_to_c (ml_table_extension_events, key)
+
+#define GdkDragContext_val(val) ((GdkDragContext*)Pointer_val(val))
+extern value Val_GdkDragContext (GdkDragContext *);
+extern int Flags_GdkDragAction_val (value);
--- /dev/null
+/* $Id$ */
+
+#include <glib.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+
+value copy_string_and_free (char *str)
+{
+ value res;
+ res = copy_string_check (str);
+ g_free (str);
+ return res;
+}
+
+value Val_GList (GList *list, value (*func)(gpointer))
+{
+ value new_cell, result, last_cell, cell;
+
+ if (list == NULL) return Val_unit;
+
+ last_cell = cell = Val_unit;
+ result = func(list->data);
+ Begin_roots3 (last_cell, cell, result);
+ cell = last_cell = alloc_small(2,0);
+ Field(cell,0) = result;
+ Field(cell,1) = Val_unit;
+ list = list->next;
+ while (list != NULL) {
+ result = func(list->data);
+ new_cell = alloc_small(2,0);
+ Field(new_cell,0) = result;
+ Field(new_cell,1) = Val_unit;
+ modify(&Field(last_cell,1), new_cell);
+ last_cell = new_cell;
+ list = list->next;
+ }
+ End_roots ();
+ return cell;
+}
+
+GList *GList_val (value list, gpointer (*func)(value))
+{
+ CAMLparam1(list);
+ GList *res = NULL;
+ if (list == Val_unit) CAMLreturn (res);
+ for (; Is_block(list); list = Field(list,1))
+ res = g_list_append (res, func(Field(list,0)));
+ CAMLreturn (res);
+}
+
+static value ml_warning_handler = 0L;
+
+static void ml_warning_wrapper (const gchar *msg)
+{
+ value arg = copy_string ((char*)msg);
+ callback (ml_warning_handler, arg);
+}
+
+value ml_g_set_warning_handler (value clos)
+{
+ value old_handler = ml_warning_handler ? ml_warning_handler : clos;
+ if (!ml_warning_handler) register_global_root (&ml_warning_handler);
+ g_set_warning_handler (ml_warning_wrapper);
+ ml_warning_handler = clos;
+ return old_handler;
+}
+
+static value ml_print_handler = 0L;
+
+static void ml_print_wrapper (const gchar *msg)
+{
+ value arg = copy_string ((char*)msg);
+ callback (ml_print_handler, arg);
+}
+
+value ml_g_set_print_handler (value clos)
+{
+ value old_handler = ml_print_handler ? ml_print_handler : clos;
+ if (!ml_print_handler) register_global_root (&ml_print_handler);
+ g_set_print_handler (ml_print_wrapper);
+ ml_print_handler = clos;
+ return old_handler;
+}
+
+value ml_get_null (value unit) { return 0L; }
+
+#define GMainLoop_val(val) ((GMainLoop*)Addr_val(val))
+ML_1 (g_main_new, Bool_val, Val_addr)
+ML_1 (g_main_iteration, Bool_val, Val_bool)
+ML_0 (g_main_pending, Val_bool)
+ML_1 (g_main_is_running, GMainLoop_val, Val_bool)
+ML_1 (g_main_quit, GMainLoop_val, Unit)
+ML_1 (g_main_destroy, GMainLoop_val, Unit)
+
+/*
+value Val_GSList (GSList *list, value (*func)(gpointer))
+{
+ value new_cell, result, last_cell, cell;
+
+ if (list == NULL) return Val_unit;
+
+ last_cell = cell = Val_unit;
+ result = func(list->data);
+ Begin_roots3 (last_cell, cell, result);
+ cell = last_cell = alloc_tuple (2);
+ Field(cell,0) = result;
+ Field(cell,1) = Val_unit;
+ list = list->next;
+ while (list != NULL) {
+ result = func(list->data);
+ new_cell = alloc_tuple(2);
+ Field(new_cell,0) = result;
+ Field(new_cell,1) = Val_unit;
+ modify(&Field(last_cell,1), new_cell);
+ last_cell = new_cell;
+ list = list->next;
+ }
+ End_roots ();
+ return cell;
+}
+
+GSList *GSList_val (value list, gpointer (*func)(value))
+{
+ GSList *res = NULL;
+ GSList **current = &res;
+ value cell = list;
+ if (list == Val_unit) return res;
+ Begin_root (cell);
+ while (cell != Val_unit) {
+ *current = g_slist_alloc ();
+ (*current)->data = func(Field(cell,0));
+ cell = Field(cell,1);
+ current = &(*current)->next;
+ }
+ End_roots ();
+ return res;
+}
+*/
--- /dev/null
+/* $Id$ */
+
+value copy_string_and_free (char *str); /* for g_strings only */
+value Val_GList (GList *list, value (*func)(gpointer));
+GList *GList_val (value list, gpointer (*func)(value));
+
+/*
+value Val_GSList (GSList *list, value (*func)(gpointer));
+GSList *GSList_val (value list, gpointer (*func)(value));
+*/
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+void ml_raise_gtk (const char *errmsg)
+{
+ static value * exn = NULL;
+ if (exn == NULL)
+ exn = caml_named_value ("gtkerror");
+ raise_with_string (*exn, (char*)errmsg);
+}
+
+/* conversion functions */
+
+#include "gtk_tags.c"
+
+ML_1 (Val_direction_type, Int_val, Id)
+ML_1 (Val_orientation, Int_val, Id)
+ML_1 (Val_toolbar_style, Int_val, Id)
+ML_1 (Val_state_type, Int_val, Id)
+ML_1 (Val_scroll_type, Int_val, Id)
+
+static Make_Flags_val (Dest_defaults_val)
+static Make_Flags_val (Target_flags_val)
+static Make_Flags_val (Font_type_val)
+
+/* gtkobject.h */
+
+Make_Val_final_pointer(GtkObject, gtk_object_ref, gtk_object_unref, 0)
+
+#define gtk_object_ref_and_sink(w) (gtk_object_ref(w), gtk_object_sink(w))
+Make_Val_final_pointer_ext(GtkObject, _sink , gtk_object_ref_and_sink,
+ gtk_object_unref, 20)
+
+/* gtkaccelgroup.h */
+
+Make_Val_final_pointer (GtkAccelGroup, gtk_accel_group_ref,
+ gtk_accel_group_unref, 0)
+Make_Val_final_pointer_ext (GtkAccelGroup, _no_ref, Ignore,
+ gtk_accel_group_unref, 20)
+Make_OptFlags_val (Accel_flag_val)
+
+#define Signal_name_val(val) String_val(Field(val,0))
+
+ML_0 (gtk_accel_group_new, Val_GtkAccelGroup_no_ref)
+ML_0 (gtk_accel_group_get_default, Val_GtkAccelGroup)
+ML_3 (gtk_accel_group_activate, GtkAccelGroup_val, Int_val,
+ OptFlags_GdkModifier_val, Val_bool)
+ML_3 (gtk_accel_groups_activate, GtkObject_val, Int_val,
+ OptFlags_GdkModifier_val, Val_bool)
+ML_2 (gtk_accel_group_attach, GtkAccelGroup_val, GtkObject_val, Unit)
+ML_2 (gtk_accel_group_detach, GtkAccelGroup_val, GtkObject_val, Unit)
+ML_1 (gtk_accel_group_lock, GtkAccelGroup_val, Unit)
+ML_1 (gtk_accel_group_unlock, GtkAccelGroup_val, Unit)
+ML_3 (gtk_accel_group_lock_entry, GtkAccelGroup_val, Int_val,
+ OptFlags_GdkModifier_val, Unit)
+ML_3 (gtk_accel_group_unlock_entry, GtkAccelGroup_val, Int_val,
+ OptFlags_GdkModifier_val, Unit)
+ML_6 (gtk_accel_group_add, GtkAccelGroup_val, Int_val,
+ OptFlags_GdkModifier_val, OptFlags_Accel_flag_val,
+ GtkObject_val, Signal_name_val, Unit)
+ML_bc6 (ml_gtk_accel_group_add)
+ML_4 (gtk_accel_group_remove, GtkAccelGroup_val, Int_val,
+ OptFlags_GdkModifier_val, GtkObject_val, Unit)
+ML_2 (gtk_accelerator_valid, Int_val, OptFlags_GdkModifier_val, Val_bool)
+ML_1 (gtk_accelerator_set_default_mod_mask, OptFlags_GdkModifier_val, Unit)
+
+/* gtkstyle.h */
+
+Make_Val_final_pointer (GtkStyle, gtk_style_ref, gtk_style_unref, 0)
+Make_Val_final_pointer_ext (GtkStyle, _no_ref, Ignore, gtk_style_unref, 20)
+ML_0 (gtk_style_new, Val_GtkStyle_no_ref)
+ML_1 (gtk_style_copy, GtkStyle_val, Val_GtkStyle_no_ref)
+ML_2 (gtk_style_attach, GtkStyle_val, GdkWindow_val, Val_GtkStyle)
+ML_1 (gtk_style_detach, GtkStyle_val, Unit)
+ML_3 (gtk_style_set_background, GtkStyle_val, GdkWindow_val, State_type_val, Unit)
+ML_6 (gtk_draw_hline, GtkStyle_val, GdkWindow_val, State_type_val,
+ Int_val, Int_val, Int_val, Unit)
+ML_bc6 (ml_gtk_draw_hline)
+ML_6 (gtk_draw_vline, GtkStyle_val, GdkWindow_val, State_type_val,
+ Int_val, Int_val, Int_val, Unit)
+ML_bc6 (ml_gtk_draw_vline)
+Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val, bg, Val_copy)
+Make_Array_Setter (gtk_style_set, GtkStyle_val, State_type_val, *GdkColor_val, bg)
+Make_Extractor (gtk_style_get, GtkStyle_val, colormap, Val_GdkColormap)
+Make_Extractor (gtk_style_get, GtkStyle_val, depth, Val_int)
+Make_Extractor (gtk_style_get, GtkStyle_val, font, Val_GdkFont)
+/* Make_Setter (gtk_style_set, GtkStyle_val, GdkFont_val, font) */
+value ml_gtk_style_set_font (value st, value font)
+{
+ GtkStyle *style = GtkStyle_val(st);
+ if (style->font) gdk_font_unref(style->font);
+ style->font = GdkFont_val(font);
+ gdk_font_ref(style->font);
+ return Val_unit;
+}
+Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val, dark_gc, Val_GdkGC)
+Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val, light_gc, Val_GdkGC)
+
+/* gtktypeutils.h */
+
+ML_1 (gtk_type_name, Int_val, Val_string)
+ML_1 (gtk_type_from_name, String_val, Val_int)
+ML_1 (gtk_type_parent, Int_val, Val_int)
+ML_1 (gtk_type_class, Int_val, (value))
+ML_1 (gtk_type_parent_class, Int_val, (value))
+ML_2 (gtk_type_is_a, Int_val, Int_val, Val_bool)
+value ml_gtk_type_fundamental (value type)
+{
+ return Val_fundamental_type (GTK_FUNDAMENTAL_TYPE (Int_val(type)));
+}
+
+/* gtkobject.h */
+
+/* ML_1 (GTK_OBJECT_TYPE, GtkObject_val, Val_int) */
+value ml_gtk_object_type (value val)
+{
+ return Val_int (GtkObject_val(val)->klass->type);
+}
+
+ML_1 (gtk_object_destroy, GtkObject_val, Unit)
+ML_1 (gtk_object_ref, GtkObject_val, Unit)
+ML_1 (gtk_object_unref, GtkObject_val, Unit)
+ML_1 (gtk_object_sink, GtkObject_val, Unit)
+
+Make_Extractor (gtk_class,(GtkObjectClass *),type,Val_int)
+
+/* gtkdata.h */
+
+/* gtkadjustment.h */
+
+ML_6 (gtk_adjustment_new, Float_val, Float_val, Float_val, Float_val,
+ Float_val, Float_val, Val_GtkObject_sink)
+ML_bc6 (ml_gtk_adjustment_new)
+ML_2 (gtk_adjustment_set_value, GtkAdjustment_val, Float_val, Unit)
+ML_3 (gtk_adjustment_clamp_page, GtkAdjustment_val,
+ Float_val, Float_val, Unit)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, lower, copy_double)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, upper, copy_double)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, value, copy_double)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, step_increment,
+ copy_double)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, page_increment,
+ copy_double)
+Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, page_size, copy_double)
+
+/* gtktooltips.h */
+
+#define GtkTooltips_val(val) check_cast(GTK_TOOLTIPS,val)
+ML_0 (gtk_tooltips_new, Val_GtkAny)
+ML_1 (gtk_tooltips_enable, GtkTooltips_val, Unit)
+ML_1 (gtk_tooltips_disable, GtkTooltips_val, Unit)
+ML_2 (gtk_tooltips_set_delay, GtkTooltips_val, Int_val, Unit)
+ML_4 (gtk_tooltips_set_tip, GtkTooltips_val, GtkWidget_val,
+ String_option_val, String_option_val, Unit)
+ML_3 (gtk_tooltips_set_colors, GtkTooltips_val,
+ Option_val(arg2, GdkColor_val, NULL) Ignore,
+ Option_val(arg3, GdkColor_val, NULL) Ignore,
+ Unit)
+
+/* gtkwidget.h */
+
+value ml_gtk_widget_set_can_default (value val, value bool)
+{
+ GtkWidget *w = GtkWidget_val(val);
+ guint32 saved_flags = GTK_WIDGET_FLAGS(w);
+ if (Bool_val(bool)) GTK_WIDGET_SET_FLAGS(w, GTK_CAN_DEFAULT);
+ else GTK_WIDGET_UNSET_FLAGS(w, GTK_CAN_DEFAULT);
+ if (saved_flags != GTK_WIDGET_FLAGS(w))
+ gtk_widget_queue_resize (w);
+ return Val_unit;
+}
+value ml_gtk_widget_set_can_focus (value val, value bool)
+{
+ GtkWidget *w = GtkWidget_val(val);
+ guint32 saved_flags = GTK_WIDGET_FLAGS(w);
+ if (Bool_val(bool)) GTK_WIDGET_SET_FLAGS(w, GTK_CAN_FOCUS);
+ else GTK_WIDGET_UNSET_FLAGS(w, GTK_CAN_FOCUS);
+ if (saved_flags != GTK_WIDGET_FLAGS(w))
+ gtk_widget_queue_resize (w);
+ return Val_unit;
+}
+ML_1 (gtk_widget_unparent, GtkWidget_val, Unit)
+ML_1 (gtk_widget_show, GtkWidget_val, Unit)
+ML_1 (gtk_widget_show_now, GtkWidget_val, Unit)
+ML_1 (gtk_widget_show_all, GtkWidget_val, Unit)
+ML_1 (gtk_widget_hide, GtkWidget_val, Unit)
+ML_1 (gtk_widget_hide_all, GtkWidget_val, Unit)
+ML_1 (gtk_widget_map, GtkWidget_val, Unit)
+ML_1 (gtk_widget_unmap, GtkWidget_val, Unit)
+ML_1 (gtk_widget_realize, GtkWidget_val, Unit)
+ML_1 (gtk_widget_unrealize, GtkWidget_val, Unit)
+ML_1 (gtk_widget_queue_draw, GtkWidget_val, Unit)
+ML_1 (gtk_widget_queue_resize, GtkWidget_val, Unit)
+ML_2 (gtk_widget_draw, GtkWidget_val,
+ Option_val(arg2,GdkRectangle_val,NULL) Ignore, Unit)
+ML_1 (gtk_widget_draw_focus, GtkWidget_val, Unit)
+ML_1 (gtk_widget_draw_default, GtkWidget_val, Unit)
+/* ML_1 (gtk_widget_draw_children, GtkWidget_val, Unit) */
+ML_2 (gtk_widget_event, GtkWidget_val, GdkEvent_val, Val_bool)
+ML_1 (gtk_widget_activate, GtkWidget_val, Val_bool)
+ML_2 (gtk_widget_reparent, GtkWidget_val, GtkWidget_val, Unit)
+ML_3 (gtk_widget_popup, GtkWidget_val, Int_val, Int_val, Unit)
+value ml_gtk_widget_intersect (value w, value area)
+{
+ GdkRectangle inter;
+ if (gtk_widget_intersect(GtkWidget_val(w), GdkRectangle_val(area), &inter))
+ return ml_some (Val_copy (inter));
+ return Val_unit;
+}
+/* ML_1 (gtk_widget_basic, GtkWidget_val, Val_bool) */
+ML_1 (gtk_widget_grab_focus, GtkWidget_val, Unit)
+ML_1 (gtk_widget_grab_default, GtkWidget_val, Unit)
+ML_2 (gtk_widget_set_name, GtkWidget_val, String_val, Unit)
+ML_1 (gtk_widget_get_name, GtkWidget_val, Val_string)
+ML_2 (gtk_widget_set_state, GtkWidget_val, State_type_val, Unit)
+ML_2 (gtk_widget_set_sensitive, GtkWidget_val, Bool_val, Unit)
+ML_3 (gtk_widget_set_uposition, GtkWidget_val, Int_val, Int_val, Unit)
+ML_3 (gtk_widget_set_usize, GtkWidget_val, Int_val, Int_val, Unit)
+ML_2 (gtk_widget_add_events, GtkWidget_val, Flags_Event_mask_val, Unit)
+ML_2 (gtk_widget_set_events, GtkWidget_val, Flags_Event_mask_val, Unit)
+ML_2 (gtk_widget_set_extension_events, GtkWidget_val, Extension_events_val,
+ Unit)
+ML_1 (gtk_widget_get_toplevel, GtkWidget_val, Val_GtkWidget)
+ML_2 (gtk_widget_get_ancestor, GtkWidget_val, Int_val, Val_GtkWidget)
+ML_1 (gtk_widget_get_colormap, GtkWidget_val, Val_GdkColormap)
+ML_1 (gtk_widget_get_visual, GtkWidget_val, (value))
+value ml_gtk_widget_get_pointer (value w)
+{
+ int x,y;
+ value ret;
+ gtk_widget_get_pointer (GtkWidget_val(w), &x, &y);
+ ret = alloc_small (2,0);
+ Field(ret,0) = Val_int(x);
+ Field(ret,1) = Val_int(y);
+ return ret;
+}
+ML_2 (gtk_widget_is_ancestor, GtkWidget_val, GtkWidget_val, Val_bool)
+/* ML_2 (gtk_widget_is_child, GtkWidget_val, GtkWidget_val, Val_bool) */
+ML_2 (gtk_widget_set_style, GtkWidget_val, GtkStyle_val, Unit)
+ML_1 (gtk_widget_set_rc_style, GtkWidget_val, Unit)
+ML_1 (gtk_widget_ensure_style, GtkWidget_val, Unit)
+ML_1 (gtk_widget_get_style, GtkWidget_val, Val_GtkStyle)
+ML_1 (gtk_widget_restore_default_style, GtkWidget_val, Unit)
+
+ML_6 (gtk_widget_add_accelerator, GtkWidget_val, Signal_name_val,
+ GtkAccelGroup_val, Char_val, OptFlags_GdkModifier_val,
+ OptFlags_Accel_flag_val, Unit)
+ML_bc6 (ml_gtk_widget_add_accelerator)
+ML_4 (gtk_widget_remove_accelerator, GtkWidget_val, GtkAccelGroup_val,
+ Char_val, OptFlags_GdkModifier_val, Unit)
+ML_1 (gtk_widget_lock_accelerators, GtkWidget_val, Unit)
+ML_1 (gtk_widget_unlock_accelerators, GtkWidget_val, Unit)
+ML_1 (gtk_widget_accelerators_locked, GtkWidget_val, Val_bool)
+
+ML_1 (GTK_WIDGET_VISIBLE, GtkWidget_val, Val_bool)
+ML_1 (GTK_WIDGET_HAS_FOCUS, GtkWidget_val, Val_bool)
+
+Make_Extractor (GtkWidget, GtkWidget_val, window, Val_GdkWindow)
+Make_Extractor (gtk_widget, GtkWidget_val, parent, Val_GtkWidget)
+static value Val_GtkAllocation (GtkAllocation allocation)
+{
+ value ret = alloc_small (4, 0);
+ Field(ret,0) = Val_int(allocation.x);
+ Field(ret,1) = Val_int(allocation.y);
+ Field(ret,2) = Val_int(allocation.width);
+ Field(ret,3) = Val_int(allocation.height);
+ return ret;
+}
+Make_Extractor (gtk_widget, GtkWidget_val, allocation, Val_GtkAllocation)
+/*
+#define GtkAllocation_val(val) ((GtkAllocation*)Pointer_val(val))
+Make_Extractor (gtk_allocation, GtkAllocation_val, x, Val_int)
+Make_Extractor (gtk_allocation, GtkAllocation_val, y, Val_int)
+Make_Extractor (gtk_allocation, GtkAllocation_val, width, Val_int)
+Make_Extractor (gtk_allocation, GtkAllocation_val, height, Val_int)
+*/
+
+ML_2 (gtk_widget_set_app_paintable, GtkWidget_val, Bool_val, Unit)
+
+ML_2 (gtk_widget_set_visual, GtkWidget_val, GdkVisual_val, Unit)
+ML_2 (gtk_widget_set_colormap, GtkWidget_val, GdkColormap_val, Unit)
+ML_1 (gtk_widget_set_default_visual, GdkVisual_val, Unit)
+ML_1 (gtk_widget_set_default_colormap, GdkColormap_val, Unit)
+ML_0 (gtk_widget_get_default_visual, Val_GdkVisual)
+ML_0 (gtk_widget_get_default_colormap, Val_GdkColormap)
+ML_1 (gtk_widget_push_visual, GdkVisual_val, Unit)
+ML_1 (gtk_widget_push_colormap, GdkColormap_val, Unit)
+ML_0 (gtk_widget_pop_visual, Unit)
+ML_0 (gtk_widget_pop_colormap, Unit)
+
+/* gtkdnd.h */
+
+value ml_gtk_drag_dest_set (value w, value f, value t, value a)
+{
+ GtkTargetEntry *targets = (GtkTargetEntry *)Val_unit;
+ int n_targets, i;
+
+ CAMLparam4 (w,f,t,a);
+ n_targets = Wosize_val(t);
+ if (n_targets)
+ targets = (GtkTargetEntry *)
+ alloc (Wosize_asize(n_targets * sizeof(GtkTargetEntry)),
+ Abstract_tag);
+ for (i=0; i<n_targets; i++) {
+ targets[i].target = String_val(Field(Field(t, i), 0));
+ targets[i].flags = Flags_Target_flags_val(Field(Field(t, i), 1));
+ targets[i].info = Int_val(Field(Field(t, i), 2));
+ }
+ gtk_drag_dest_set (GtkWidget_val(w), Flags_Dest_defaults_val(f),
+ targets, n_targets, Flags_GdkDragAction_val(a));
+ CAMLreturn(Val_unit);
+}
+ML_1 (gtk_drag_dest_unset, GtkWidget_val, Unit)
+ML_4 (gtk_drag_finish, GdkDragContext_val, Bool_val, Bool_val, Int_val, Unit)
+ML_4 (gtk_drag_get_data, GtkWidget_val, GdkDragContext_val, Int_val, Int_val, Unit)
+ML_1 (gtk_drag_get_source_widget, GdkDragContext_val, Val_GtkWidget)
+ML_1 (gtk_drag_highlight, GtkWidget_val, Unit)
+ML_1 (gtk_drag_unhighlight, GtkWidget_val, Unit)
+ML_4 (gtk_drag_set_icon_widget, GdkDragContext_val, GtkWidget_val,
+ Int_val, Int_val, Unit)
+ML_6 (gtk_drag_set_icon_pixmap, GdkDragContext_val, GdkColormap_val,
+ GdkPixmap_val, Option_val(arg4, GdkBitmap_val, NULL) Ignore,
+ Int_val, Int_val, Unit)
+ML_bc6 (ml_gtk_drag_set_icon_pixmap)
+ML_1 (gtk_drag_set_icon_default, GdkDragContext_val, Unit)
+ML_5 (gtk_drag_set_default_icon, GdkColormap_val,
+ GdkPixmap_val, Option_val(arg3, GdkBitmap_val, NULL) Ignore,
+ Int_val, Int_val, Unit)
+value ml_gtk_drag_source_set (value w, value m, value t, value a)
+{
+ GtkTargetEntry *targets = (GtkTargetEntry *)Val_unit;
+ int n_targets, i;
+ CAMLparam4 (w,m,t,a);
+
+ n_targets = Wosize_val(t);
+ if (n_targets)
+ targets = (GtkTargetEntry *)
+ alloc (Wosize_asize(n_targets * sizeof(GtkTargetEntry)),
+ Abstract_tag);
+ for (i=0; i<n_targets; i++) {
+ targets[i].target = String_val(Field(Field(t, i), 0));
+ targets[i].flags = Flags_Target_flags_val(Field(Field(t, i), 1));
+ targets[i].info = Int_val(Field(Field(t, i), 2));
+ }
+ gtk_drag_source_set (GtkWidget_val(w), OptFlags_GdkModifier_val(m),
+ targets, n_targets, Flags_GdkDragAction_val(a));
+ CAMLreturn(Val_unit);
+}
+ML_4 (gtk_drag_source_set_icon, GtkWidget_val, GdkColormap_val,
+ GdkPixmap_val, Option_val(arg4, GdkBitmap_val, NULL) Ignore, Unit)
+ML_1 (gtk_drag_source_unset, GtkWidget_val, Unit)
+
+/* gtkwidget.h / gtkselection.h */
+
+#define GtkSelectionData_val(val) ((GtkSelectionData *)Pointer_val(val))
+
+Make_Extractor (gtk_selection_data, GtkSelectionData_val, selection, Val_int)
+Make_Extractor (gtk_selection_data, GtkSelectionData_val, target, Val_int)
+Make_Extractor (gtk_selection_data, GtkSelectionData_val, type, Val_int)
+Make_Extractor (gtk_selection_data, GtkSelectionData_val, format, Val_int)
+value ml_gtk_selection_data_get_data (value val)
+{
+ value ret;
+ GtkSelectionData *data = GtkSelectionData_val(val);
+
+ if (data->length < 0) ml_raise_null_pointer();
+ ret = alloc_string (data->length);
+ if (data->length) memcpy ((void*)ret, data->data, data->length);
+ return ret;
+}
+
+ML_4 (gtk_selection_data_set, GtkSelectionData_val, Int_val, Int_val,
+ Insert((guchar*)String_option_val(arg4))
+ Option_val(arg4, string_length, -1) Ignore,
+ Unit)
+
+/* gtkcontainer.h */
+
+#define GtkContainer_val(val) check_cast(GTK_CONTAINER,val)
+ML_2 (gtk_container_set_border_width, GtkContainer_val, Int_val, Unit)
+ML_2 (gtk_container_set_resize_mode, GtkContainer_val, Resize_mode_val, Unit)
+ML_2 (gtk_container_add, GtkContainer_val, GtkWidget_val, Unit)
+ML_2 (gtk_container_remove, GtkContainer_val, GtkWidget_val, Unit)
+static void ml_gtk_simple_callback (GtkWidget *w, gpointer data)
+{
+ value val, *clos = (value*)data;
+ val = Val_GtkWidget(w);
+ callback (*clos, val);
+}
+value ml_gtk_container_foreach (value w, value clos)
+{
+ CAMLparam1(clos);
+ gtk_container_foreach (GtkContainer_val(w), ml_gtk_simple_callback,
+ &clos);
+ CAMLreturn(Val_unit);
+}
+ML_1 (gtk_container_register_toplevel, GtkContainer_val, Unit)
+ML_1 (gtk_container_unregister_toplevel, GtkContainer_val, Unit)
+ML_2 (gtk_container_focus, GtkContainer_val, Direction_type_val, Val_bool)
+ML_2 (gtk_container_set_focus_child, GtkContainer_val, GtkWidget_val, Unit)
+ML_2 (gtk_container_set_focus_vadjustment, GtkContainer_val,
+ GtkAdjustment_val, Unit)
+ML_2 (gtk_container_set_focus_hadjustment, GtkContainer_val,
+ GtkAdjustment_val, Unit)
+
+/* gtkdialog.h */
+
+static void window_unref (GtkObject *w)
+{
+ /* If the window exists and is still not visible, then unreference twice.
+ This should be enough to destroy it. */
+ if (!GTK_OBJECT_DESTROYED(w) && !GTK_WIDGET_VISIBLE(w))
+ gtk_object_unref (w);
+ gtk_object_unref (w);
+}
+Make_Val_final_pointer_ext (GtkObject, _window, gtk_object_ref, window_unref,
+ 20)
+#define Val_GtkWidget_window(w) Val_GtkObject_window((GtkObject*)w)
+
+#define GtkDialog_val(val) check_cast(GTK_DIALOG,val)
+ML_0 (gtk_dialog_new, Val_GtkWidget_window)
+Make_Extractor (GtkDialog, GtkDialog_val, action_area, Val_GtkWidget)
+Make_Extractor (GtkDialog, GtkDialog_val, vbox, Val_GtkWidget)
+
+/* gtkinputdialog.h */
+
+ML_0 (gtk_input_dialog_new, Val_GtkWidget_window)
+
+/* gtkfileselection.h */
+
+#define GtkFileSelection_val(val) check_cast(GTK_FILE_SELECTION,val)
+ML_1 (gtk_file_selection_new, String_val, Val_GtkWidget_window)
+ML_2 (gtk_file_selection_set_filename, GtkFileSelection_val, String_val, Unit)
+ML_1 (gtk_file_selection_get_filename, GtkFileSelection_val, Val_string)
+ML_1 (gtk_file_selection_show_fileop_buttons, GtkFileSelection_val, Unit)
+ML_1 (gtk_file_selection_hide_fileop_buttons, GtkFileSelection_val, Unit)
+Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, ok_button,
+ Val_GtkWidget)
+Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, cancel_button,
+ Val_GtkWidget)
+Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, help_button,
+ Val_GtkWidget)
+
+/* gtkwindow.h */
+
+#define GtkWindow_val(val) check_cast(GTK_WINDOW,val)
+ML_1 (gtk_window_new, Window_type_val, Val_GtkWidget_window)
+ML_2 (gtk_window_set_title, GtkWindow_val, String_val, Unit)
+ML_3 (gtk_window_set_wmclass, GtkWindow_val, String_val, String_val, Unit)
+Make_Extractor (gtk_window_get, GtkWindow_val, wmclass_name, Val_optstring)
+Make_Extractor (gtk_window_get, GtkWindow_val, wmclass_class, Val_optstring)
+ML_2 (gtk_window_set_focus, GtkWindow_val, GtkWidget_val, Unit)
+ML_2 (gtk_window_set_default, GtkWindow_val, GtkWidget_val, Unit)
+ML_4 (gtk_window_set_policy, GtkWindow_val, Bool_val, Bool_val, Bool_val, Unit)
+Make_Extractor (gtk_window_get, GtkWindow_val, allow_shrink, Val_bool)
+Make_Extractor (gtk_window_get, GtkWindow_val, allow_grow, Val_bool)
+Make_Extractor (gtk_window_get, GtkWindow_val, auto_shrink, Val_bool)
+ML_2 (gtk_window_add_accel_group, GtkWindow_val,
+ GtkAccelGroup_val, Unit)
+ML_2 (gtk_window_remove_accel_group, GtkWindow_val,
+ GtkAccelGroup_val, Unit)
+ML_1 (gtk_window_activate_focus, GtkWindow_val, Val_bool)
+ML_1 (gtk_window_activate_default, GtkWindow_val, Val_bool)
+ML_2 (gtk_window_set_modal, GtkWindow_val, Bool_val, Unit)
+ML_3 (gtk_window_set_default_size, GtkWindow_val, Int_val, Int_val, Unit)
+ML_2 (gtk_window_set_position, GtkWindow_val, Window_position_val, Unit)
+ML_2 (gtk_window_set_transient_for, GtkWindow_val, GtkWindow_val, Unit)
+
+/* gtkcolorsel.h */
+
+#define GtkColorSelection_val(val) check_cast(GTK_COLOR_SELECTION,val)
+#define GtkColorSelectionDialog_val(val) check_cast(GTK_COLOR_SELECTION_DIALOG,val)
+ML_0 (gtk_color_selection_new, Val_GtkWidget_sink)
+ML_2 (gtk_color_selection_set_update_policy, GtkColorSelection_val,
+ Update_type_val, Unit)
+ML_2 (gtk_color_selection_set_opacity, GtkColorSelection_val,
+ Bool_val, Unit)
+value ml_gtk_color_selection_set_color (value w, value red, value green,
+ value blue, value opacity)
+{
+ double color[4];
+ color[0] = Double_val(red);
+ color[1] = Double_val(green);
+ color[2] = Double_val(blue);
+ color[3] = Option_val(opacity,Double_val,0.0);
+ gtk_color_selection_set_color (GtkColorSelection_val(w), color);
+ return Val_unit;
+}
+value ml_gtk_color_selection_get_color (value w)
+{
+ value ret;
+ double color[4];
+ color[3] = 0.0;
+ gtk_color_selection_get_color (GtkColorSelection_val(w), color);
+ ret = alloc (4*Double_wosize, Double_array_tag);
+ Store_double_field (ret, 0, color[0]);
+ Store_double_field (ret, 1, color[1]);
+ Store_double_field (ret, 2, color[2]);
+ Store_double_field (ret, 3, color[3]);
+ return ret;
+}
+ML_1 (gtk_color_selection_dialog_new, String_val, Val_GtkWidget_window)
+Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, ok_button, Val_GtkWidget)
+Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, cancel_button, Val_GtkWidget)
+Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, help_button, Val_GtkWidget)
+Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, colorsel, Val_GtkWidget)
+
+/* gtkfontsel.h */
+
+#define GtkFontSelection_val(val) \
+ check_cast(GTK_FONT_SELECTION,val)
+ML_0 (gtk_font_selection_new, Val_GtkWidget_sink)
+ML_1 (gtk_font_selection_get_font, GtkFontSelection_val,
+ Val_GdkFont)
+ML_1 (gtk_font_selection_get_font_name, GtkFontSelection_val,
+ copy_string_check)
+ML_2 (gtk_font_selection_set_font_name, GtkFontSelection_val,
+ String_val, Val_bool)
+ML_9 (gtk_font_selection_set_filter, GtkFontSelection_val,
+ Font_filter_type_val, Flags_Font_type_val,
+ (gchar**), (gchar**), (gchar**),
+ (gchar**), (gchar**), (gchar**), Unit)
+ML_bc9 (ml_gtk_font_selection_set_filter)
+ML_1 (gtk_font_selection_get_preview_text, GtkFontSelection_val,
+ copy_string)
+ML_2 (gtk_font_selection_set_preview_text, GtkFontSelection_val,
+ String_val, Unit)
+
+#define GtkFontSelectionDialog_val(val) \
+ check_cast(GTK_FONT_SELECTION_DIALOG,val)
+ML_1 (gtk_font_selection_dialog_new, String_option_val, Val_GtkWidget_window)
+/*
+ML_1 (gtk_font_selection_dialog_get_font, GtkFontSelectionDialog_val,
+ Val_GdkFont)
+ML_1 (gtk_font_selection_dialog_get_font_name, GtkFontSelectionDialog_val,
+ copy_string_check)
+ML_2 (gtk_font_selection_dialog_set_font_name, GtkFontSelectionDialog_val,
+ String_val, Val_bool)
+ML_9 (gtk_font_selection_dialog_set_filter, GtkFontSelectionDialog_val,
+ Font_filter_type_val, Flags_Font_type_val,
+ (gchar**), (gchar**), (gchar**),
+ (gchar**), (gchar**), (gchar**), Unit)
+ML_bc9 (ml_gtk_font_selection_dialog_set_filter)
+ML_1 (gtk_font_selection_dialog_get_preview_text, GtkFontSelectionDialog_val,
+ copy_string)
+ML_2 (gtk_font_selection_dialog_set_preview_text, GtkFontSelectionDialog_val,
+ String_val, Unit)
+*/
+Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
+ fontsel, Val_GtkWidget)
+Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
+ ok_button, Val_GtkWidget)
+Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
+ apply_button, Val_GtkWidget)
+Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
+ cancel_button, Val_GtkWidget)
+
+/* gtkplug.h */
+
+ML_1 (gtk_plug_new, XID_val, Val_GtkWidget_window)
+
+/* gtkctree.h */
+#define GtkCTree_val(val) check_cast(GTK_CTREE,val)
+/* Beware: this definition axpects arg1 to be a GtkCTree */
+/*
+#define GtkCTreeNode_val(val) \
+ (gtk_ctree_find(GtkCTree_val(arg1),NULL,(GtkCTreeNode*)(val-1)) \
+ ? (GtkCTreeNode*)(val-1) : (ml_raise_gtk ("Bad GtkCTreeNode"), NULL))
+#define Val_GtkCTreeNode Val_addr
+ML_2 (gtk_ctree_new, Int_val, Int_val, Val_GtkWidget_sink)
+ML_3 (gtk_ctree_new_with_titles, Int_val, Int_val, (char **),
+ Val_GtkWidget_sink)
+ML_11 (gtk_ctree_insert_node, GtkCTree_val, GtkCTreeNode_val,
+ GtkCTreeNode_val, (char**), Int_val, GdkPixmap_val, GdkBitmap_val,
+ GdkPixmap_val, GdkBitmap_val, Bool_val, Bool_val,
+ Val_GtkCTreeNode)
+ML_2 (gtk_ctree_remove_node, GtkCTree_val, GtkCTreeNode_val, Unit)
+ML_2 (gtk_ctree_is_viewable, GtkCTree_val, GtkCTreeNode_val, Val_bool)
+*/
+
+/* gtkpreview.h */
+/*
+#define GtkPreview_val(val) GTK_PREVIEW(Pointer_val(val))
+ML_1 (gtk_preview_new, Preview_val, Val_GtkWidget_sink)
+ML_3 (gtk_preview_size, GtkPreview_val, Int_val, Int_val, Unit)
+ML_9 (gtk_preview_put, GtkPreview_val, GdkWindow_val, GdkGC_val,
+ Int_val, Int_val, Int_val, Int_val, Int_val, Int_val, Unit)
+ML_bc9 (ml_gtk_preview_put)
+*/
+
+/* gtkmain.h */
+
+value ml_gtk_init (value argv)
+{
+ CAMLparam1 (argv);
+ int argc = Wosize_val(argv), i;
+ CAMLlocal1 (copy);
+
+ copy = (argc ? alloc (argc, Abstract_tag) : Atom(0));
+ for (i = 0; i < argc; i++) Field(copy,i) = Field(argv,i);
+ gtk_init (&argc, (char ***)©);
+
+ argv = (argc ? alloc (argc, 0) : Atom(0));
+ for (i = 0; i < argc; i++) modify(&Field(argv,i), Field(copy,i));
+ CAMLreturn (argv);
+}
+ML_1 (gtk_exit, Int_val, Unit)
+ML_0 (gtk_set_locale, Val_string)
+ML_0 (gtk_main, Unit)
+ML_1 (gtk_main_iteration_do, Bool_val, Val_bool)
+ML_0 (gtk_main_quit, Unit)
+ML_1 (gtk_grab_add, GtkWidget_val, Unit)
+ML_1 (gtk_grab_remove, GtkWidget_val, Unit)
+ML_0 (gtk_grab_get_current, Val_GtkWidget)
+value ml_gtk_get_version (value unit)
+{
+ value ret = alloc_small(3,0);
+ Field(ret,0) = Val_int(gtk_major_version);
+ Field(ret,1) = Val_int(gtk_minor_version);
+ Field(ret,2) = Val_int(gtk_micro_version);
+ return ret;
+}
+
+/* Marshalling */
+
+void ml_gtk_callback_marshal (GtkObject *object, gpointer data,
+ guint nargs, GtkArg *args)
+{
+ value vargs = alloc_small(3,0);
+
+ CAMLparam1 (vargs);
+ Field(vargs,0) = (value) object;
+ Field(vargs,1) = Val_int(nargs);
+ Field(vargs,2) = (value) args;
+
+ callback (*(value*)data, vargs);
+
+ Field(vargs,0) = Val_int(-1);
+ Field(vargs,1) = Val_int(-1);
+ CAMLreturn0;
+}
+
+value ml_gtk_arg_shift (GtkArg *args, value index)
+{
+ return (value) (&args[Int_val(index)]);
+}
+
+value ml_gtk_arg_get_type (GtkArg *arg)
+{
+ return Val_int (arg->type);
+}
+
+value ml_gtk_arg_get (GtkArg *arg)
+{
+ CAMLparam0();
+ CAMLlocal1(tmp);
+ value ret = Val_unit;
+ GtkFundamentalType type = GTK_FUNDAMENTAL_TYPE(arg->type);
+ int tag;
+
+ switch (type) {
+ case GTK_TYPE_CHAR:
+ tag = 0;
+ tmp = Int_val(GTK_VALUE_CHAR(*arg));
+ break;
+ case GTK_TYPE_BOOL:
+ tag = 1;
+ tmp = Val_bool(GTK_VALUE_BOOL(*arg));
+ break;
+ case GTK_TYPE_INT:
+ case GTK_TYPE_ENUM:
+ case GTK_TYPE_UINT:
+ case GTK_TYPE_FLAGS:
+ tag = 2;
+ tmp = Val_int (GTK_VALUE_INT(*arg)); break;
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG:
+ tag = 2;
+ tmp = Val_int (GTK_VALUE_LONG(*arg)); break;
+ case GTK_TYPE_FLOAT:
+ tag = 3;
+ tmp = copy_double ((double)GTK_VALUE_FLOAT(*arg)); break;
+ case GTK_TYPE_DOUBLE:
+ tag = 3;
+ tmp = copy_double (GTK_VALUE_DOUBLE(*arg)); break;
+ case GTK_TYPE_STRING:
+ tag = 4;
+ tmp = Val_option (GTK_VALUE_STRING(*arg), copy_string); break;
+ case GTK_TYPE_OBJECT:
+ tag = 5;
+ tmp = Val_option (GTK_VALUE_OBJECT(*arg), Val_GtkObject); break;
+ case GTK_TYPE_BOXED:
+ case GTK_TYPE_POINTER:
+ tag = 6;
+ tmp = Val_option (GTK_VALUE_POINTER(*arg), Val_pointer); break;
+ default:
+ tag = -1;
+ }
+ if (tag != -1) {
+ ret = alloc_small(1,tag);
+ Field(ret,0) = tmp;
+ }
+ CAMLreturn(ret);
+}
+
+value ml_gtk_arg_set_retloc (GtkArg *arg, value val)
+{
+ value type = Fundamental_type_val(Is_block(val) ? Field(val,0) : val);
+ value data = (Is_block(val) ? Field(val,1) : 0);
+ if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_POINTER
+ && GTK_FUNDAMENTAL_TYPE(arg->type) != type)
+ ml_raise_gtk ("GtkArgv.Arg.set : argument type mismatch");
+ switch (type) {
+ case GTK_TYPE_CHAR: *GTK_RETLOC_CHAR(*arg) = Int_val(data); break;
+ case GTK_TYPE_BOOL: *GTK_RETLOC_BOOL(*arg) = Int_val(data); break;
+ case GTK_TYPE_INT:
+ case GTK_TYPE_ENUM: *GTK_RETLOC_INT(*arg) = Int_val(data); break;
+ case GTK_TYPE_UINT:
+ case GTK_TYPE_FLAGS: *GTK_RETLOC_UINT(*arg) = Int32_val(data); break;
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG: *GTK_RETLOC_LONG(*arg) = Nativeint_val(data); break;
+ case GTK_TYPE_FLOAT: *GTK_RETLOC_FLOAT(*arg) = Float_val(data); break;
+ case GTK_TYPE_DOUBLE: *GTK_RETLOC_DOUBLE(*arg) = Double_val(data); break;
+ case GTK_TYPE_STRING:
+ *GTK_RETLOC_STRING(*arg) = Option_val(data, String_val, NULL);
+ break;
+ case GTK_TYPE_BOXED:
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_OBJECT:
+ *GTK_RETLOC_POINTER(*arg) = Option_val(data, Pointer_val, NULL);
+ break;
+ }
+ return Val_unit;
+}
+
+/*
+value ml_gtk_arg_get_char (GtkArg *arg)
+{
+ if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_CHAR)
+ ml_raise_gtk ("argument type mismatch");
+ return Val_char (GTK_VALUE_CHAR(*arg));
+}
+
+value ml_gtk_arg_get_bool (GtkArg *arg)
+{
+ if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_BOOL)
+ ml_raise_gtk ("argument type mismatch");
+ return Val_bool (GTK_VALUE_BOOL(*arg));
+}
+
+value ml_gtk_arg_get_int (GtkArg *arg)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_INT:
+ case GTK_TYPE_UINT:
+ return Val_int (GTK_VALUE_INT(*arg));
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG:
+ return Val_long (GTK_VALUE_LONG(*arg));
+ case GTK_TYPE_ENUM:
+ return Val_int (GTK_VALUE_ENUM(*arg));
+ case GTK_TYPE_FLAGS:
+ return Val_int (GTK_VALUE_FLAGS(*arg));
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+*/
+value ml_gtk_arg_get_nativeint(GtkArg *arg) {
+
+ switch(GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_INT:
+ case GTK_TYPE_UINT:
+ return copy_nativeint (GTK_VALUE_INT(*arg));
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG:
+ return copy_nativeint (GTK_VALUE_LONG(*arg));
+ case GTK_TYPE_ENUM:
+ return copy_nativeint (GTK_VALUE_ENUM(*arg));
+ case GTK_TYPE_FLAGS:
+ return copy_nativeint (GTK_VALUE_FLAGS(*arg));
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+/*
+value ml_gtk_arg_get_float (GtkArg *arg)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_FLOAT:
+ return copy_double ((double)GTK_VALUE_FLOAT(*arg));
+ case GTK_TYPE_DOUBLE:
+ return copy_double (GTK_VALUE_DOUBLE(*arg));
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_get_string (GtkArg *arg)
+{
+ char *p;
+ if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_STRING)
+ ml_raise_gtk ("argument type mismatch");
+ p = GTK_VALUE_STRING(*arg);
+ return Val_option (p, copy_string);
+}
+*/
+value ml_gtk_arg_get_pointer (GtkArg *arg)
+{
+ gpointer p = NULL;
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_STRING:
+ case GTK_TYPE_BOXED:
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_OBJECT:
+ p = GTK_VALUE_POINTER(*arg); break;
+ default:
+ ml_raise_gtk ("GtkArgv.get_pointer : argument type mismatch");
+ }
+ return Val_pointer(p);
+}
+/*
+value ml_gtk_arg_get_object (GtkArg *arg)
+{
+ GtkObject *p;
+ if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_OBJECT)
+ ml_raise_gtk ("argument type mismatch");
+ p = GTK_VALUE_OBJECT(*arg);
+ return Val_option (p, Val_GtkObject);
+}
+*/
+
+value ml_string_at_pointer (value ofs, value len, value ptr)
+{
+ char *start = ((char*)Pointer_val(ptr)) + Option_val(ofs, Int_val, 0);
+ int length = Option_val(len, Int_val, strlen(start));
+ value ret = alloc_string(length);
+ memcpy ((char*)ret, start, length);
+ return ret;
+}
+
+value ml_int_at_pointer (value ptr)
+{
+ return Val_int(*(int*)Pointer_val(ptr));
+}
+
+/*
+value ml_gtk_arg_set_char (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_CHAR:
+ *GTK_RETLOC_CHAR(*arg) = Char_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_bool (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_BOOL:
+ *GTK_RETLOC_BOOL(*arg) = Bool_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_int (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_INT:
+ case GTK_TYPE_UINT:
+ *GTK_RETLOC_INT(*arg) = Int_val(val); break;
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG:
+ *GTK_RETLOC_LONG(*arg) = Long_val(val); break;
+ case GTK_TYPE_ENUM:
+ *GTK_RETLOC_ENUM(*arg) = Int_val(val); break;
+ case GTK_TYPE_FLAGS:
+ *GTK_RETLOC_FLAGS(*arg) = Int_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_nativeint (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_INT:
+ case GTK_TYPE_UINT:
+ *GTK_RETLOC_INT(*arg) = Nativeint_val(val); break;
+ case GTK_TYPE_LONG:
+ case GTK_TYPE_ULONG:
+ *GTK_RETLOC_LONG(*arg) = Nativeint_val(val); break;
+ case GTK_TYPE_ENUM:
+ *GTK_RETLOC_ENUM(*arg) = Nativeint_val(val); break;
+ case GTK_TYPE_FLAGS:
+ *GTK_RETLOC_FLAGS(*arg) = Nativeint_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_float (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_FLOAT:
+ *GTK_RETLOC_FLOAT(*arg) = (float) Double_val(val); break;
+ case GTK_TYPE_DOUBLE:
+ *GTK_RETLOC_DOUBLE(*arg) = Double_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_string (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_STRING:
+ *GTK_RETLOC_STRING(*arg) = String_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_pointer (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_BOXED:
+ *GTK_RETLOC_BOXED(*arg) = Pointer_val(val); break;
+ case GTK_TYPE_POINTER:
+ *GTK_RETLOC_POINTER(*arg) = Pointer_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+
+value ml_gtk_arg_set_object (GtkArg *arg, value val)
+{
+ switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
+ case GTK_TYPE_POINTER:
+ case GTK_TYPE_OBJECT:
+ *GTK_RETLOC_OBJECT(*arg) = GtkObject_val(val); break;
+ default:
+ ml_raise_gtk ("argument type mismatch");
+ }
+ return Val_unit;
+}
+*/
+
+/* gtksignal.h */
+
+value ml_gtk_signal_connect (value object, value name, value clos, value after)
+{
+ value *clos_p = ml_global_root_new (clos);
+ return Val_int (gtk_signal_connect_full
+ (GtkObject_val(object), String_val(name), NULL,
+ ml_gtk_callback_marshal, clos_p,
+ ml_global_root_destroy, FALSE, Bool_val(after)));
+}
+
+ML_2 (gtk_signal_disconnect, GtkObject_val, Int_val, Unit)
+ML_2 (gtk_signal_emit_stop_by_name, GtkObject_val, String_val, Unit)
+ML_2 (gtk_signal_handler_block, GtkObject_val, Int_val, Unit)
+ML_2 (gtk_signal_handler_unblock, GtkObject_val, Int_val, Unit)
+ML_2_name (ml_gtk_signal_emit_none, gtk_signal_emit_by_name,
+ GtkObject_val, String_val, Unit)
+ML_3_name (ml_gtk_signal_emit_int, gtk_signal_emit_by_name,
+ GtkObject_val, String_val, Int_val, Unit)
+ML_4_name (ml_gtk_signal_emit_scroll, gtk_signal_emit_by_name,
+ GtkObject_val, String_val, Scroll_type_val, Double_val, Unit)
+
+/* gtkmain.h (again) */
+
+value ml_gtk_timeout_add (value interval, value clos)
+{
+ value *clos_p = ml_global_root_new (clos);
+ return Val_int (gtk_timeout_add_full
+ (Int_val(interval), NULL, ml_gtk_callback_marshal, clos_p,
+ ml_global_root_destroy));
+}
+ML_1 (gtk_timeout_remove, Int_val, Unit)
+
+ML_1 (gtk_rc_add_default_file, String_val, Unit)
--- /dev/null
+/* $Id$ */
+
+#define GtkObject_val(obj) ((GtkObject*)Field(obj,1))
+value Val_GtkObject (GtkObject *w);
+value Val_GtkObject_sink (GtkObject *w);
+#define GtkAccelGroup_val(val) ((GtkAccelGroup*)Pointer_val(val))
+value Val_GtkAccelGroup (GtkAccelGroup *);
+#define GtkStyle_val(val) ((GtkStyle*)Pointer_val(val))
+value Val_GtkStyle (GtkStyle *);
+
+#define Val_GtkAny(w) Val_GtkObject((GtkObject*)w)
+#define Val_GtkAny_sink(w) Val_GtkObject_sink((GtkObject*)w)
+#define Val_GtkWidget Val_GtkAny
+#define Val_GtkWidget_sink Val_GtkAny_sink
+
+#ifdef GTK_NO_CHECK_CASTS
+#define check_cast(f,v) f(Pointer_val(v))
+#else
+#define check_cast(f,v) (Pointer_val(v) == NULL ? NULL : f(Pointer_val(v)))
+#endif
+
+#define GtkWidget_val(val) check_cast(GTK_WIDGET,val)
+#define GtkAdjustment_val(val) check_cast(GTK_ADJUSTMENT,val)
+#define GtkItem_val(val) check_cast(GTK_ITEM,val)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkalignment.h */
+
+#define GtkAlignment_val(val) check_cast(GTK_ALIGNMENT,val)
+ML_4 (gtk_alignment_new, Float_val, Float_val, Float_val, Float_val,
+ Val_GtkWidget_sink)
+value ml_gtk_alignment_set (value x, value y,
+ value xscale, value yscale, value val)
+{
+ GtkAlignment *alignment = GtkAlignment_val(val);
+ gtk_alignment_set (alignment,
+ Option_val(x, Float_val, alignment->xalign),
+ Option_val(y, Float_val, alignment->yalign),
+ Option_val(xscale, Float_val, alignment->xscale),
+ Option_val(yscale, Float_val, alignment->xscale));
+ return Val_unit;
+}
+
+/* gtkeventbox.h */
+
+ML_0 (gtk_event_box_new, Val_GtkWidget_sink)
+
+/* gtkframe.h */
+
+#define GtkFrame_val(val) check_cast(GTK_FRAME,val)
+ML_1 (gtk_frame_new, Optstring_val, Val_GtkWidget_sink)
+ML_2 (gtk_frame_set_label, GtkFrame_val, Optstring_val, Unit)
+ML_3 (gtk_frame_set_label_align, GtkFrame_val, Float_val, Float_val, Unit)
+ML_2 (gtk_frame_set_shadow_type, GtkFrame_val, Shadow_type_val, Unit)
+Make_Extractor (gtk_frame_get, GtkFrame_val, label_xalign, copy_double)
+Make_Extractor (gtk_frame_get, GtkFrame_val, label_yalign, copy_double)
+
+/* gtkaspectframe.h */
+
+#define GtkAspectFrame_val(val) check_cast(GTK_ASPECT_FRAME,val)
+ML_5 (gtk_aspect_frame_new, Optstring_val,
+ Float_val, Float_val, Float_val, Bool_val, Val_GtkWidget_sink)
+ML_5 (gtk_aspect_frame_set, GtkAspectFrame_val, Float_val, Float_val,
+ Float_val, Bool_val, Unit)
+Make_Extractor (gtk_aspect_frame_get, GtkAspectFrame_val, xalign, copy_double)
+Make_Extractor (gtk_aspect_frame_get, GtkAspectFrame_val, yalign, copy_double)
+Make_Extractor (gtk_aspect_frame_get, GtkAspectFrame_val, ratio, copy_double)
+Make_Extractor (gtk_aspect_frame_get, GtkAspectFrame_val, obey_child, Val_bool)
+
+/* gtkhandlebox.h */
+
+#define GtkHandleBox_val(val) check_cast(GTK_HANDLE_BOX,val)
+ML_0 (gtk_handle_box_new, Val_GtkWidget_sink)
+ML_2 (gtk_handle_box_set_shadow_type, GtkHandleBox_val, Shadow_type_val, Unit)
+ML_2 (gtk_handle_box_set_handle_position, GtkHandleBox_val, Position_val, Unit)
+ML_2 (gtk_handle_box_set_snap_edge, GtkHandleBox_val, Position_val, Unit)
+
+/* gtkinvisible.h */
+/* private class
+ML_0 (gtk_invisible_new, Val_GtkWidget_sink)
+*/
+
+/* gtkitem.h */
+
+ML_1 (gtk_item_select, GtkItem_val, Unit)
+ML_1 (gtk_item_deselect, GtkItem_val, Unit)
+ML_1 (gtk_item_toggle, GtkItem_val, Unit)
+
+/* gtkviewport.h */
+
+#define GtkViewport_val(val) check_cast(GTK_VIEWPORT,val)
+ML_2 (gtk_viewport_new, GtkAdjustment_val, GtkAdjustment_val,
+ Val_GtkWidget_sink)
+ML_1 (gtk_viewport_get_hadjustment, GtkViewport_val, Val_GtkWidget_sink)
+ML_1 (gtk_viewport_get_vadjustment, GtkViewport_val, Val_GtkWidget)
+ML_2 (gtk_viewport_set_hadjustment, GtkViewport_val, GtkAdjustment_val, Unit)
+ML_2 (gtk_viewport_set_vadjustment, GtkViewport_val, GtkAdjustment_val, Unit)
+ML_2 (gtk_viewport_set_shadow_type, GtkViewport_val, Shadow_type_val, Unit)
+
+/* gtkscrolledwindow.h */
+
+#define GtkScrolledWindow_val(val) check_cast(GTK_SCROLLED_WINDOW,val)
+ML_2 (gtk_scrolled_window_new, GtkAdjustment_val ,GtkAdjustment_val,
+ Val_GtkWidget_sink)
+ML_2 (gtk_scrolled_window_set_hadjustment, GtkScrolledWindow_val ,
+ GtkAdjustment_val, Unit)
+ML_2 (gtk_scrolled_window_set_vadjustment, GtkScrolledWindow_val ,
+ GtkAdjustment_val, Unit)
+ML_1 (gtk_scrolled_window_get_hadjustment, GtkScrolledWindow_val,
+ Val_GtkWidget)
+ML_1 (gtk_scrolled_window_get_vadjustment, GtkScrolledWindow_val,
+ Val_GtkWidget)
+ML_3 (gtk_scrolled_window_set_policy, GtkScrolledWindow_val,
+ Policy_type_val, Policy_type_val, Unit)
+Make_Extractor (gtk_scrolled_window_get, GtkScrolledWindow_val,
+ hscrollbar_policy, Val_policy_type)
+Make_Extractor (gtk_scrolled_window_get, GtkScrolledWindow_val,
+ vscrollbar_policy, Val_policy_type)
+ML_2 (gtk_scrolled_window_set_placement, GtkScrolledWindow_val,
+ Corner_type_val, Unit)
+ML_2 (gtk_scrolled_window_add_with_viewport, GtkScrolledWindow_val,
+ GtkWidget_val, Unit)
+
+/* gtksocket.h */
+
+#define GtkSocket_val(val) check_cast(GTK_SOCKET,val)
+ML_0 (gtk_socket_new, Val_GtkWidget_sink)
+ML_2 (gtk_socket_steal, GtkSocket_val, XID_val, Unit)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkbutton.h */
+
+#define GtkButton_val(val) check_cast(GTK_BUTTON,val)
+ML_0 (gtk_button_new, Val_GtkWidget_sink)
+ML_1 (gtk_button_new_with_label, String_val, Val_GtkWidget_sink)
+ML_1 (gtk_button_pressed, GtkButton_val, Unit)
+ML_1 (gtk_button_released, GtkButton_val, Unit)
+ML_1 (gtk_button_clicked, GtkButton_val, Unit)
+ML_1 (gtk_button_enter, GtkButton_val, Unit)
+ML_1 (gtk_button_leave, GtkButton_val, Unit)
+
+/* gtktogglebutton.h */
+
+#define GtkToggleButton_val(val) check_cast(GTK_TOGGLE_BUTTON,val)
+ML_0 (gtk_toggle_button_new, Val_GtkWidget_sink)
+ML_1 (gtk_toggle_button_new_with_label, String_val, Val_GtkWidget_sink)
+ML_2 (gtk_toggle_button_set_mode, GtkToggleButton_val, Bool_val, Unit)
+ML_2 (gtk_toggle_button_set_active, GtkToggleButton_val, Bool_val, Unit)
+ML_1 (gtk_toggle_button_toggled, GtkToggleButton_val, Unit)
+Make_Extractor (gtk_toggle_button_get, GtkToggleButton_val, active, Val_bool)
+
+/* gtkcheckbutton.h */
+
+#define GtkCheckButton_val(val) check_cast(GTK_CHECK_BUTTON,val)
+ML_0 (gtk_check_button_new, Val_GtkWidget_sink)
+ML_1 (gtk_check_button_new_with_label, String_val, Val_GtkWidget_sink)
+
+/* gtkradiobutton.h */
+
+#define GtkRadioButton_val(val) check_cast(GTK_RADIO_BUTTON,val)
+static GSList* button_group_val(value val)
+{
+ return (val == Val_unit ? NULL :
+ gtk_radio_button_group(GtkRadioButton_val(Field(val,0))));
+}
+ML_1 (gtk_radio_button_new, button_group_val,
+ Val_GtkWidget_sink)
+ML_2 (gtk_radio_button_new_with_label, button_group_val,
+ String_val, Val_GtkWidget_sink)
+ML_2 (gtk_radio_button_set_group, GtkRadioButton_val, button_group_val, Unit)
+
+/* gtktoolbar.h */
+
+#define GtkToolbar_val(val) check_cast(GTK_TOOLBAR,val)
+ML_2 (gtk_toolbar_new, Orientation_val, Toolbar_style_val, Val_GtkWidget_sink)
+ML_2 (gtk_toolbar_insert_space, GtkToolbar_val, Int_val, Unit)
+ML_7 (gtk_toolbar_insert_element, GtkToolbar_val, Toolbar_child_val,
+ Insert(NULL) Optstring_val, Optstring_val, Optstring_val, GtkWidget_val,
+ Insert(NULL) Insert(NULL) Int_val, Val_GtkWidget)
+ML_bc7 (ml_gtk_toolbar_insert_element)
+ML_5 (gtk_toolbar_insert_widget, GtkToolbar_val, GtkWidget_val,
+ Optstring_val, Optstring_val, Int_val, Unit)
+ML_2 (gtk_toolbar_set_orientation, GtkToolbar_val, Orientation_val, Unit)
+ML_2 (gtk_toolbar_set_style, GtkToolbar_val, Toolbar_style_val, Unit)
+ML_2 (gtk_toolbar_set_space_size, GtkToolbar_val, Int_val, Unit)
+ML_2 (gtk_toolbar_set_space_style, GtkToolbar_val, Toolbar_space_style_val, Unit)
+ML_2 (gtk_toolbar_set_tooltips, GtkToolbar_val, Bool_val, Unit)
+ML_2 (gtk_toolbar_set_button_relief, GtkToolbar_val, Relief_style_val, Unit)
+ML_1 (gtk_toolbar_get_button_relief, GtkToolbar_val, Val_relief_style)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkeditable.h */
+
+#define GtkEditable_val(val) check_cast(GTK_EDITABLE,val)
+ML_3 (gtk_editable_select_region, GtkEditable_val, Int_val, Int_val, Unit)
+value ml_gtk_editable_insert_text (value w, value s, value pos)
+{
+ int position = Int_val(pos);
+ gtk_editable_insert_text (GtkEditable_val(w), String_val(s),
+ string_length(s), &position);
+ return Val_int(position);
+}
+ML_3 (gtk_editable_delete_text, GtkEditable_val, Int_val, Int_val, Unit)
+ML_3 (gtk_editable_get_chars, GtkEditable_val, Int_val, Int_val,
+ copy_string_and_free)
+ML_1 (gtk_editable_cut_clipboard, GtkEditable_val, Unit)
+ML_1 (gtk_editable_copy_clipboard, GtkEditable_val, Unit)
+ML_1 (gtk_editable_paste_clipboard, GtkEditable_val, Unit)
+ML_3 (gtk_editable_claim_selection, GtkEditable_val, Bool_val, Int_val, Unit)
+ML_1 (gtk_editable_delete_selection, GtkEditable_val, Unit)
+ML_1 (gtk_editable_changed, GtkEditable_val, Unit)
+ML_2 (gtk_editable_set_position, GtkEditable_val, Int_val, Unit)
+ML_1 (gtk_editable_get_position, GtkEditable_val, Val_int)
+ML_2 (gtk_editable_set_editable, GtkEditable_val, Bool_val, Unit)
+Make_Extractor (gtk_editable, GtkEditable_val, selection_start_pos, Val_int)
+Make_Extractor (gtk_editable, GtkEditable_val, selection_end_pos, Val_int)
+Make_Extractor (gtk_editable, GtkEditable_val, has_selection, Val_bool)
+
+/* gtkentry.h */
+
+#define GtkEntry_val(val) check_cast(GTK_ENTRY,val)
+ML_0 (gtk_entry_new, Val_GtkWidget_sink)
+ML_1 (gtk_entry_new_with_max_length, (gint16)Long_val, Val_GtkWidget_sink)
+ML_2 (gtk_entry_set_text, GtkEntry_val, String_val, Unit)
+ML_2 (gtk_entry_append_text, GtkEntry_val, String_val, Unit)
+ML_2 (gtk_entry_prepend_text, GtkEntry_val, String_val, Unit)
+ML_1 (gtk_entry_get_text, GtkEntry_val, Val_string)
+ML_3 (gtk_entry_select_region, GtkEntry_val, Int_val, Int_val, Unit)
+ML_2 (gtk_entry_set_visibility, GtkEntry_val, Bool_val, Unit)
+ML_2 (gtk_entry_set_max_length, GtkEntry_val, (gint16)Long_val, Unit)
+Make_Extractor (GtkEntry, GtkEntry_val, text_length, Val_int)
+
+/* gtkspinbutton.h */
+
+#define GtkSpinButton_val(val) check_cast(GTK_SPIN_BUTTON,val)
+ML_3 (gtk_spin_button_new, GtkAdjustment_val,
+ Float_val, Int_val, Val_GtkWidget_sink)
+ML_2 (gtk_spin_button_set_adjustment, GtkSpinButton_val, GtkAdjustment_val,
+ Unit)
+ML_1 (gtk_spin_button_get_adjustment, GtkSpinButton_val, Val_GtkAny)
+ML_2 (gtk_spin_button_set_digits, GtkSpinButton_val, Int_val, Unit)
+ML_1 (gtk_spin_button_get_value_as_float, GtkSpinButton_val, copy_double)
+ML_2 (gtk_spin_button_set_value, GtkSpinButton_val, Float_val, Unit)
+ML_2 (gtk_spin_button_set_update_policy, GtkSpinButton_val,
+ Update_type_val, Unit)
+ML_2 (gtk_spin_button_set_numeric, GtkSpinButton_val, Bool_val, Unit)
+ML_2 (gtk_spin_button_spin, GtkSpinButton_val,
+ Insert (Is_long(arg2) ? Spin_type_val(arg2) : GTK_SPIN_USER_DEFINED)
+ (Is_long(arg2) ? 0.0 : Float_val(Field(arg2,1))) Ignore, Unit)
+ML_2 (gtk_spin_button_set_wrap, GtkSpinButton_val, Bool_val, Unit)
+ML_2 (gtk_spin_button_set_shadow_type, GtkSpinButton_val, Shadow_type_val, Unit)
+ML_2 (gtk_spin_button_set_snap_to_ticks, GtkSpinButton_val, Bool_val, Unit)
+ML_4 (gtk_spin_button_configure, GtkSpinButton_val, GtkAdjustment_val,
+ Float_val, Int_val, Unit)
+ML_1 (gtk_spin_button_update, GtkSpinButton_val, Unit)
+
+/* gtktext.h */
+
+#define GtkText_val(val) check_cast(GTK_TEXT,val)
+ML_2 (gtk_text_new, GtkAdjustment_val, GtkAdjustment_val, Val_GtkWidget_sink)
+ML_2 (gtk_text_set_word_wrap, GtkText_val, Bool_val, Unit)
+ML_2 (gtk_text_set_line_wrap, GtkText_val, Bool_val, Unit)
+ML_3 (gtk_text_set_adjustments, GtkText_val,
+ Option_val(arg2,GtkAdjustment_val,GtkText_val(arg1)->hadj) Ignore,
+ Option_val(arg3,GtkAdjustment_val,GtkText_val(arg1)->vadj) Ignore,
+ Unit)
+Make_Extractor (gtk_text_get, GtkText_val, hadj, Val_GtkWidget)
+Make_Extractor (gtk_text_get, GtkText_val, vadj, Val_GtkWidget)
+ML_2 (gtk_text_set_point, GtkText_val, Int_val, Unit)
+ML_1 (gtk_text_get_point, GtkText_val, Val_int)
+ML_1 (gtk_text_get_length, GtkText_val, Val_int)
+ML_1 (gtk_text_freeze, GtkText_val, Unit)
+ML_1 (gtk_text_thaw, GtkText_val, Unit)
+value ml_gtk_text_insert (value text, value font, value fore, value back,
+ value str)
+{
+ gtk_text_insert (GtkText_val(text),
+ Option_val(font,GdkFont_val,NULL),
+ Option_val(fore,GdkColor_val,NULL),
+ Option_val(back,GdkColor_val,NULL),
+ String_val(str), string_length(str));
+ return Val_unit;
+}
+ML_2 (gtk_text_forward_delete, GtkText_val, Int_val, Val_int)
+ML_2 (gtk_text_backward_delete, GtkText_val, Int_val, Val_int)
+
+/* gtkcombo.h */
+
+#define GtkCombo_val(val) check_cast(GTK_COMBO,val)
+ML_0 (gtk_combo_new, Val_GtkWidget_sink)
+ML_3 (gtk_combo_set_value_in_list, GtkCombo_val,
+ Option_val(arg2, Bool_val, GtkCombo_val(arg1)->value_in_list) Ignore,
+ Option_val(arg3, Bool_val, GtkCombo_val(arg1)->ok_if_empty) Ignore,
+ Unit)
+ML_2 (gtk_combo_set_use_arrows, GtkCombo_val, Bool_val, Unit)
+ML_2 (gtk_combo_set_use_arrows_always, GtkCombo_val, Bool_val, Unit)
+ML_2 (gtk_combo_set_case_sensitive, GtkCombo_val, Bool_val, Unit)
+ML_3 (gtk_combo_set_item_string, GtkCombo_val, GtkItem_val, String_val, Unit)
+ML_1 (gtk_combo_disable_activate, GtkCombo_val, Unit)
+Make_Extractor (gtk_combo, GtkCombo_val, entry, Val_GtkWidget)
+Make_Extractor (gtk_combo, GtkCombo_val, list, Val_GtkWidget)
--- /dev/null
+/* $Id$ */
+
+#include <gtk/gtk.h>
+#include <gtkgl/gtkglarea.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtkgl_tags.h"
+
+/* Conversion functions */
+#include "gtkgl_tags.c"
+
+#define GtkGLArea_val(val) ((GtkGLArea*)GtkObject_val(val))
+
+value ml_gtk_gl_area_new (value list, value share)
+{
+ value cursor, res;
+ int len, i;
+ int *attrs;
+
+ for (len = 0, cursor = list; cursor != Val_unit; cursor = Field(cursor,1))
+ {
+ if (Is_block(Field(cursor,0))) len += 2;
+ else len++;
+ }
+
+ attrs = (int*) stat_alloc ((len+1)*sizeof(int));
+
+ for (i = 0, cursor = list; cursor != Val_unit; cursor = Field(cursor,1))
+ {
+ value option = Field(cursor,0);
+ if (Is_block(option)) {
+ attrs[i++] = Visual_options_val(Field(option,0));
+ attrs[i++] = Int_val(Field(option,1));
+ }
+ else attrs[i++] = Visual_options_val(option);
+ }
+ attrs[i] = GDK_GL_NONE;
+
+ res = Val_GtkObject
+ ((GtkObject*)gtk_gl_area_share_new(attrs,GtkGLArea_val(share)));
+ stat_free(attrs);
+ return res;
+}
+
+ML_1 (gtk_gl_area_make_current, GtkGLArea_val, Val_bool)
+ML_1 (gtk_gl_area_swapbuffers, GtkGLArea_val, Unit)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+static Make_Flags_val (Button_action_val)
+
+/* gtklistitem.h */
+
+ML_0 (gtk_list_item_new, Val_GtkWidget_sink)
+ML_1 (gtk_list_item_new_with_label, String_val, Val_GtkWidget_sink)
+
+/* gtklist.h */
+
+#define GtkList_val(val) check_cast(GTK_LIST,val)
+ML_0 (gtk_list_new, Val_GtkWidget_sink)
+value ml_gtk_list_insert_item (value list, value item, value pos)
+{
+ GList *tmp_list = g_list_alloc ();
+ tmp_list->data = GtkWidget_val(item);
+ tmp_list->next = NULL;
+ tmp_list->prev = NULL;
+ gtk_list_insert_items (GtkList_val(list), tmp_list, Int_val(pos));
+ return Val_unit;
+}
+ML_3 (gtk_list_clear_items, GtkList_val, Int_val, Int_val, Unit)
+ML_2 (gtk_list_select_item, GtkList_val, Int_val, Unit)
+ML_2 (gtk_list_unselect_item, GtkList_val, Int_val, Unit)
+ML_2 (gtk_list_select_child, GtkList_val, GtkWidget_val, Unit)
+ML_2 (gtk_list_unselect_child, GtkList_val, GtkWidget_val, Unit)
+ML_2 (gtk_list_child_position, GtkList_val, GtkWidget_val, Val_int)
+ML_2 (gtk_list_set_selection_mode, GtkList_val, Selection_mode_val, Unit)
+
+/* gtkclist.h */
+
+#define GtkCList_val(val) check_cast(GTK_CLIST,val)
+ML_1 (gtk_clist_new, Int_val, Val_GtkWidget_sink)
+ML_1 (gtk_clist_new_with_titles, Insert(Wosize_val(arg1)) (char **),
+ Val_GtkWidget_sink)
+Make_Extractor (gtk_clist_get, GtkCList_val, rows, Val_int)
+Make_Extractor (gtk_clist_get, GtkCList_val, columns, Val_int)
+Make_Extractor (gtk_clist_get, GtkCList_val, focus_row, Val_int)
+ML_2 (gtk_clist_set_hadjustment, GtkCList_val, GtkAdjustment_val, Unit)
+ML_2 (gtk_clist_set_vadjustment, GtkCList_val, GtkAdjustment_val, Unit)
+ML_1 (gtk_clist_get_hadjustment, GtkCList_val, Val_GtkAny)
+ML_1 (gtk_clist_get_vadjustment, GtkCList_val, Val_GtkAny)
+ML_2 (gtk_clist_set_shadow_type, GtkCList_val, Shadow_type_val, Unit)
+ML_2 (gtk_clist_set_selection_mode, GtkCList_val, Selection_mode_val, Unit)
+ML_2 (gtk_clist_set_reorderable, GtkCList_val, Bool_val, Unit)
+ML_2 (gtk_clist_set_use_drag_icons, GtkCList_val, Bool_val, Unit)
+ML_3 (gtk_clist_set_button_actions, GtkCList_val, Int_val,
+ (guint8)Flags_Button_action_val, Unit)
+ML_1 (gtk_clist_freeze, GtkCList_val, Unit)
+ML_1 (gtk_clist_thaw, GtkCList_val, Unit)
+ML_1 (gtk_clist_column_titles_show, GtkCList_val, Unit)
+ML_1 (gtk_clist_column_titles_hide, GtkCList_val, Unit)
+ML_2 (gtk_clist_column_title_active, GtkCList_val, Int_val, Unit)
+ML_2 (gtk_clist_column_title_passive, GtkCList_val, Int_val, Unit)
+ML_1 (gtk_clist_column_titles_active, GtkCList_val, Unit)
+ML_1 (gtk_clist_column_titles_passive, GtkCList_val, Unit)
+ML_3 (gtk_clist_set_column_title, GtkCList_val, Int_val, String_val, Unit)
+ML_2 (gtk_clist_get_column_title, GtkCList_val, Int_val, Val_string)
+ML_3 (gtk_clist_set_column_widget, GtkCList_val, Int_val, GtkWidget_val, Unit)
+ML_2 (gtk_clist_get_column_widget, GtkCList_val, Int_val, Val_GtkWidget)
+ML_3 (gtk_clist_set_column_justification, GtkCList_val, Int_val,
+ Justification_val, Unit)
+ML_3 (gtk_clist_set_column_visibility, GtkCList_val, Int_val, Bool_val, Unit)
+ML_3 (gtk_clist_set_column_resizeable, GtkCList_val, Int_val, Bool_val, Unit)
+ML_3 (gtk_clist_set_column_auto_resize, GtkCList_val, Int_val, Bool_val, Unit)
+ML_1 (gtk_clist_columns_autosize, GtkCList_val, Unit)
+ML_2 (gtk_clist_optimal_column_width, GtkCList_val, Int_val, Val_int)
+ML_3 (gtk_clist_set_column_width, GtkCList_val, Int_val, Int_val, Unit)
+ML_3 (gtk_clist_set_column_min_width, GtkCList_val, Int_val, Int_val, Unit)
+ML_3 (gtk_clist_set_column_max_width, GtkCList_val, Int_val, Int_val, Unit)
+ML_2 (gtk_clist_set_row_height, GtkCList_val, Int_val, Unit)
+ML_5 (gtk_clist_moveto, GtkCList_val, Int_val, Int_val,
+ Double_val, Double_val, Unit)
+ML_2 (gtk_clist_row_is_visible, GtkCList_val, Int_val, Val_visibility)
+ML_3 (gtk_clist_get_cell_type, GtkCList_val, Int_val, Int_val, Val_cell_type)
+ML_4 (gtk_clist_set_text, GtkCList_val, Int_val, Int_val, Optstring_val, Unit)
+value ml_gtk_clist_get_text (value clist, value row, value column)
+{
+ char *text;
+ if (!gtk_clist_get_text (GtkCList_val(clist), Int_val(row),
+ Int_val(column), &text))
+ invalid_argument ("Gtk.Clist.get_text");
+ return Val_optstring(text);
+}
+ML_5 (gtk_clist_set_pixmap, GtkCList_val, Int_val, Int_val, GdkPixmap_val,
+ GdkBitmap_val, Unit)
+value ml_gtk_clist_get_pixmap (value clist, value row, value column)
+{
+ CAMLparam0 ();
+ GdkPixmap *pixmap;
+ GdkBitmap *bitmap;
+ CAMLlocal2 (vpixmap,vbitmap);
+ value ret;
+
+ if (!gtk_clist_get_pixmap (GtkCList_val(clist), Int_val(row),
+ Int_val(column), &pixmap, &bitmap))
+ invalid_argument ("Gtk.Clist.get_pixmap");
+ vpixmap = Val_option (pixmap, Val_GdkPixmap);
+ vbitmap = Val_option (bitmap, Val_GdkBitmap);
+
+ ret = alloc_small (2,0);
+ Field(ret,0) = vpixmap;
+ Field(ret,1) = vbitmap;
+ CAMLreturn(ret);
+}
+ML_7 (gtk_clist_set_pixtext, GtkCList_val, Int_val, Int_val, String_val,
+ (guint8)Long_val, GdkPixmap_val, GdkBitmap_val, Unit)
+ML_bc7 (ml_gtk_clist_set_pixtext)
+ML_3 (gtk_clist_set_foreground, GtkCList_val, Int_val, GdkColor_val, Unit)
+ML_3 (gtk_clist_set_background, GtkCList_val, Int_val, GdkColor_val, Unit)
+ML_3 (gtk_clist_get_cell_style, GtkCList_val, Int_val, Int_val, Val_GtkStyle)
+ML_4 (gtk_clist_set_cell_style, GtkCList_val, Int_val, Int_val, GtkStyle_val,
+ Unit)
+ML_2 (gtk_clist_get_row_style, GtkCList_val, Int_val, Val_GtkStyle)
+ML_3 (gtk_clist_set_row_style, GtkCList_val, Int_val, GtkStyle_val, Unit)
+ML_3 (gtk_clist_set_selectable, GtkCList_val, Int_val, Bool_val, Unit)
+ML_2 (gtk_clist_get_selectable, GtkCList_val, Int_val, Val_bool)
+ML_5 (gtk_clist_set_shift, GtkCList_val, Int_val, Int_val, Int_val, Int_val,
+ Unit)
+/* ML_2 (gtk_clist_append, GtkCList_val, (char **), Val_int) */
+ML_3 (gtk_clist_insert, GtkCList_val, Int_val, (char **), Val_int)
+ML_2 (gtk_clist_remove, GtkCList_val, Int_val, Unit)
+value ml_gtk_clist_set_row_data (value w, value row, value data)
+{
+ value *data_p = ml_global_root_new (data);
+ gtk_clist_set_row_data_full (GtkCList_val(w), Int_val(row),
+ data_p, ml_global_root_destroy);
+ return Val_unit;
+}
+ML_2 (gtk_clist_get_row_data, GtkCList_val, Int_val, *(value*)Check_null)
+ML_3 (gtk_clist_select_row, GtkCList_val, Int_val, Int_val, Unit)
+ML_3 (gtk_clist_unselect_row, GtkCList_val, Int_val, Int_val, Unit)
+ML_1 (gtk_clist_clear, GtkCList_val, Unit)
+value ml_gtk_clist_get_selection_info (value clist, value x, value y)
+{
+ int row, column;
+ value ret;
+ if (!gtk_clist_get_selection_info (GtkCList_val(clist), Int_val(x),
+ Int_val(y), &row, &column))
+ invalid_argument ("Gtk.Clist.get_selection_info");
+ ret = alloc_small (2,0);
+ Field(ret,0) = row;
+ Field(ret,1) = column;
+ return ret;
+}
+ML_1 (gtk_clist_select_all, GtkCList_val, Unit)
+ML_1 (gtk_clist_unselect_all, GtkCList_val, Unit)
+ML_3 (gtk_clist_swap_rows, GtkCList_val, Int_val, Int_val, Unit)
+ML_3 (gtk_clist_row_move, GtkCList_val, Int_val, Int_val, Unit)
+ML_2 (gtk_clist_set_sort_column, GtkCList_val, Int_val, Unit)
+ML_2 (gtk_clist_set_sort_type, GtkCList_val, Sort_type_val, Unit)
+ML_1 (gtk_clist_sort, GtkCList_val, Unit)
+ML_2 (gtk_clist_set_auto_sort, GtkCList_val, Bool_val, Unit)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkmenuitem.h */
+
+#define GtkMenuItem_val(val) check_cast(GTK_MENU_ITEM,val)
+ML_0 (gtk_menu_item_new, Val_GtkWidget_sink)
+ML_0 (gtk_tearoff_menu_item_new, Val_GtkWidget_sink)
+ML_1 (gtk_menu_item_new_with_label, String_val, Val_GtkWidget_sink)
+ML_2 (gtk_menu_item_set_submenu, GtkMenuItem_val, GtkWidget_val, Unit)
+ML_1 (gtk_menu_item_remove_submenu, GtkMenuItem_val, Unit)
+ML_2 (gtk_menu_item_set_placement, GtkMenuItem_val,
+ Submenu_placement_val, Unit)
+ML_3 (gtk_menu_item_configure, GtkMenuItem_val, Bool_val, Bool_val, Unit)
+ML_1 (gtk_menu_item_activate, GtkMenuItem_val, Unit)
+ML_1 (gtk_menu_item_right_justify, GtkMenuItem_val, Unit)
+
+/* gtkcheckmenuitem.h */
+
+#define GtkCheckMenuItem_val(val) check_cast(GTK_CHECK_MENU_ITEM,val)
+ML_0 (gtk_check_menu_item_new, Val_GtkWidget_sink)
+ML_1 (gtk_check_menu_item_new_with_label, String_val, Val_GtkWidget_sink)
+ML_2 (gtk_check_menu_item_set_active, GtkCheckMenuItem_val, Bool_val, Unit)
+ML_2 (gtk_check_menu_item_set_show_toggle, GtkCheckMenuItem_val,
+ Bool_val, Unit)
+ML_1 (gtk_check_menu_item_toggled, GtkCheckMenuItem_val, Unit)
+Make_Extractor (gtk_check_menu_item_get, GtkCheckMenuItem_val,
+ active, Val_bool)
+
+/* gtkradiomenuitem.h */
+
+#define GtkRadioMenuItem_val(val) check_cast(GTK_RADIO_MENU_ITEM,val)
+static GSList* item_group_val(value val)
+{
+ return (val == Val_unit ? NULL :
+ gtk_radio_menu_item_group(GtkRadioMenuItem_val(Field(val,0))));
+}
+ML_1 (gtk_radio_menu_item_new, item_group_val, Val_GtkWidget_sink)
+ML_2 (gtk_radio_menu_item_new_with_label, item_group_val,
+ String_val, Val_GtkWidget_sink)
+ML_2 (gtk_radio_menu_item_set_group, GtkRadioMenuItem_val,
+ item_group_val, Unit)
+
+/* gtkoptionmenu.h */
+
+#define GtkOptionMenu_val(val) check_cast(GTK_OPTION_MENU,val)
+ML_0 (gtk_option_menu_new, Val_GtkWidget_sink)
+ML_1 (gtk_option_menu_get_menu, GtkOptionMenu_val, Val_GtkWidget_sink)
+ML_2 (gtk_option_menu_set_menu, GtkOptionMenu_val, GtkWidget_val, Unit)
+ML_1 (gtk_option_menu_remove_menu, GtkOptionMenu_val, Unit)
+ML_2 (gtk_option_menu_set_history, GtkOptionMenu_val, Int_val, Unit)
+
+/* gtkmenushell.h */
+
+#define GtkMenuShell_val(val) check_cast(GTK_MENU_SHELL,val)
+ML_2 (gtk_menu_shell_append, GtkMenuShell_val, GtkWidget_val, Unit)
+ML_2 (gtk_menu_shell_prepend, GtkMenuShell_val, GtkWidget_val, Unit)
+ML_3 (gtk_menu_shell_insert, GtkMenuShell_val, GtkWidget_val, Int_val, Unit)
+ML_1 (gtk_menu_shell_deactivate, GtkMenuShell_val, Unit)
+
+/* gtkmenu.h */
+
+#define GtkMenu_val(val) check_cast(GTK_MENU,val)
+ML_0 (gtk_menu_new, Val_GtkWidget_sink)
+ML_5 (gtk_menu_popup, GtkMenu_val, GtkWidget_val, GtkWidget_val,
+ Insert(NULL) Insert(NULL) Int_val, Int_val, Unit)
+ML_1 (gtk_menu_popdown, GtkMenu_val, Unit)
+ML_1 (gtk_menu_get_active, GtkMenu_val, Val_GtkWidget)
+ML_2 (gtk_menu_set_active, GtkMenu_val, Int_val, Unit)
+ML_2 (gtk_menu_set_accel_group, GtkMenu_val, GtkAccelGroup_val, Unit)
+ML_1 (gtk_menu_get_accel_group, GtkMenu_val, Val_GtkAccelGroup)
+ML_1 (gtk_menu_ensure_uline_accel_group, GtkMenu_val, Val_GtkAccelGroup)
+value ml_gtk_menu_attach_to_widget (value menu, value widget)
+{
+ gtk_menu_attach_to_widget (GtkMenu_val(menu), GtkWidget_val(widget), NULL);
+ return Val_unit;
+}
+ML_1 (gtk_menu_get_attach_widget, GtkMenu_val, Val_GtkWidget)
+ML_1 (gtk_menu_detach, GtkMenu_val, Unit)
+
+/* gtkmenubar.h */
+
+#define GtkMenuBar_val(val) check_cast(GTK_MENU_BAR,val)
+ML_0 (gtk_menu_bar_new, Val_GtkWidget_sink)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkgamma.h */
+
+#define GtkGammaCurve_val(val) check_cast(GTK_GAMMA_CURVE,val)
+ML_0 (gtk_gamma_curve_new, Val_GtkWidget_sink)
+Make_Extractor (gtk_gamma_curve_get, GtkGammaCurve_val, gamma, copy_double)
+
+/* gtkstatusbar.h */
+
+#define GtkStatusbar_val(val) check_cast(GTK_STATUSBAR,val)
+ML_0 (gtk_statusbar_new, Val_GtkWidget_sink)
+ML_2 (gtk_statusbar_get_context_id, GtkStatusbar_val, String_val, Val_int)
+ML_3 (gtk_statusbar_push, GtkStatusbar_val, Int_val, String_val, Val_int)
+ML_2 (gtk_statusbar_pop, GtkStatusbar_val, Int_val, Unit)
+ML_3 (gtk_statusbar_remove, GtkStatusbar_val, Int_val, Int_val, Unit)
+
+/* gtkcalendar.h */
+
+#define GtkCalendar_val(val) check_cast(GTK_CALENDAR,val)
+ML_0 (gtk_calendar_new, Val_GtkWidget_sink)
+ML_3 (gtk_calendar_select_month, GtkCalendar_val, Int_val, Int_val, Unit)
+ML_2 (gtk_calendar_select_day, GtkCalendar_val, Int_val, Unit)
+ML_2 (gtk_calendar_mark_day, GtkCalendar_val, Int_val, Unit)
+ML_2 (gtk_calendar_unmark_day, GtkCalendar_val, Int_val, Unit)
+ML_1 (gtk_calendar_clear_marks, GtkCalendar_val, Unit)
+Make_Flags_val (Calendar_display_options_val)
+ML_2 (gtk_calendar_display_options, GtkCalendar_val,
+ Flags_Calendar_display_options_val, Unit)
+value ml_gtk_calendar_get_date (value w)
+{
+ guint year, month, day;
+ value ret;
+
+ gtk_calendar_get_date (GtkCalendar_val(w), &year, &month, &day);
+ ret = alloc_small (3, 0);
+ Field(ret,0) = Val_int(year);
+ Field(ret,1) = Val_int(month);
+ Field(ret,2) = Val_int(day);
+ return ret;
+}
+ML_1 (gtk_calendar_freeze, GtkCalendar_val, Unit)
+ML_1 (gtk_calendar_thaw, GtkCalendar_val, Unit)
+
+/* gtkdrawingarea.h */
+
+#define GtkDrawingArea_val(val) check_cast(GTK_DRAWING_AREA,val)
+ML_0 (gtk_drawing_area_new, Val_GtkWidget_sink)
+ML_3 (gtk_drawing_area_size, GtkDrawingArea_val, Int_val, Int_val, Unit)
+
+/* gtkmisc.h */
+
+#define GtkMisc_val(val) check_cast(GTK_MISC,val)
+ML_3 (gtk_misc_set_alignment, GtkMisc_val, Double_val, Double_val, Unit)
+ML_3 (gtk_misc_set_padding, GtkMisc_val, Int_val, Int_val, Unit)
+Make_Extractor (gtk_misc_get, GtkMisc_val, xalign, copy_double)
+Make_Extractor (gtk_misc_get, GtkMisc_val, yalign, copy_double)
+Make_Extractor (gtk_misc_get, GtkMisc_val, xpad, Val_int)
+Make_Extractor (gtk_misc_get, GtkMisc_val, ypad, Val_int)
+
+/* gtkarrow.h */
+
+#define GtkArrow_val(val) check_cast(GTK_ARROW,val)
+ML_2 (gtk_arrow_new, Arrow_type_val, Shadow_type_val, Val_GtkWidget_sink)
+ML_3 (gtk_arrow_set, GtkArrow_val, Arrow_type_val, Shadow_type_val, Unit)
+
+/* gtkimage.h */
+
+#define GtkImage_val(val) check_cast(GTK_IMAGE,val)
+ML_2 (gtk_image_new, GdkImage_val,
+ Option_val (arg2, GdkBitmap_val, NULL) Ignore, Val_GtkWidget_sink)
+ML_3 (gtk_image_set, GtkImage_val, GdkImage_val,
+ Option_val (arg2, GdkBitmap_val, NULL) Ignore, Unit)
+
+/* gtklabel.h */
+
+#define GtkLabel_val(val) check_cast(GTK_LABEL,val)
+ML_1 (gtk_label_new, String_val, Val_GtkWidget_sink)
+ML_2 (gtk_label_set_text, GtkLabel_val, String_val, Unit)
+ML_2 (gtk_label_set_pattern, GtkLabel_val, String_val, Unit)
+ML_2 (gtk_label_set_justify, GtkLabel_val, Justification_val, Unit)
+ML_2 (gtk_label_set_line_wrap, GtkLabel_val, Bool_val, Unit)
+Make_Extractor (gtk_label_get, GtkLabel_val, label, Val_string)
+
+/* gtktipsquery.h */
+
+#define GtkTipsQuery_val(val) check_cast(GTK_TIPS_QUERY,val)
+ML_0 (gtk_tips_query_new, Val_GtkWidget_sink)
+ML_1 (gtk_tips_query_start_query, GtkTipsQuery_val, Unit)
+ML_1 (gtk_tips_query_stop_query, GtkTipsQuery_val, Unit)
+ML_2 (gtk_tips_query_set_caller, GtkTipsQuery_val, GtkWidget_val, Unit)
+ML_3 (gtk_tips_query_set_labels, GtkTipsQuery_val,
+ String_val, String_val, Unit)
+value ml_gtk_tips_query_set_emit_always (value w, value arg)
+{
+ GtkTipsQuery_val(w)->emit_always = Bool_val(arg);
+ return Val_unit;
+}
+Make_Extractor (gtk_tips_query_get, GtkTipsQuery_val, emit_always, Val_bool)
+Make_Extractor (gtk_tips_query_get, GtkTipsQuery_val, caller, Val_GtkWidget)
+Make_Extractor (gtk_tips_query_get, GtkTipsQuery_val, label_inactive,
+ Val_string)
+Make_Extractor (gtk_tips_query_get, GtkTipsQuery_val, label_no_tip,
+ Val_string)
+
+/* gtkpixmap.h */
+
+#define GtkPixmap_val(val) check_cast(GTK_PIXMAP,val)
+ML_2 (gtk_pixmap_new, GdkPixmap_val,
+ Option_val (arg2, GdkBitmap_val, NULL) Ignore,
+ Val_GtkWidget_sink)
+value ml_gtk_pixmap_set (value val, value pixmap, value mask)
+{
+ GtkPixmap *w = GtkPixmap_val(val);
+ gtk_pixmap_set (w, Option_val(pixmap,GdkPixmap_val,w->pixmap),
+ Option_val(mask,GdkBitmap_val,w->mask));
+ return Val_unit;
+}
+Make_Extractor (GtkPixmap, GtkPixmap_val, pixmap, Val_GdkPixmap)
+Make_Extractor (GtkPixmap, GtkPixmap_val, mask, Val_GdkBitmap)
+
+/* gtk[hv]separator.h */
+
+ML_0 (gtk_hseparator_new, Val_GtkWidget_sink)
+ML_0 (gtk_vseparator_new, Val_GtkWidget_sink)
--- /dev/null
+/* $Id$ */
+
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+
+static value ml_class_init=0;
+
+static void class_init (value class)
+{
+ callback(ml_class_init, class);
+}
+
+
+value set_ml_class_init (value class_func)
+{
+ if (!ml_class_init) register_global_root (&ml_class_init);
+ ml_class_init = class_func;
+ return Val_unit;
+}
+
+value ml_gtk_type_new (value type)
+{
+ return Val_GtkWidget_sink(gtk_type_new(Int_val(type)));
+}
+
+
+struct widget_info {
+ guint size;
+ guint class_size;
+ guint (*get_type_func)(void);
+}
+widget_info_array[] = {
+ { sizeof(GtkObject), sizeof(GtkObjectClass), gtk_object_get_type },
+ { sizeof(GtkWidget), sizeof(GtkWidgetClass), gtk_widget_get_type },
+ { sizeof(GtkMisc), sizeof(GtkMiscClass), gtk_misc_get_type },
+ { sizeof(GtkLabel), sizeof(GtkLabelClass), gtk_label_get_type },
+ { sizeof(GtkAccelLabel), sizeof(GtkAccelLabelClass), gtk_accel_label_get_type },
+ { sizeof(GtkTipsQuery), sizeof(GtkTipsQueryClass), gtk_tips_query_get_type },
+ { sizeof(GtkArrow), sizeof(GtkArrowClass), gtk_arrow_get_type },
+ { sizeof(GtkImage), sizeof(GtkImageClass), gtk_image_get_type },
+ { sizeof(GtkPixmap), sizeof(GtkPixmapClass), gtk_pixmap_get_type },
+ { sizeof(GtkContainer), sizeof(GtkContainerClass), gtk_container_get_type },
+ { sizeof(GtkBin), sizeof(GtkBinClass), gtk_bin_get_type },
+ { sizeof(GtkAlignment), sizeof(GtkAlignmentClass), gtk_alignment_get_type },
+ { sizeof(GtkFrame), sizeof(GtkFrameClass), gtk_frame_get_type },
+ { sizeof(GtkAspectFrame), sizeof(GtkAspectFrameClass), gtk_aspect_frame_get_type },
+ { sizeof(GtkButton), sizeof(GtkButtonClass), gtk_button_get_type },
+ { sizeof(GtkToggleButton), sizeof(GtkToggleButtonClass), gtk_toggle_button_get_type },
+ { sizeof(GtkCheckButton), sizeof(GtkCheckButtonClass), gtk_check_button_get_type },
+ { sizeof(GtkRadioButton), sizeof(GtkRadioButtonClass), gtk_radio_button_get_type },
+ { sizeof(GtkOptionMenu), sizeof(GtkOptionMenuClass), gtk_option_menu_get_type },
+ { sizeof(GtkItem), sizeof(GtkItemClass), gtk_item_get_type },
+ { sizeof(GtkMenuItem), sizeof(GtkMenuItemClass), gtk_menu_item_get_type },
+ { sizeof(GtkCheckMenuItem), sizeof(GtkCheckMenuItemClass), gtk_check_menu_item_get_type },
+ { sizeof(GtkRadioMenuItem), sizeof(GtkRadioMenuItemClass), gtk_radio_menu_item_get_type },
+ { sizeof(GtkTearoffMenuItem), sizeof(GtkTearoffMenuItemClass), gtk_tearoff_menu_item_get_type },
+ { sizeof(GtkListItem), sizeof(GtkListItemClass), gtk_list_item_get_type },
+ { sizeof(GtkTreeItem), sizeof(GtkTreeItemClass), gtk_tree_item_get_type },
+ { sizeof(GtkWindow), sizeof(GtkWindowClass), gtk_window_get_type },
+ { sizeof(GtkColorSelectionDialog), sizeof(GtkColorSelectionDialogClass), gtk_color_selection_dialog_get_type },
+ { sizeof(GtkDialog), sizeof(GtkDialogClass), gtk_dialog_get_type },
+ { sizeof(GtkInputDialog), sizeof(GtkInputDialogClass), gtk_input_dialog_get_type },
+ { sizeof(GtkFileSelection), sizeof(GtkFileSelectionClass), gtk_file_selection_get_type },
+ { sizeof(GtkFontSelectionDialog), sizeof(GtkFontSelectionDialogClass), gtk_font_selection_dialog_get_type },
+ { sizeof(GtkPlug), sizeof(GtkPlugClass), gtk_plug_get_type },
+ { sizeof(GtkEventBox), sizeof(GtkEventBoxClass), gtk_event_box_get_type },
+ { sizeof(GtkHandleBox), sizeof(GtkHandleBoxClass), gtk_handle_box_get_type },
+ { sizeof(GtkScrolledWindow), sizeof(GtkScrolledWindowClass), gtk_scrolled_window_get_type },
+ { sizeof(GtkViewport), sizeof(GtkViewportClass), gtk_viewport_get_type },
+ { sizeof(GtkBox), sizeof(GtkBoxClass), gtk_box_get_type },
+ { sizeof(GtkButtonBox), sizeof(GtkButtonBoxClass), gtk_button_box_get_type },
+ { sizeof(GtkHButtonBox), sizeof(GtkHButtonBoxClass), gtk_hbutton_box_get_type },
+ { sizeof(GtkVButtonBox), sizeof(GtkVButtonBoxClass), gtk_vbutton_box_get_type },
+ { sizeof(GtkVBox), sizeof(GtkVBoxClass), gtk_vbox_get_type },
+ { sizeof(GtkColorSelection), sizeof(GtkColorSelectionClass), gtk_color_selection_get_type },
+ { sizeof(GtkGammaCurve), sizeof(GtkGammaCurveClass), gtk_gamma_curve_get_type },
+ { sizeof(GtkHBox), sizeof(GtkHBoxClass), gtk_hbox_get_type },
+ { sizeof(GtkCombo), sizeof(GtkComboClass), gtk_combo_get_type },
+ { sizeof(GtkStatusbar), sizeof(GtkStatusbarClass), gtk_statusbar_get_type },
+ { sizeof(GtkCList), sizeof(GtkCListClass), gtk_clist_get_type },
+ { sizeof(GtkCTree), sizeof(GtkCTreeClass), gtk_ctree_get_type },
+ { sizeof(GtkFixed), sizeof(GtkFixedClass), gtk_fixed_get_type },
+ { sizeof(GtkNotebook), sizeof(GtkNotebookClass), gtk_notebook_get_type },
+ { sizeof(GtkFontSelection), sizeof(GtkFontSelectionClass), gtk_font_selection_get_type },
+ { sizeof(GtkPaned), sizeof(GtkPanedClass), gtk_paned_get_type },
+ { sizeof(GtkHPaned), sizeof(GtkHPanedClass), gtk_hpaned_get_type },
+ { sizeof(GtkVPaned), sizeof(GtkVPanedClass), gtk_vpaned_get_type },
+ { sizeof(GtkLayout), sizeof(GtkLayoutClass), gtk_layout_get_type },
+ { sizeof(GtkList), sizeof(GtkListClass), gtk_list_get_type },
+ { sizeof(GtkMenuShell), sizeof(GtkMenuShellClass), gtk_menu_shell_get_type },
+ { sizeof(GtkMenuBar), sizeof(GtkMenuBarClass), gtk_menu_bar_get_type },
+ { sizeof(GtkMenu), sizeof(GtkMenuClass), gtk_menu_get_type },
+ { sizeof(GtkPacker), sizeof(GtkPackerClass), gtk_packer_get_type },
+ { sizeof(GtkSocket), sizeof(GtkSocketClass), gtk_socket_get_type },
+ { sizeof(GtkTable), sizeof(GtkTableClass), gtk_table_get_type },
+ { sizeof(GtkToolbar), sizeof(GtkToolbarClass), gtk_toolbar_get_type },
+ { sizeof(GtkTree), sizeof(GtkTreeClass), gtk_tree_get_type },
+ { sizeof(GtkCalendar), sizeof(GtkCalendarClass), gtk_calendar_get_type },
+ { sizeof(GtkDrawingArea), sizeof(GtkDrawingAreaClass), gtk_drawing_area_get_type },
+ { sizeof(GtkCurve), sizeof(GtkCurveClass), gtk_curve_get_type },
+ { sizeof(GtkEditable), sizeof(GtkEditableClass), gtk_editable_get_type },
+ { sizeof(GtkEntry), sizeof(GtkEntryClass), gtk_entry_get_type },
+ { sizeof(GtkSpinButton), sizeof(GtkSpinButtonClass), gtk_spin_button_get_type },
+ { sizeof(GtkText), sizeof(GtkTextClass), gtk_text_get_type },
+ { sizeof(GtkRuler), sizeof(GtkRulerClass), gtk_ruler_get_type },
+ { sizeof(GtkHRuler), sizeof(GtkHRulerClass), gtk_hruler_get_type },
+ { sizeof(GtkVRuler), sizeof(GtkVRulerClass), gtk_vruler_get_type },
+ { sizeof(GtkRange), sizeof(GtkRangeClass), gtk_range_get_type },
+ { sizeof(GtkScale), sizeof(GtkScaleClass), gtk_scale_get_type },
+ { sizeof(GtkHScale), sizeof(GtkHScaleClass), gtk_hscale_get_type },
+ { sizeof(GtkVScale), sizeof(GtkVScaleClass), gtk_vscale_get_type },
+ { sizeof(GtkScrollbar), sizeof(GtkScrollbarClass), gtk_scrollbar_get_type },
+ { sizeof(GtkHScrollbar), sizeof(GtkHScrollbarClass), gtk_hscrollbar_get_type },
+ { sizeof(GtkVScrollbar), sizeof(GtkVScrollbarClass), gtk_vscrollbar_get_type },
+ { sizeof(GtkSeparator), sizeof(GtkSeparatorClass), gtk_separator_get_type },
+ { sizeof(GtkHSeparator), sizeof(GtkHSeparatorClass), gtk_hseparator_get_type },
+ { sizeof(GtkVSeparator), sizeof(GtkVSeparatorClass), gtk_vseparator_get_type },
+ { sizeof(GtkPreview), sizeof(GtkPreviewClass), gtk_preview_get_type },
+ { sizeof(GtkProgress), sizeof(GtkProgressClass), gtk_progress_get_type },
+ { sizeof(GtkProgressBar), sizeof(GtkProgressBarClass), gtk_progress_bar_get_type },
+ { sizeof(GtkData), sizeof(GtkDataClass), gtk_data_get_type },
+ { sizeof(GtkAdjustment), sizeof(GtkAdjustmentClass), gtk_adjustment_get_type },
+ { sizeof(GtkTooltips), sizeof(GtkTooltipsClass), gtk_tooltips_get_type },
+ { sizeof(GtkItemFactory), sizeof(GtkItemFactoryClass), gtk_item_factory_get_type }
+};
+
+
+value ml_gtk_type_unique (value name, value parent, value nsignals)
+{
+ struct widget_info * wi;
+ GtkTypeInfo ttt_info;
+
+ wi = widget_info_array + Int_val(parent);
+ ttt_info.type_name = String_val(name);
+ ttt_info.object_size = wi->size;
+ ttt_info.class_size = wi->class_size + Int_val(nsignals)*sizeof(void *);
+ ttt_info.class_init_func = (GtkClassInitFunc) class_init;
+ ttt_info.object_init_func = (GtkObjectInitFunc) NULL;
+ ttt_info.reserved_1 = NULL;
+ ttt_info.reserved_2 = NULL;
+ ttt_info.base_class_init_func = (GtkClassInitFunc) NULL;
+
+ return Val_int(gtk_type_unique(wi->get_type_func (), &ttt_info));
+}
+
+static guint sig[100];
+
+value ml_gtk_object_class_add_signals (value class, value signals,
+ value nsignals)
+{
+ int i;
+ for (i=0; i<nsignals; i++)
+ sig[i] = Int_val(Field(signals, i));
+ gtk_object_class_add_signals ((GtkObjectClass *)class,
+ sig, Int_val(nsignals));
+ return Val_unit;
+}
+
+value ml_gtk_signal_new (value name, value run_type, value classe,
+ value parent, value num)
+{
+ struct widget_info * wi;
+ int offset;
+
+ wi = widget_info_array + Int_val(parent);
+ offset = wi->class_size+Int_val(num)*sizeof(void *);
+ return Val_int(gtk_signal_new (String_val(name), Int_val(run_type),
+ ((GtkObjectClass *)classe)->type, offset,
+ gtk_signal_default_marshaller, GTK_TYPE_NONE, 0));
+ *(((int *)classe)+offset) = 0;
+}
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+static Make_Flags_val (Attach_options_val)
+
+/* gtkbox.h */
+
+#define GtkBox_val(val) check_cast(GTK_BOX,val)
+ML_5 (gtk_box_pack_start, GtkBox_val, GtkWidget_val, Bool_val, Bool_val,
+ Int_val, Unit)
+ML_5 (gtk_box_pack_end, GtkBox_val, GtkWidget_val, Bool_val, Bool_val,
+ Int_val, Unit)
+ML_2 (gtk_box_set_homogeneous, GtkBox_val, Bool_val, Unit)
+ML_2 (gtk_box_set_spacing, GtkBox_val, Int_val, Unit)
+ML_3 (gtk_box_reorder_child, GtkBox_val, GtkWidget_val, Int_val, Unit)
+value ml_gtk_box_query_child_packing (value box, value child)
+{
+ int expand, fill;
+ unsigned int padding;
+ GtkPackType pack_type;
+ value ret;
+ gtk_box_query_child_packing (GtkBox_val(box), GtkWidget_val(child),
+ &expand, &fill, &padding, &pack_type);
+ ret = alloc_small(4,0);
+ Field(ret,0) = Val_bool(expand);
+ Field(ret,1) = Val_bool(fill);
+ Field(ret,2) = Val_int(padding);
+ Field(ret,3) = Val_pack_type(pack_type);
+ return ret;
+}
+value ml_gtk_box_set_child_packing (value vbox, value vchild, value vexpand,
+ value vfill, value vpadding, value vpack)
+{
+ GtkBox *box = GtkBox_val(vbox);
+ GtkWidget *child = GtkWidget_val(vchild);
+ int expand, fill;
+ unsigned int padding;
+ GtkPackType pack;
+ gtk_box_query_child_packing (box, child, &expand, &fill, &padding, &pack);
+ gtk_box_set_child_packing (box, child,
+ Option_val(vexpand, Bool_val, expand),
+ Option_val(vfill, Bool_val, fill),
+ Option_val(vpadding, Int_val, padding),
+ Option_val(vpack, Pack_type_val, pack));
+ return Val_unit;
+}
+ML_bc6 (ml_gtk_box_set_child_packing)
+
+ML_2 (gtk_hbox_new, Bool_val, Int_val, Val_GtkWidget_sink)
+ML_2 (gtk_vbox_new, Bool_val, Int_val, Val_GtkWidget_sink)
+
+/* gtkbbox.h */
+
+#define GtkButtonBox_val(val) check_cast(GTK_BUTTON_BOX,val)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, spacing, Val_int)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, child_min_width, Val_int)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, child_min_height,
+ Val_int)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, child_ipad_x, Val_int)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, child_ipad_y, Val_int)
+Make_Extractor (gtk_button_box_get, GtkButtonBox_val, layout_style,
+ Val_button_box_style)
+ML_2 (gtk_button_box_set_spacing, GtkButtonBox_val, Int_val, Unit)
+ML_3 (gtk_button_box_set_child_size, GtkButtonBox_val,
+ Int_val, Int_val, Unit)
+ML_3 (gtk_button_box_set_child_ipadding, GtkButtonBox_val,
+ Int_val, Int_val, Unit)
+ML_2 (gtk_button_box_set_layout, GtkButtonBox_val, Button_box_style_val, Unit)
+ML_2 (gtk_button_box_set_child_size_default, Int_val, Int_val, Unit)
+ML_2 (gtk_button_box_set_child_ipadding_default, Int_val, Int_val, Unit)
+
+ML_0 (gtk_hbutton_box_new, Val_GtkWidget_sink)
+ML_0 (gtk_vbutton_box_new, Val_GtkWidget_sink)
+
+/* gtkfixed.h */
+
+#define GtkFixed_val(val) check_cast(GTK_FIXED,val)
+ML_0 (gtk_fixed_new, Val_GtkWidget_sink)
+ML_4 (gtk_fixed_put, GtkFixed_val, GtkWidget_val, (gint16)Long_val, (gint16)Long_val, Unit)
+ML_4 (gtk_fixed_move, GtkFixed_val, GtkWidget_val, (gint16)Long_val, (gint16)Long_val, Unit)
+
+/* gtklayout.h */
+
+#define GtkLayout_val(val) check_cast(GTK_LAYOUT,val)
+ML_2 (gtk_layout_new, GtkAdjustment_val, GtkAdjustment_val, Val_GtkWidget_sink)
+ML_4 (gtk_layout_put, GtkLayout_val, GtkWidget_val, Int_val, Int_val, Unit)
+ML_4 (gtk_layout_move, GtkLayout_val, GtkWidget_val, Int_val, Int_val, Unit)
+ML_3 (gtk_layout_set_size, GtkLayout_val, Int_val, Int_val, Unit)
+ML_1 (gtk_layout_get_hadjustment, GtkLayout_val, Val_GtkAny)
+ML_1 (gtk_layout_get_vadjustment, GtkLayout_val, Val_GtkAny)
+ML_2 (gtk_layout_set_hadjustment, GtkLayout_val, GtkAdjustment_val, Unit)
+ML_2 (gtk_layout_set_vadjustment, GtkLayout_val, GtkAdjustment_val, Unit)
+ML_1 (gtk_layout_freeze, GtkLayout_val, Unit)
+ML_1 (gtk_layout_thaw, GtkLayout_val, Unit)
+Make_Extractor (gtk_layout_get, GtkLayout_val, width, Val_int)
+Make_Extractor (gtk_layout_get, GtkLayout_val, height, Val_int)
+
+/* gtknotebook.h */
+
+#define GtkNotebook_val(val) check_cast(GTK_NOTEBOOK,val)
+ML_0 (gtk_notebook_new, Val_GtkWidget_sink)
+
+ML_5 (gtk_notebook_insert_page_menu, GtkNotebook_val, GtkWidget_val,
+ GtkWidget_val, GtkWidget_val, Int_val, Unit)
+ML_2 (gtk_notebook_remove_page, GtkNotebook_val, Int_val, Unit)
+
+ML_2 (gtk_notebook_set_tab_pos, GtkNotebook_val, Position_val, Unit)
+ML_2 (gtk_notebook_set_homogeneous_tabs, GtkNotebook_val, Bool_val, Unit)
+ML_2 (gtk_notebook_set_show_tabs, GtkNotebook_val, Bool_val, Unit)
+ML_2 (gtk_notebook_set_show_border, GtkNotebook_val, Bool_val, Unit)
+ML_2 (gtk_notebook_set_scrollable, GtkNotebook_val, Bool_val, Unit)
+ML_2 (gtk_notebook_set_tab_border, GtkNotebook_val, Int_val, Unit)
+ML_1 (gtk_notebook_popup_enable, GtkNotebook_val, Unit)
+ML_1 (gtk_notebook_popup_disable, GtkNotebook_val, Unit)
+
+ML_1 (gtk_notebook_get_current_page, GtkNotebook_val, Val_int)
+ML_2 (gtk_notebook_set_page, GtkNotebook_val, Int_val, Unit)
+ML_2 (gtk_notebook_get_nth_page, GtkNotebook_val, Int_val, Val_GtkWidget)
+ML_2 (gtk_notebook_page_num, GtkNotebook_val, GtkWidget_val, Val_int)
+ML_1 (gtk_notebook_next_page, GtkNotebook_val, Unit)
+ML_1 (gtk_notebook_prev_page, GtkNotebook_val, Unit)
+
+ML_2 (gtk_notebook_get_tab_label, GtkNotebook_val, GtkWidget_val,
+ Val_GtkWidget)
+ML_3 (gtk_notebook_set_tab_label, GtkNotebook_val, GtkWidget_val,
+ GtkWidget_val, Unit)
+ML_2 (gtk_notebook_get_menu_label, GtkNotebook_val, GtkWidget_val,
+ Val_GtkWidget)
+ML_3 (gtk_notebook_set_menu_label, GtkNotebook_val, GtkWidget_val,
+ GtkWidget_val, Unit)
+ML_3 (gtk_notebook_reorder_child, GtkNotebook_val, GtkWidget_val,
+ Int_val, Unit)
+
+
+/* gtkpacker.h */
+
+Make_OptFlags_val(Packer_options_val)
+
+#define GtkPacker_val(val) check_cast(GTK_PACKER,val)
+ML_0 (gtk_packer_new, Val_GtkWidget_sink)
+ML_10 (gtk_packer_add, GtkPacker_val, GtkWidget_val,
+ Option_val(arg3,Side_type_val,GTK_SIDE_TOP) Ignore,
+ Option_val(arg4,Anchor_type_val,GTK_ANCHOR_CENTER) Ignore,
+ OptFlags_Packer_options_val,
+ Option_val(arg6,Int_val,GtkPacker_val(arg1)->default_border_width) Ignore,
+ Option_val(arg7,Int_val,GtkPacker_val(arg1)->default_pad_x) Ignore,
+ Option_val(arg8,Int_val,GtkPacker_val(arg1)->default_pad_y) Ignore,
+ Option_val(arg9,Int_val,GtkPacker_val(arg1)->default_i_pad_x) Ignore,
+ Option_val(arg10,Int_val,GtkPacker_val(arg1)->default_i_pad_y) Ignore,
+ Unit)
+ML_bc10 (ml_gtk_packer_add)
+ML_5 (gtk_packer_add_defaults, GtkPacker_val, GtkWidget_val,
+ Option_val(arg3,Side_type_val,GTK_SIDE_TOP) Ignore,
+ Option_val(arg4,Anchor_type_val,GTK_ANCHOR_CENTER) Ignore,
+ OptFlags_Packer_options_val, Unit)
+ML_10 (gtk_packer_set_child_packing, GtkPacker_val, GtkWidget_val,
+ Option_val(arg3,Side_type_val,GTK_SIDE_TOP) Ignore,
+ Option_val(arg4,Anchor_type_val,GTK_ANCHOR_CENTER) Ignore,
+ OptFlags_Packer_options_val,
+ Option_val(arg6,Int_val,GtkPacker_val(arg1)->default_border_width) Ignore,
+ Option_val(arg7,Int_val,GtkPacker_val(arg1)->default_pad_x) Ignore,
+ Option_val(arg8,Int_val,GtkPacker_val(arg1)->default_pad_y) Ignore,
+ Option_val(arg9,Int_val,GtkPacker_val(arg1)->default_i_pad_x) Ignore,
+ Option_val(arg10,Int_val,GtkPacker_val(arg1)->default_i_pad_y) Ignore,
+ Unit)
+ML_bc10 (ml_gtk_packer_set_child_packing)
+ML_3 (gtk_packer_reorder_child, GtkPacker_val, GtkWidget_val,
+ Int_val, Unit)
+ML_2 (gtk_packer_set_spacing, GtkPacker_val, Int_val, Unit)
+value ml_gtk_packer_set_defaults (value w, value border_width,
+ value pad_x, value pad_y,
+ value i_pad_x, value i_pad_y)
+{
+ GtkPacker *p = GtkPacker_val(w);
+ if (Is_block(border_width))
+ gtk_packer_set_default_border_width (p,Int_val(Field(border_width,0)));
+ if (Is_block(pad_x) || Is_block(pad_y))
+ gtk_packer_set_default_pad
+ (p, Option_val(pad_x,Int_val,p->default_pad_x),
+ Option_val(pad_y,Int_val,p->default_pad_y));
+ if (Is_block(i_pad_x) || Is_block(i_pad_y))
+ gtk_packer_set_default_ipad
+ (p, Option_val(pad_x,Int_val,p->default_i_pad_x),
+ Option_val(pad_y,Int_val,p->default_i_pad_y));
+ return Val_unit;
+}
+ML_bc6 (ml_gtk_packer_set_defaults)
+
+/* gtkpaned.h */
+
+#define GtkPaned_val(val) check_cast(GTK_PANED,val)
+ML_0 (gtk_hpaned_new, Val_GtkWidget_sink)
+ML_0 (gtk_vpaned_new, Val_GtkWidget_sink)
+ML_2 (gtk_paned_add1, GtkPaned_val, GtkWidget_val, Unit)
+ML_2 (gtk_paned_add2, GtkPaned_val, GtkWidget_val, Unit)
+ML_2 (gtk_paned_set_handle_size, GtkPaned_val, (gint16)Int_val, Unit)
+ML_2 (gtk_paned_set_gutter_size, GtkPaned_val, (gint16)Int_val, Unit)
+Make_Extractor (gtk_paned, GtkPaned_val, child1, Val_GtkWidget)
+Make_Extractor (gtk_paned, GtkPaned_val, child2, Val_GtkWidget)
+Make_Extractor (gtk_paned, GtkPaned_val, handle_size, Val_int)
+Make_Extractor (gtk_paned, GtkPaned_val, gutter_size, Val_int)
+
+/* gtktable.h */
+
+#define GtkTable_val(val) check_cast(GTK_TABLE,val)
+ML_3 (gtk_table_new, Int_val, Int_val, Int_val, Val_GtkWidget_sink)
+ML_10 (gtk_table_attach, GtkTable_val, GtkWidget_val,
+ Int_val, Int_val, Int_val, Int_val,
+ Flags_Attach_options_val, Flags_Attach_options_val,
+ Int_val, Int_val, Unit)
+ML_bc10 (ml_gtk_table_attach)
+ML_3 (gtk_table_set_row_spacing, GtkTable_val, Int_val, Int_val, Unit)
+ML_3 (gtk_table_set_col_spacing, GtkTable_val, Int_val, Int_val, Unit)
+ML_2 (gtk_table_set_row_spacings, GtkTable_val, Int_val, Unit)
+ML_2 (gtk_table_set_col_spacings, GtkTable_val, Int_val, Unit)
+ML_2 (gtk_table_set_homogeneous, GtkTable_val, Bool_val, Unit)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtkprogress.h */
+
+#define GtkProgress_val(val) check_cast(GTK_PROGRESS,val)
+ML_2 (gtk_progress_set_show_text, GtkProgress_val, Bool_val, Unit)
+ML_3 (gtk_progress_set_text_alignment, GtkProgress_val,
+ Option_val(arg2,Float_val,(GtkProgress_val(arg1))->x_align) Ignore,
+ Option_val(arg3,Float_val,(GtkProgress_val(arg1))->y_align) Ignore, Unit)
+ML_2 (gtk_progress_set_format_string, GtkProgress_val, String_val, Unit)
+ML_2 (gtk_progress_set_adjustment, GtkProgress_val, GtkAdjustment_val, Unit)
+ML_4 (gtk_progress_configure, GtkProgress_val,
+ Float_val, Float_val, Float_val, Unit)
+ML_2 (gtk_progress_set_percentage, GtkProgress_val, Float_val, Unit)
+ML_2 (gtk_progress_set_value, GtkProgress_val, Float_val, Unit)
+ML_1 (gtk_progress_get_value, GtkProgress_val, copy_double)
+ML_1 (gtk_progress_get_current_percentage, GtkProgress_val, copy_double)
+ML_2 (gtk_progress_set_activity_mode, GtkProgress_val, Bool_val, Unit)
+ML_1 (gtk_progress_get_current_text, GtkProgress_val, Val_string)
+Make_Extractor (gtk_progress_get, GtkProgress_val, adjustment,
+ Val_GtkAny)
+
+/* gtkprogressbar.h */
+
+#define GtkProgressBar_val(val) check_cast(GTK_PROGRESS_BAR,val)
+ML_0 (gtk_progress_bar_new, Val_GtkWidget_sink)
+ML_1 (gtk_progress_bar_new_with_adjustment, GtkAdjustment_val,
+ Val_GtkWidget_sink)
+ML_2 (gtk_progress_bar_set_bar_style, GtkProgressBar_val,
+ Progress_bar_style_val, Unit)
+ML_2 (gtk_progress_bar_set_discrete_blocks, GtkProgressBar_val, Int_val, Unit)
+ML_2 (gtk_progress_bar_set_activity_step, GtkProgressBar_val, Int_val, Unit)
+ML_2 (gtk_progress_bar_set_activity_blocks, GtkProgressBar_val, Int_val, Unit)
+ML_2 (gtk_progress_bar_set_orientation, GtkProgressBar_val,
+ Progress_bar_orientation_val, Unit)
+/* ML_2 (gtk_progress_bar_update, GtkProgressBar_val, Float_val, Unit) */
+
+/* gtkrange.h */
+
+#define GtkRange_val(val) check_cast(GTK_RANGE,val)
+ML_1 (gtk_range_get_adjustment, GtkRange_val, Val_GtkAny)
+ML_2 (gtk_range_set_adjustment, GtkRange_val, GtkAdjustment_val, Unit)
+ML_2 (gtk_range_set_update_policy, GtkRange_val, Update_type_val, Unit)
+
+/* gtkscale.h */
+
+#define GtkScale_val(val) check_cast(GTK_SCALE,val)
+ML_2 (gtk_scale_set_digits, GtkScale_val, Int_val, Unit)
+ML_2 (gtk_scale_set_draw_value, GtkScale_val, Bool_val, Unit)
+ML_2 (gtk_scale_set_value_pos, GtkScale_val, Position_val, Unit)
+ML_1 (gtk_scale_get_value_width, GtkScale_val, Val_int)
+ML_1 (gtk_scale_draw_value, GtkScale_val, Unit)
+ML_1 (gtk_hscale_new, GtkAdjustment_val, Val_GtkWidget_sink)
+ML_1 (gtk_vscale_new, GtkAdjustment_val, Val_GtkWidget_sink)
+
+/* gtkscrollbar.h */
+
+ML_1 (gtk_hscrollbar_new, GtkAdjustment_val, Val_GtkWidget_sink)
+ML_1 (gtk_vscrollbar_new, GtkAdjustment_val, Val_GtkWidget_sink)
+
+/* gtkruler.h */
+
+#define GtkRuler_val(val) check_cast(GTK_RULER,val)
+ML_2 (gtk_ruler_set_metric, GtkRuler_val, Metric_type_val, Unit)
+ML_5 (gtk_ruler_set_range, GtkRuler_val, Float_val,
+ Float_val, Float_val, Float_val, Unit)
+Make_Extractor (gtk_ruler_get, GtkRuler_val, lower, copy_double)
+Make_Extractor (gtk_ruler_get, GtkRuler_val, upper, copy_double)
+Make_Extractor (gtk_ruler_get, GtkRuler_val, position, copy_double)
+Make_Extractor (gtk_ruler_get, GtkRuler_val, max_size, copy_double)
+ML_1 (gtk_ruler_draw_ticks, GtkRuler_val, Unit)
+ML_1 (gtk_ruler_draw_pos, GtkRuler_val, Unit)
+ML_0 (gtk_hruler_new, Val_GtkWidget_sink)
+ML_0 (gtk_vruler_new, Val_GtkWidget_sink)
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtk_tags.h"
+
+/* gtktreeitem.h */
+
+#define GtkTreeItem_val(val) check_cast(GTK_TREE_ITEM,val)
+ML_0 (gtk_tree_item_new, Val_GtkWidget_sink)
+ML_1 (gtk_tree_item_new_with_label, String_val, Val_GtkWidget_sink)
+ML_2 (gtk_tree_item_set_subtree, GtkTreeItem_val, GtkWidget_val, Unit)
+ML_1 (gtk_tree_item_remove_subtree, GtkTreeItem_val, Unit)
+ML_1 (gtk_tree_item_expand, GtkTreeItem_val, Unit)
+ML_1 (gtk_tree_item_collapse, GtkTreeItem_val, Unit)
+ML_1 (GTK_TREE_ITEM_SUBTREE, GtkTreeItem_val, Val_GtkWidget)
+
+/* gtktree.h */
+
+#define GtkTree_val(val) check_cast(GTK_TREE,val)
+ML_0 (gtk_tree_new, Val_GtkWidget_sink)
+ML_3 (gtk_tree_insert, GtkTree_val, GtkWidget_val, Int_val, Unit)
+ML_3 (gtk_tree_clear_items, GtkTree_val, Int_val, Int_val, Unit)
+ML_2 (gtk_tree_select_item, GtkTree_val, Int_val, Unit)
+ML_2 (gtk_tree_unselect_item, GtkTree_val, Int_val, Unit)
+ML_2 (gtk_tree_child_position, GtkTree_val, GtkWidget_val, Val_int)
+ML_2 (gtk_tree_set_selection_mode, GtkTree_val, Selection_mode_val, Unit)
+ML_2 (gtk_tree_set_view_mode, GtkTree_val, Tree_view_mode_val, Unit)
+ML_2 (gtk_tree_set_view_lines, GtkTree_val, Bool_val, Unit)
+
+static value val_gtkany (gpointer p) { return Val_GtkAny(p); }
+value ml_gtk_tree_selection (value tree)
+{
+ GList *selection = GTK_TREE_SELECTION(GtkTree_val(tree));
+ return Val_GList(selection, val_gtkany);
+}
+static gpointer gtkobject_val (value val) { return GtkObject_val(val); }
+value ml_gtk_tree_remove_items (value tree, value items)
+{
+ GList *items_list = GList_val (items, gtkobject_val);
+ gtk_tree_remove_items (GtkTree_val(tree), items_list);
+ return Val_unit;
+}
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <gtk/gtk.h>
+#include <gtk-xmhtml/gtk-xmhtml.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+#include "gtkxmhtml_tags.h"
+
+/* conversion functions */
+
+#include "gtkxmhtml_tags.c"
+
+Make_Flags_val (Line_type_val)
+
+#define GtkXmHTML_val(val) ((GtkXmHTML*)GtkObject_val(val))
+
+ML_0 (gtk_xmhtml_new, Val_GtkAny_sink)
+ML_1 (gtk_xmhtml_freeze, GtkXmHTML_val, Unit)
+ML_1 (gtk_xmhtml_thaw, GtkXmHTML_val, Unit)
+ML_2 (gtk_xmhtml_source, GtkXmHTML_val, String_val, Unit)
+ML_2 (gtk_xmhtml_set_string_direction, GtkXmHTML_val, String_direction_val,
+ Unit)
+ML_2 (gtk_xmhtml_set_alignment, GtkXmHTML_val, Alignment_val, Unit)
+/* ML_2 (gtk_xmhtml_outline, GtkXmHTML_val, Bool_val, Unit) */
+ML_3 (gtk_xmhtml_set_font_familty, GtkXmHTML_val, String_val, String_val, Unit)
+ML_3 (gtk_xmhtml_set_font_familty_fixed, GtkXmHTML_val, String_val, String_val,
+ Unit)
+ML_2 (gtk_xmhtml_set_font_charset, GtkXmHTML_val, String_val, Unit)
+ML_2 (gtk_xmhtml_set_allow_body_colors, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_hilight_on_enter, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_anchor_underline_type, GtkXmHTML_val, Flags_Line_type_val,
+ Unit)
+ML_2 (gtk_xmhtml_set_anchor_visited_underline_type, GtkXmHTML_val,
+ Flags_Line_type_val, Unit)
+ML_2 (gtk_xmhtml_set_anchor_target_underline_type, GtkXmHTML_val,
+ Flags_Line_type_val, Unit)
+ML_2 (gtk_xmhtml_set_allow_color_switching, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_dithering, GtkXmHTML_val, Dither_type_val, Unit)
+ML_2 (gtk_xmhtml_set_allow_font_switching, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_max_image_colors, GtkXmHTML_val, Int_val, Unit)
+ML_2 (gtk_xmhtml_set_allow_images, GtkXmHTML_val, Bool_val, Unit)
+ML_4 (gtk_xmhtml_set_plc_intervals, GtkXmHTML_val, Int_val, Int_val, Int_val,
+ Unit)
+/* ML_2 (gtk_xmhtml_set_def_body_image_url, GtkXmHTML_val, String_val, Unit) */
+ML_2 (gtk_xmhtml_set_anchor_buttons, GtkXmHTML_val, Bool_val, Unit)
+value ml_gtk_xmhtml_set_anchor_cursor(value html, value cursor)
+{
+ gtk_xmhtml_set_anchor_cursor
+ (GtkXmHTML_val(html), Option_val(cursor, GdkCursor_val, NULL),
+ Bool_val(cursor));
+ return Val_unit;
+}
+ML_2 (gtk_xmhtml_set_topline, GtkXmHTML_val, Int_val, Unit)
+ML_1 (gtk_xmhtml_get_topline, GtkXmHTML_val, Val_int)
+ML_2 (gtk_xmhtml_set_freeze_animations, GtkXmHTML_val, Bool_val, Unit)
+/* ML_1 (gtk_xmhtml_get_source, GtkXmHTML_val, copy_string) */
+ML_2 (gtk_xmhtml_set_screen_gamma, GtkXmHTML_val, Float_val, Unit)
+/* ML_2 (gtk_xmhtml_set_event_proc, GtkXmHTML_val, ???, Unit) */
+ML_2 (gtk_xmhtml_set_perfect_colors, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_uncompress_command, GtkXmHTML_val, String_val, Unit)
+ML_2 (gtk_xmhtml_set_strict_checking, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_bad_html_warnings, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_allow_form_coloring, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_imagemap_draw, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_mime_type, GtkXmHTML_val, String_val, Unit)
+ML_2 (gtk_xmhtml_set_alpha_processing, GtkXmHTML_val, Bool_val, Unit)
+ML_2 (gtk_xmhtml_set_rgb_conv_mode, GtkXmHTML_val, Dither_type_val, Unit)
--- /dev/null
+(* $Id$ *)
+
+(* Compile a list of variant tags into CPP defines *)
+
+(* hash_variant, from ctype.ml *)
+
+let hash_variant s =
+ let accu = ref 0 in
+ for i = 0 to String.length s - 1 do
+ accu := 223 * !accu + Char.code s.[i]
+ done;
+ (* reduce to 31 bits *)
+ accu := !accu land (1 lsl 31 - 1);
+ (* make it signed for 64 bits architectures *)
+ if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+open Genlex
+
+let lexer = make_lexer ["type"; "public"; "="; "["; "]"; "`"; "|"]
+
+let may_string = parser
+ [< ' String s >] -> s
+ | [< >] -> ""
+
+let may_bar = parser
+ [< ' Kwd "|" >] -> ()
+ | [< >] -> ()
+
+let rec ident_list = parser
+ [< ' Kwd "`"; ' Ident x; trans = may_string; _ = may_bar; s >] ->
+ (x, trans) :: ident_list s
+ | [< >] -> []
+
+let static = ref false
+let may_public = parser
+ [< ' Kwd "public" >] -> true
+ | [< ' Kwd "private" >] -> false
+ | [< >] -> not !static
+
+open Printf
+
+let hashes = Hashtbl.create 57
+
+let declaration ~hc ~cc = parser
+ [< ' Kwd "type"; public = may_public; ' Ident name; ' Kwd "=";
+ prefix = may_string; ' Kwd "["; _ = may_bar;
+ tags = ident_list; ' Kwd "]"; suffix = may_string >] ->
+ let oh x = fprintf hc x and oc x = fprintf cc x in
+ (* Output tag values to headers *)
+ let first = ref true in
+ List.iter tags ~f:
+ begin fun (tag, _) ->
+ let hash = hash_variant tag in
+ try
+ let tag' = Hashtbl.find hashes hash in
+ if tag <> tag' then
+ failwith (String.concat ~sep:" " ["Doublon tag:";tag;"and";tag'])
+ with Not_found ->
+ Hashtbl.add ~key:hash ~data:tag hashes;
+ if !first then begin
+ oh "/* %s : tags and macros */\n" name; first := false
+ end;
+ oh "#define MLTAG_%s\tVal_int(%d)\n" tag hash;
+ end;
+ (* compute C name *)
+ let ctag tag trans =
+ if trans <> "" then trans else
+ let tag =
+ if tag.[0] = '_' then
+ String.sub tag ~pos:1 ~len:(String.length tag -1)
+ else tag
+ in
+ match
+ if prefix = "" then None, ""
+ else
+ Some (prefix.[String.length prefix - 1]),
+ String.sub prefix ~pos:0 ~len:(String.length prefix - 1)
+ with
+ Some '#', prefix ->
+ prefix ^ String.uncapitalize tag ^ suffix
+ | Some '^', prefix ->
+ prefix ^ String.uppercase tag ^ suffix
+ | _ ->
+ prefix ^ tag ^ suffix
+ and cname =
+ String.capitalize name
+ in
+ let tags =
+ Sort.list tags
+ ~order:(fun (tag1,_) (tag2,_) -> hash_variant tag1 < hash_variant tag2)
+ in
+ (* Output table to code file *)
+ oc "/* %s : conversion table */\n" name;
+ let static = if not public then "static " else "" in
+ oc "%slookup_info ml_table_%s[] = {\n" static name;
+ oc " { 0, %d },\n" (List.length tags);
+ List.iter tags ~f:
+ begin fun (tag,trans) ->
+ oc " { MLTAG_%s, %s },\n" tag (ctag tag trans)
+ end;
+ oc "};\n\n";
+ (* Output macros to headers *)
+ if not !first then oh "\n";
+ if public then oh "extern lookup_info ml_table_%s[];\n" name;
+ oh "#define Val_%s(data) ml_lookup_from_c (ml_table_%s, data)\n"
+ name name;
+ oh "#define %s_val(key) ml_lookup_to_c (ml_table_%s, key)\n\n"
+ cname name;
+ | [< >] -> raise End_of_file
+
+
+let process ic ~hc ~cc =
+ let chars = Stream.of_channel ic in
+ let s = lexer chars in
+ try
+ while true do declaration s ~hc ~cc done
+ with End_of_file -> ()
+ | Stream.Error err ->
+ failwith
+ (Printf.sprintf "Parsing error \"%s\" at character %d on input stream"
+ err (Stream.count chars))
+
+let main () =
+ let inputs = ref [] in
+ let header = ref "" in
+ let code = ref "" in
+ Arg.parse ~errmsg:"usage: varcc [options] file.var" ~keywords:
+ [ "-h", Arg.String ((:=) header), "file to output macros (file.h)";
+ "-c", Arg.String ((:=) code),
+ "file to output conversion tables (file.c)";
+ "-static", Arg.Set static, "do not export conversion tables" ]
+ ~others:(fun s -> inputs := s :: !inputs);
+ let inputs = List.rev !inputs in
+ begin match inputs with
+ | [] ->
+ if !header = "" then header := "a.h";
+ if !code = "" then code := "a.c"
+ | ip :: _ ->
+ let rad =
+ if Filename.check_suffix ip ".var" then Filename.chop_extension ip
+ else ip in
+ if !header = "" then header := rad ^ ".h";
+ if !code = "" then code := rad ^ ".c"
+ end;
+ let hc = open_out !header and cc = open_out !code in
+ let chars = Stream.of_channel stdin in
+ if inputs = [] then process stdin ~hc ~cc else begin
+ List.iter inputs ~f:
+ begin fun file ->
+ let ic = open_in file in
+ try process ic ~hc ~cc; close_in ic
+ with exn -> close_in ic; prerr_endline ("Error in " ^ file); raise exn
+ end
+ end;
+ close_out hc; close_out cc
+
+let _ = Printexc.print main ()
--- /dev/null
+/* $Id$ */
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+
+value copy_memblock_indirected (void *src, asize_t size)
+{
+ value ret = alloc (Wosize_asize(size)+2, Abstract_tag);
+ if (!src) ml_raise_null_pointer ();
+
+ Field(ret,1) = 2;
+ memcpy (&Field(ret,2), src, size);
+ return ret;
+}
+
+value ml_some (value v)
+{
+ CAMLparam1(v);
+ value ret = alloc_small(1,0);
+ Field(ret,0) = v;
+ CAMLreturn(ret);
+}
+
+void ml_raise_null_pointer ()
+{
+ static value * exn = NULL;
+ if (exn == NULL)
+ exn = caml_named_value ("null_pointer");
+ raise_constant (*exn);
+}
+
+value Val_pointer (void *ptr)
+{
+ value ret = alloc_small (2, Abstract_tag);
+ if (!ptr) ml_raise_null_pointer ();
+ Field(ret,1) = (value)ptr;
+ return ret;
+}
+
+value copy_string_check (const char*str)
+{
+ if (!str) ml_raise_null_pointer ();
+ return copy_string ((char*) str);
+}
+
+value copy_string_or_null (const char*str)
+{
+ return copy_string (str ? (char*) str : "");
+}
+
+value *ml_global_root_new (value v)
+{
+ value *p = stat_alloc(sizeof(value));
+ *p = v;
+ register_global_root (p);
+ return p;
+}
+
+void ml_global_root_destroy (void *data)
+{
+ remove_global_root ((value *)data);
+ stat_free (data);
+}
+
+value ml_lookup_from_c (lookup_info *table, int data)
+{
+ int i;
+ for (i = table[0].data; i > 0; i--)
+ if (table[i].data == data) return table[i].key;
+ invalid_argument ("ml_lookup_from_c");
+}
+
+int ml_lookup_to_c (lookup_info *table, value key)
+{
+ int first = 1, last = table[0].data, current;
+
+ while (first < last) {
+ current = (first+last)/2;
+ if (table[current].key >= key) last = current;
+ else first = current + 1;
+ }
+ if (table[first].key == key) return table[first].data;
+ invalid_argument ("ml_lookup_to_c");
+}
--- /dev/null
+/* $Id$ */
+
+#ifndef _wrappers_
+#define _wrappers_
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+
+value copy_memblock_indirected (void *src, asize_t size);
+value ml_some (value);
+void ml_raise_null_pointer (void) Noreturn;
+value Val_pointer (void *);
+value copy_string_check (const char*);
+value copy_string_or_null (const char *);
+
+value *ml_global_root_new (value v);
+void ml_global_root_destroy (void *data);
+
+typedef struct { value key; int data; } lookup_info;
+value ml_lookup_from_c (lookup_info *table, int data);
+int ml_lookup_to_c (lookup_info *table, value key);
+
+/* Wrapper generators */
+
+#define ML_0(cname, conv) \
+value ml_##cname (value unit) { return conv (cname ()); }
+#define ML_1(cname, conv1, conv) \
+value ml_##cname (value arg1) { return conv (cname (conv1 (arg1))); }
+#define ML_1_post(cname, conv1, conv, post) \
+value ml_##cname (value arg1) \
+{ value ret = conv (cname (conv1(arg1))); post; return ret; }
+#define ML_2(cname, conv1, conv2, conv) \
+value ml_##cname (value arg1, value arg2) \
+{ return conv (cname (conv1(arg1), conv2(arg2))); }
+#define ML_2_name(mlname, cname, conv1, conv2, conv) \
+value mlname (value arg1, value arg2) \
+{ return conv (cname (conv1(arg1), conv2(arg2))); }
+#define ML_3(cname, conv1, conv2, conv3, conv) \
+value ml_##cname (value arg1, value arg2, value arg3) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); }
+#define ML_3_name(mlname, cname, conv1, conv2, conv3, conv) \
+value mlname (value arg1, value arg2, value arg3) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); }
+#define ML_4(cname, conv1, conv2, conv3, conv4, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); }
+#define ML_4_name(mlname, cname, conv1, conv2, conv3, conv4, conv) \
+value mlname (value arg1, value arg2, value arg3, value arg4) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); }
+#define ML_5(cname, conv1, conv2, conv3, conv4, conv5, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5))); }
+#define ML_6(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6))); }
+#define ML_7(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7))); }
+#define ML_8(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
+ conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7, value arg8) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8))); }
+#define ML_9(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
+ conv9, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7, value arg8, value arg9) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
+ conv9(arg9))); }
+#define ML_10(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
+ conv9, conv10, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7, value arg8, value arg9, value arg10)\
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
+ conv9(arg9), conv10(arg10))); }
+#define ML_11(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
+ conv9, conv10, conv11, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7, value arg8, value arg9, value arg10,\
+ value arg11) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
+ conv9(arg9), conv10(arg10), conv11(arg11))); }
+#define ML_12(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
+ conv9, conv10, conv11, conv12, conv) \
+value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
+ value arg6, value arg7, value arg8, value arg9, value arg10,\
+ value arg11, value arg12) \
+{ return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
+ conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
+ conv9(arg9), conv10(arg10), conv11(arg11), \
+ conv12(arg12))); }
+
+/* Use with care: needs the argument index */
+#define Ignore(x)
+#define Insert(x) (x),
+#define Split(x,f,g) f(x), g(x) Ignore
+#define Split3(x,f,g,h) f(x), g(x), h(x) Ignore
+#define Pair(x,f,g) f(Field(x,0)), g(Field(x,1)) Ignore
+#define Triple(x,f,g,h) f(Field(x,0)), g(Field(x,1)), h(Field(x,2)) Ignore
+
+/* For more than 5 arguments */
+#define ML_bc6(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5]); }
+#define ML_bc7(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6]); }
+#define ML_bc8(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
+ argv[7]); }
+#define ML_bc9(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
+ argv[7],argv[8]); }
+#define ML_bc10(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
+ argv[7],argv[8],argv[9]); }
+#define ML_bc11(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
+ argv[7],argv[8],argv[9],argv[10]); }
+#define ML_bc12(cname) \
+value cname##_bc (value *argv, int argn) \
+{ return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
+ argv[7],argv[8],argv[9],argv[10],argv[11]); }
+
+/* result conversion */
+#define Unit(x) ((x), Val_unit)
+#define Id(x) x
+#define Val_char Val_int
+
+/* parameter conversion */
+#define Bool_ptr(x) ((long) x - 1)
+#define Char_val Int_val
+#define Float_val(x) ((float)Double_val(x))
+
+#define Option_val(val,unwrap,default) \
+((long)val-1 ? unwrap(Field(val,0)) : default)
+#define String_option_val(s) Option_val(s,String_val,NULL)
+
+/* Utility */
+
+#define Copy_array(ret,l,src,conv) \
+ if (!l) ret = Atom(0); \
+ else if (l <= Max_young_wosize) { int i; ret = alloc_tuple(l); \
+ for(i=0;i<l;i++) Field(ret,i) = conv(src[i]); } \
+ else { int i; ret = alloc_shr(l,0); \
+ for(i=0;i<l;i++) initialize (&Field(ret,i), conv(src[i])); }
+
+#define Make_Val_final_pointer(type, init, final, adv) \
+static void ml_final_##type (value val) \
+{ if (Field(val,1)) final ((type*)Field(val,1)); } \
+value Val_##type (type *p) \
+{ value ret; if (!p) ml_raise_null_pointer(); \
+ ret = alloc_final (2, ml_final_##type, adv, 1000); \
+ initialize (&Field(ret,1), (value) p); init(p); return ret; }
+
+#define Make_Val_final_pointer_ext(type, ext, init, final, adv) \
+static void ml_final_##type##ext (value val) \
+{ if (Field(val,1)) final ((type*)Field(val,1)); } \
+value Val_##type##ext (type *p) \
+{ value ret; if (!p) ml_raise_null_pointer(); \
+ ret = alloc_final (2, ml_final_##type##ext, adv, 1000); \
+ initialize (&Field(ret,1), (value) p); init(p); return ret; }
+
+#define Pointer_val(val) ((void*)Field(val,1))
+#define MLPointer_val(val) (Field(val,1) == 2 ? &Field(val,2) : (void*)Field(val,1))
+
+#define Val_addr(ptr) (1+(value)ptr)
+#define Addr_val(val) ((void*)(val-1))
+
+#define Wosize_asize(x) ((x-1)/sizeof(value)+1)
+#define Wosizeof(x) Wosize_asize(sizeof(x))
+
+#define Make_Extractor(name,conv1,field,conv2) \
+value ml_##name##_##field (value val) \
+{ return conv2 ((conv1(val))->field); }
+
+#define Make_Setter(name,conv1,conv2,field) \
+value ml_##name##_##field (value val, value new) \
+{ (conv1(val))->field = conv2(new); return Val_unit; }
+
+#define Make_Array_Extractor(name,conv1,conv2,field,conv) \
+value ml_##name##_##field (value val, value index) \
+{ return conv ((conv1(val))->field[conv2(index)]); }
+
+#define Make_Array_Setter(name,conv1,conv2,conv3,field) \
+value ml_##name##_##field (value val, value index, value new) \
+{ (conv1(val))->field[conv2(index)] = conv3(new); return Val_unit; }
+
+/* ML value is [flag list] */
+#define Make_Flags_val(conv) \
+int Flags_##conv (value list) \
+{ int flags = 0L; \
+ while Is_block(list) { flags |= conv(Field(list,0)); list = Field(list,1); }\
+ return flags; }
+
+/* ML value is [flag list option] */
+#define Make_OptFlags_val(conv) \
+int OptFlags_##conv (value list) \
+{ int flags = 0L; \
+ if Is_block(list) list = Field(list,0); \
+ while Is_block(list) { flags |= conv(Field(list,0)); list = Field(list,1); }\
+ return flags; }
+
+#define Val_copy(val) copy_memblock_indirected (&val, sizeof(val))
+#define Val_string copy_string_check
+#define Val_optstring copy_string_or_null
+#define Optstring_val(v) (string_length(v) ? String_val(v) : (char*)NULL)
+#define Val_option(v,f) (v ? ml_some(f(v)) : Val_unit)
+
+#define Check_null(v) (v ? v : (ml_raise_null_pointer (), v))
+
+#endif /* _wrappers_ */
projects / helm.git / commitdiff