diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..f58b073
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+labltklink
+labltkopt
+Makefile.config
+config.status
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..dde07fd
--- /dev/null
+++ b/Changes
@@ -0,0 +1,82 @@
+2017-10-30:
+-----------
+* Release labltk-8.06.4, for ocaml 4.06
+
+2017-09-19:
+-----------
+* prepare for 4.06: -safe-string transition and browser updates
+
+2017-07-19:
+-----------
+* Release labltk-8.06.3, for ocaml 4.05
+* Various fixes for ocaml 4.05 (merge debian patches by Stephane Glondu)
+
+2017-05-15:
+-----------
+* Fix configuration and Makefile for OCaml 4.06
+
+2016-08-13:
+-----------
+* suppress gcc warning about unused variable (Damien Doligez)
+
+2016-08-10:
+-----------
+* Release labltk-8.06.2, for ocaml 4.04
+
+2016-08-02:
+-----------
+* update browser for 4.04
+
+2016-04-28:
+-----------
+* Fix warning 52
+
+2016-04-27:
+-----------
+* Release labltk-8.06.1
+* Adapt to ocaml 4.03
+* Fix const qualifiers in C code
+
+2014-12-22:
+-----------
+* Adapt to changes in trunk
+
+2014-09-18:
+-----------
+* Release labltk-8.06.0
+* Improve configuration, and allow using findlib for installation
+* Fix PR#1423: Tkvars.version() call gives Fatal error
+* Fix PR#1411: some void-returning functions are wrongly declared with CAMLprim
+* Fix PR#1412: wrong declaration for argument of camltk_tk_mainloop
+
+2014-08-21:
+-----------
+* Add command line flags in ocamlbrowser for -safe-string and -short-paths.
+
+2014-05-22:
+-----------
+* Update for 4.02.
+
+2013-12-17:
+-----------
+* Add INSTALL file.
+* Update for ocaml trunk.
+* Modify tkcompiler to allow widgets with name containing special characters.
+
+2005-12-20:
+-----------
+* Add Protocol.do_one_event and Protocol.do_pending.
+
+2002-05-03:
+-----------
+General Changes
+* Merging CamlTk and LablTk API interfaces
+* Activate and Deactivate Events are added
+* Virtual events support
+* Added UTF conversion
+
+Incompatibilities between the previous camltk/labltk versions
+* CamlTk's bind_tag and bind_class superseded tag_bind and class_bind.
+* added optional arguments to some functions of CamlTk.
+* The library name libfrx and libjpf are changed to frxlib and jpflib
+ respectively, to avoid the library name confusion.
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 0000000..c57d761
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,77 @@
+ Installing LablTk from sources
+ ------------------------------
+
+PREREQUISITES
+
+* OCaml (>= 4.02) should be installed
+
+* Tcl/Tk (>= 8.03) should be installed
+
+INSTALLATION INSTRUCTIONS FOR UNIX AND OSX
+
+1- Configure the system. From the top directory, do:
+
+ ./configure
+
+In case of success, this generates config/Makefile which contains the
+OCaml library path and compilation options.
+
+The "configure" script accepts the following options:
+
+-use-findlib
+ If you want to use ocamlfind for installation.
+
+-libdir
(default: `ocamlc -where`)
+ Directory where the OCaml library was installed,
+ where Makefile.config can be found.
+
+-installdir (default: libdir/labltk)
+-installbindir (default: same as ocamlc)
+ Where to install the library and the labltk script.
+ When using findlib, the default is taken from it.
+
+-tkdefs (default: none)
+-tklibs (default: determined automatically)
+ These options specify where to find the Tcl/Tk libraries for
+ LablTk. "-tkdefs" helps to find the headers, and "-tklibs"
+ the C libraries. "-tklibs" may contain either only -L/path and
+ -Wl,... flags, in which case the library names are determined
+ automatically, or the actual libraries, which are used as given.
+ Examples:
+ for an OSX installation using macports, use just
+ ./configure -tklibs -L/opt/local/lib -tkdefs -I/opt/local/include
+ for Japanese Tcl/Tk whose headers are in specific directories
+ and libraries in /usr/local/lib, you can use
+ ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp"
+ -tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp"
+
+-tk-no-x11
+ Build LablTk without using X11. This option is needed on
+ Cygwin, or if you want to use the Quartz version on Tk on OSX.
+
+-verbose
+ Verbose output of the configuration tests. Use it if the outcome
+ of configure is not what you were expecting.
+
+2- From the top directory do
+
+ make all
+
+and optionally
+
+ make opt
+
+3- From the top directory do
+
+ make install
+
+It will install labltk at the above defined location.
+You may need to become superuser first.
+
+
+INSTALLATION INSTRUCTIONS FOR WINDOWS
+
+1- In the config subdirectory, overwrite Makefile with the file
+corresponding to your system
+
+2- Continue from step 2 above
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..23c14e3
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,109 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+# Top Makefile for mlTk
+
+SUBDIRS=compiler support lib jpf frx examples_labltk \
+ examples_camltk browser
+SUBDIRS_GENERATED=camltk labltk
+include config/Makefile
+
+all:
+ cd support; $(MAKE)
+ cd compiler; $(MAKE)
+ cd labltk; $(MAKE) -f Makefile.gen
+ cd labltk; $(MAKE)
+ cd camltk; $(MAKE) -f Makefile.gen
+ cd camltk; $(MAKE)
+ cd lib; $(MAKE)
+ cd jpf; $(MAKE)
+ cd frx; $(MAKE)
+ cd browser; $(MAKE)
+
+allopt:
+ cd support; $(MAKE) opt
+ cd labltk; $(MAKE) -f Makefile.gen
+ cd labltk; $(MAKE) opt
+ cd camltk; $(MAKE) -f Makefile.gen
+ cd camltk; $(MAKE) opt
+ cd lib; $(MAKE) opt
+ cd jpf; $(MAKE) opt
+ cd frx; $(MAKE) opt
+
+byte: all
+opt: allopt
+
+.PHONY: all allopt byte opt apiref
+.PHONY: labltk camltk examples examples_labltk examples_camltk
+.PHONY: install installopt partialclean clean depend
+
+labltk: Widgets.src
+ compiler/tkcompiler -outdir labltk
+ cd labltk; $(MAKE)
+
+camltk: Widgets.src
+ compiler/tkcompiler -camltk -outdir camltk
+ cd camltk; $(MAKE)
+
+examples: examples_labltk examples_camltk
+
+examples_labltk:
+ cd examples_labltk; $(MAKE) all
+
+examples_camltk:
+ cd examples_camltk; $(MAKE) all
+
+SUPPORTMLIS= fileevent support textvariable timer tkthread widget
+apiref:
+ $(BINDIR)/ocamldoc -I +threads -I support -I labltk $(SUPPORTMLIS:%=support/%.mli) labltk/*.mli labltk/tk.ml -sort -d htdocs/apiref -html || echo "There were errors"
+
+install:
+ cd support; $(MAKE) install
+ cd lib; $(MAKE) install
+ cd labltk; $(MAKE) install
+ cd camltk; $(MAKE) install
+ cd compiler; $(MAKE) install
+ cd jpf; $(MAKE) install
+ cd frx; $(MAKE) install
+ cd browser; $(MAKE) install
+ if test -f lib/labltk.cmxa; then $(MAKE) installopt; else :; fi
+
+installopt:
+ cd support; $(MAKE) installopt
+ cd lib; $(MAKE) installopt
+ cd labltk; $(MAKE) installopt
+ cd camltk; $(MAKE) installopt
+ cd jpf; $(MAKE) installopt
+ cd frx; $(MAKE) installopt
+
+uninstall:
+ ocamlfind remove labltk
+ rm -f $(INSTALLBINDIR)/labltk
+ rm -f $(INSTALLBINDIR)/ocamlbrowser$(EXE)
+
+reinstall:
+ $(MAKE) uninstall
+ $(MAKE) install
+
+partialclean clean:
+ for d in $(SUBDIRS); do \
+ cd $$d; $(MAKE) -f Makefile clean; cd ..; \
+ done
+ for d in $(SUBDIRS_GENERATED); do \
+ cd $$d; $(MAKE) -f Makefile.gen clean; cd ..; \
+ done
+
+depend:
diff --git a/Makefile.gen b/Makefile.gen
new file mode 100644
index 0000000..35bc34d
--- /dev/null
+++ b/Makefile.gen
@@ -0,0 +1,72 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include ../support/Makefile.common
+
+all: tk.ml # labltk.ml .depend
+
+ # all 3 dependencies are generated by the same rule. When the
+ # target 'all' depends on the 3 files, a 'make -jN' will spawn 3
+ # shell processes, and generate all files 3 times in parallel...
+
+_tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE)
+ cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -outdir labltk
+
+# dependencies are broken: wouldn't work with gmake 3.77
+
+#tk.ml labltk.ml .depend: generate
+
+tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml
+ (echo 'open StdLabels'; \
+ echo 'open Widget'; \
+ echo 'open Protocol'; \
+ echo 'open Support'; \
+ echo 'open Textvariable'; \
+ cat ../builtin/report.ml; \
+ cat ../builtin/builtin_*.ml; \
+ cat _tkgen.ml; \
+ echo ; \
+ echo ; \
+ echo 'module Tkintf = struct'; \
+ cat ../builtin/builtini_*.ml; \
+ cat _tkigen.ml; \
+ echo 'end (* module Tkintf *)'; \
+ echo ; \
+ echo ; \
+ echo 'open Tkintf' ;\
+ echo ; \
+ echo ; \
+ cat ../builtin/builtinf_*.ml; \
+ cat _tkfgen.ml; \
+ echo ; \
+ ) > _tk.ml
+ $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml
+ rm -f _tk.ml
+ $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
+
+../compiler/pp$(EXE):
+ cd ../compiler; $(MAKE) pp$(EXE)
+
+../compiler/tkcompiler$(EXE):
+ cd ../compiler; $(MAKE) tkcompiler$(EXE)
+
+# All .{ml,mli} files are generated in this directory
+clean:
+ rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend
+
+# rm -f modules
+
+.PHONY: all generate clean
diff --git a/Makefile.gen.nt b/Makefile.gen.nt
new file mode 100644
index 0000000..4feb527
--- /dev/null
+++ b/Makefile.gen.nt
@@ -0,0 +1,17 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include Makefile.gen
diff --git a/Makefile.nt b/Makefile.nt
new file mode 100644
index 0000000..e90f3e7
--- /dev/null
+++ b/Makefile.nt
@@ -0,0 +1,76 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2000 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+# Top Makefile for LablTk
+
+include config/Makefile
+
+
+
+SUBDIRS=compiler support lib labltk camltk jpf frx examples_labltk examples_camltk browser
+
+all:
+ cd support ; $(MAKEREC)
+ cd compiler ; $(MAKEREC)
+ cd labltk ; $(MAKECMD) -f Makefile.gen.nt
+ cd labltk ; $(MAKEREC)
+ cd camltk ; $(MAKECMD) -f Makefile.gen.nt
+ cd camltk ; $(MAKEREC)
+ cd lib ; $(MAKEREC)
+ cd jpf ; $(MAKEREC)
+ cd frx ; $(MAKEREC)
+ cd browser ; $(MAKEREC)
+
+allopt:
+ cd support ; $(MAKEREC) opt
+ cd labltk ; $(MAKECMD) -f Makefile.gen.nt
+ cd labltk ; $(MAKEREC) opt
+ cd camltk ; $(MAKECMD) -f Makefile.gen.nt
+ cd camltk ; $(MAKEREC) opt
+ cd lib ; $(MAKEREC) opt
+ cd jpf ; $(MAKEREC) opt
+ cd frx ; $(MAKEREC) opt
+
+.PHONY: examples_labltk examples_camltk
+
+examples: examples_labltk examples_camltk
+
+examples_labltk:
+ cd examples_labltk; $(MAKE) all
+
+examples_camltk:
+ cd examples_camltk; $(MAKE) all
+
+install:
+ cd labltk ; $(MAKEREC) install
+ cd camltk ; $(MAKEREC) install
+ cd lib ; $(MAKEREC) install
+ cd support ; $(MAKEREC) install
+ cd compiler ; $(MAKEREC) install
+ cd jpf ; $(MAKEREC) install
+ cd frx ; $(MAKEREC) install
+ cd browser ; $(MAKEREC) install
+
+installopt:
+ cd support ; $(MAKEREC) installopt
+ cd labltk ; $(MAKEREC) installopt
+ cd camltk ; $(MAKEREC) installopt
+ cd lib ; $(MAKEREC) installopt
+ cd jpf ; $(MAKEREC) installopt
+ cd frx ; $(MAKEREC) installopt
+
+partialclean clean:
+ for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..0789125
--- /dev/null
+++ b/README.md
@@ -0,0 +1,7 @@
+LablTk is an interface to the Tcl/Tk GUI framework. It allows to develop GUI applications in a speedy and type safe way. A legacy Camltk interface is included. The OCamlBrowser library viewer is also part of this project.
+
+The project page is:
+https://forge.ocamlcore.org/projects/labltk/
+
+You can find documentation here:
+https://forge.ocamlcore.org/docman/?group_id=343&view=listfile&dirid=385
diff --git a/README.mlTk b/README.mlTk
new file mode 100644
index 0000000..6815b66
--- /dev/null
+++ b/README.mlTk
@@ -0,0 +1,151 @@
+INTRODUCTION
+============
+mlTk is a library for interfacing OCaml with the scripting
+language Tcl/Tk (all versions since 8.0.3, but no betas).
+
+In addition to the basic interface with Tcl/Tk, this package contains
+ * the OCamlBrowser code editor / library browser written by Jacques
+ Garrigue.
+ * the "jpf" library, written by Jun P. Furuse; it contains a "file
+ selector" and "balloon help" support
+ * the "frx" library, written by Francois Rouaix
+ * the "tkanim" library, which supports animated gif loading/display
+
+mlTk = CamlTk + LablTk
+======================
+There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk.
+
+CamlTk uses classical features only, therefore it is easy to understand for
+the beginners of ML. It makes many conservative OCaml gurus also happy.
+LablTk, on the other hand, uses rather newer features of OCaml, the labeled
+optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk
+script flavor, but provides more powerful typing than CamlTk at the same time
+(i.e. less run time type checking of widgets).
+Until now, these two interfaces have been distributed and maintained
+independently.
+
+mlTk unifies these libraries into one. Since mlTk provides the both API's,
+both CamlTk and LablTk users can compile their applications with mlTk,
+just with little fixes.
+
+REQUIREMENTS
+============
+You must have already installed
+ * OCaml source, version 3.04+8 or later
+
+ * Tcl/Tk 8.0.3 or later
+ http://www.scriptics.com/ or various mirrors
+
+PLATFORMS:
+Essentially any Unix/X Window System platform. We have tested
+releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC
+OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin).
+
+INSTALLATION
+============
+
+0. Check-out the OCaml CVS source code tree.
+
+1. Compile OCaml (= make world). If you want, also make opt.
+
+2. Untar this mlTk distribution in the otherlibs directory, just like
+ the labltk source tree.
+
+3. change directory to otherlibs/mltk, and make (and make opt)
+
+4. To install the library, make install (and make installopt)
+
+To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser
+requires some modules of OCaml. If you are not interested in camlbrowser,
+you can compile mlTk without the OCaml source tree, but you have to modify
+support/Makefile.common.
+
+
+Compile your CamlTk/LablTk applications with mlTk
+=================================================
+
+* General
+
+The names of the additional libraries libjpf and libfrx are changed
+to jpflib and frxlib respectively, to avoid the library name space confusion.
+
+* LablTk users
+
+Just change the occurrences of labltk in your Makefiles to mltk
+(i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on)
+Since the API functions are 100% compatible, you need not to change
+your .ml files.
+
+* CamlTk users
+
+ - Makefiles : apply the same modification explained above for LablTk users.
+
+ - open Camltk : The API modules and functions are stored in the modules
+ Camltk. Therefore you need to replace the module name Tk to Camltk.
+ For example, open Tk => open Camltk.
+
+ open Camltk (* instead of open Tk *)
+
+ let t = openTk ();;
+ let b = Button.create t [];;
+
+ - You may also need to open the Camltk module explicitly, when your
+ original module source contain no open Tk phrase. Widget and the other
+ Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now
+ Camltk.Widget.widget) Add open Camltk at the beginning of .mli files,
+ if these types are used:
+
+ open Camltk (* added for compiling under mlTk *)
+
+ val create_progress_bar : Widget.widget -> Widget.widget
+
+ - Eta expansion to flush optional arguments at registering callbacks.
+ Functions with the _displayof suffix are unified with their non-displayof
+ versions, using optional labeled arguments. For example, Bell.ring
+ had/have the following types:
+
+ before: Bell.ring : unit -> unit
+ now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit
+
+ If you use these functions as callbacks directly like Command Bell.ring,
+ you need eta-expansions to flush these new optional arguments:
+
+ Button.create w [Command Bell.ring]
+
+ => Button.create w [Command (fun () -> Bell.ring ())]
+
+Use the both API's at the same time
+===================================
+It is possible to use the both API's in one program. If you want to use
+a widget library written in the different API from you use, you need to
+do it. (It will be confusing, but easier than porting the library itself
+from one to the other API.)
+
+For the users who mainly use LablTk API, CamlTk API is available
+in the modules start with 'C'. For example, the source file of
+the CamlTk button widget functions is CButton (and exported also as
+Camltk.Button).
+
+For the users who mainly use CamlTk API, LablTk API modules are exported
+inside Labltk module. For example, LablTk's Button module can be also
+accessible as Labltk.Button.
+
+In CamlTk, we have only one widget type, [widget]. This type is equivalent
+to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk
+functions to LablTk widget, you can use [coe] function to coerce it to
+[any widget].
+
+To do the converse, the "widget-typers" are available inside the module Labltk.
+For example, to recover the type of a button widget, use Labltk.button.
+These widget-typers checks the types of widgets at run-time. If the widget
+type is different from the context type, a run-time exception is raised.
+
+ open Tk (* open LablTk API *)
+
+ let t = openTk ();; (* t is LablTk widget, toplevel widget *)
+ (* CButton.create takes [any widget]; [t] must be coerced to the type. *)
+ let caml_b = CButton.create (coe t) [];;
+ (* caml_b is [any widget], must be explicitly typed as [button widget],
+ when it is used with LablTk API functions *)
+ let b = Labltk.button caml_b in (* recover the type [button widget] *)
+ ...
diff --git a/Widgets.src b/Widgets.src
new file mode 100644
index 0000000..6a516b0
--- /dev/null
+++ b/Widgets.src
@@ -0,0 +1,2312 @@
+%(***********************************************************************)
+%(* *)
+%(* MLTk, Tcl/Tk interface of OCaml *)
+%(* *)
+%(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+%(* projet Cristal, INRIA Rocquencourt *)
+%(* Jacques Garrigue, Kyoto University RIMS *)
+%(* *)
+%(* Copyright 2002 Institut National de Recherche en Informatique et *)
+%(* en Automatique and Kyoto University. All rights reserved. *)
+%(* This file is distributed under the terms of the GNU Library *)
+%(* General Public License, with the special exception on linking *)
+%(* described in file LICENSE found in the OCaml source tree. *)
+%(* *)
+%(***********************************************************************)
+
+%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%%
+type Widget external
+
+% cget will probably never be implemented with verifications
+function (string) cgets [widget; "cget"; string]
+% another version with some hack is
+type options_constrs external
+function (string) cget [widget; "cget"; options_constrs]
+% constructors of type options_constrs are of the form C
+% where is an option constructor (e.g. CBackground)
+
+%%%%% Some types for standard options of widgets
+type Anchor {
+ NW ["nw"] N ["n"] NE ["ne"]
+ W ["w"] Center ["center"] E ["e"]
+ SW ["sw"] S ["s"] SE ["se"]
+}
+
+type Bitmap external % builtin_GetBitmap.ml
+type Cursor external % builtin_GetCursor.ml
+type Color external % builtin_GetCursor.ml
+
+##ifdef CAMLTK
+
+type ImageBitmap {
+ BitmapImage [string]
+ }
+type ImagePhoto {
+ PhotoImage [string]
+ }
+
+##else
+
+variant type ImageBitmap {
+ Bitmap [string]
+ }
+variant type ImagePhoto {
+ Photo [string]
+ }
+variant type Image {
+ Bitmap [string]
+ Photo [string]
+}
+
+##endif
+
+type Justification {
+ Justify_Left ["left"]
+ Justify_Center ["center"]
+ Justify_Right ["right"]
+}
+
+type Orientation {
+ Vertical ["vertical"]
+ Horizontal ["horizontal"]
+}
+
+type Relief {
+ Raised ["raised"]
+ Sunken ["sunken"]
+ Flat ["flat"]
+ Ridge ["ridge"]
+ Solid ["solid"]
+ Groove ["groove"]
+}
+
+type TextVariable external % textvariable.ml
+type Units external % builtin_GetPixel.ml
+
+%%%%% The standard options, as defined in man page options(n)
+%%%%% The subtype is never used
+subtype option(standard) {
+ ActiveBackground ["-activebackground"; Color]
+ ActiveBorderWidth ["-activeborderwidth"; Units/int]
+ ActiveForeground ["-activeforeground"; Color]
+ Anchor ["-anchor"; Anchor]
+ Background ["-background"; Color]
+ Bitmap ["-bitmap"; Bitmap]
+ BorderWidth ["-borderwidth"; Units/int]
+ Cursor ["-cursor"; Cursor]
+ DisabledForeground ["-disabledforeground"; Color]
+ ExportSelection ["-exportselection"; bool]
+ Font ["-font"; string]
+ Foreground ["-foreground"; Color]
+% Geometry is not one of standard options...
+ Geometry ["-geometry"; string] % Too variable to encode
+ HighlightBackground ["-highlightbackground"; Color]
+ HighlightColor ["-highlightcolor"; Color]
+ HighlightThickness ["-highlightthickness"; Units/int]
+##ifdef CAMLTK
+ % images are split, to do additionnal static typing
+ ImageBitmap (ImageBitmap) ["-image"; ImageBitmap]
+ ImagePhoto (ImagePhoto) ["-image"; ImagePhoto]
+##else
+ Image ["-image"; Image]
+##endif
+ InsertBackground ["-insertbackground"; Color]
+ InsertBorderWidth ["-insertborderwidth"; Units/int]
+ InsertOffTime ["-insertofftime"; int] % Positive only
+ InsertOnTime ["-insertontime"; int] % Idem
+ InsertWidth ["-insertwidth"; Units/int]
+ Jump ["-jump"; bool]
+ Justify ["-justify"; Justification]
+ Orient ["-orient"; Orientation]
+ PadX ["-padx"; Units/int]
+ PadY ["-pady"; Units/int]
+ Relief ["-relief"; Relief]
+ RepeatDelay ["-repeatdelay"; int]
+ RepeatInterval ["-repeatinterval"; int]
+ SelectBackground ["-selectbackground"; Color]
+ SelectBorderWidth ["-selectborderwidth"; Units/int]
+ SelectForeground ["-selectforeground"; Color]
+ SetGrid ["-setgrid"; bool]
+ % incomplete description of TakeFocus
+ TakeFocus ["-takefocus"; bool]
+ Text ["-text"; string]
+ TextVariable ["-textvariable"; TextVariable]
+ TroughColor ["-troughcolor"; Color]
+ UnderlinedChar ["-underline"; int]
+ WrapLength ["-wraplength"; Units/int]
+ XScrollCommand ["-xscrollcommand"; function(first:float, last:float)]
+ YScrollCommand ["-yscrollcommand"; function(first:float, last:float)]
+}
+
+%%%% Some other common types
+type Index external % builtin_index.ml
+type sequence ScrollValue external % builtin_ScrollValue.ml
+% type sequence ScrollValue {
+% MoveTo ["moveto"; float]
+% ScrollUnit ["scroll"; int; "unit"]
+% ScrollPage ["scroll"; int; "page"]
+% }
+
+
+
+%%%%% bell(n)
+module Bell {
+##ifdef CAMLTK
+ function () ring ["bell"; ?displayof:["-displayof"; widget]]
+ function () ring_displayof ["bell"; "-displayof" ; displayof: widget]
+##else
+ function () ring ["bell"; ?displayof:["-displayof"; widget]]
+##endif
+ }
+
+%%%%% bind(n)
+% builtin_bind.ml
+
+
+%%%%% bindtags(n)
+%type Bindings {
+% TagBindings [string]
+% WidgetBindings [widget]
+% }
+
+type Bindings external
+
+function () bindtags ["bindtags"; widget; [bindings: Bindings list]]
+function (Bindings list) bindtags_get ["bindtags"; widget]
+
+%%%%% bitmap(n)
+subtype option(bitmapimage) {
+ Background
+ Data ["-data"; string]
+ File ["-file"; string]
+ Foreground
+ Maskdata ["-maskdata"; string]
+ Maskfile ["-maskfile"; string]
+ }
+
+module Imagebitmap {
+ function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list]
+##ifdef CAMLTK
+ function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list]
+##endif
+ function () delete ["image"; "delete"; ImageBitmap]
+ function (int) height ["image"; "height"; ImageBitmap]
+ function (int) width ["image"; "width"; ImageBitmap]
+ function () configure [ImageBitmap; "configure"; option(bitmapimage) list]
+ function (string) configure_get [ImageBitmap; "configure"]
+ % Functions inherited from the "image" TK class
+ }
+
+%%%%% button(n)
+
+type State {
+ Normal ["normal"]
+ Active ["active"]
+ Disabled ["disabled"]
+ Hidden ["hidden"] % introduced in tk8.3, requested for Syndex
+}
+
+widget button {
+ % Standard options
+ option ActiveBackground
+ option ActiveForeground
+ option Anchor
+ option Background
+ option Bitmap
+ option BorderWidth
+ option Cursor
+ option DisabledForeground
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+##ifdef CAMLTK
+ option ImageBitmap
+ option ImagePhoto
+##else
+ option Image
+##endif
+ option Justify
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ option UnderlinedChar
+ option WrapLength
+ % Widget specific options
+ option Command ["-command"; function ()]
+ option Default ["-default"; State]
+ option Height ["-height"; Units/int]
+ option State ["-state"; State]
+ option Width ["-width"; Units/int]
+
+ function () configure [widget(button); "configure"; option(button) list]
+ function (string) configure_get [widget(button); "configure"]
+ function () flash [widget(button); "flash"]
+ function () invoke [widget(button); "invoke"]
+ }
+
+
+%%%%%% canvas(n)
+% Item ids and tags
+type TagOrId {
+ Tag [string]
+ Id [int]
+}
+
+% Indices: defined internally
+% subtype Index(canvas) {
+% Number End Insert SelFirst SelLast AtXY
+% }
+
+type SearchSpec {
+ Above ["above"; TagOrId]
+ All ["all"]
+ Below ["below"; TagOrId]
+ Closest ["closest"; Units/int; Units/int]
+ ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int]
+ ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId]
+ Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int]
+ Overlapping ["overlapping"; int;int;int;int]
+ Withtag ["withtag"; TagOrId]
+}
+
+type ColorMode {
+ Color ["color"]
+ Gray ["gray"]
+ Mono ["mono"]
+}
+
+subtype option(postscript) {
+ % Cannot support this without array variables
+ % Colormap ["-colormap"; TextVariable]
+ Colormode ["-colormode"; ColorMode]
+ File ["-file"; string]
+ % Fontmap ["-fontmap"; TextVariable]
+ Height
+ PageAnchor ["-pageanchor"; Anchor]
+ PageHeight ["-pageheight"; Units/int]
+ PageWidth ["-pagewidth"; Units/int]
+ PageX ["-pagex"; Units/int]
+ PageY ["-pagey"; Units/int]
+ Rotate ["-rotate"; bool]
+ Width
+ X ["-x"; Units/int]
+ Y ["-y"; Units/int]
+ }
+
+
+% Arc item configuration
+type ArcStyle {
+ Arc ["arc"]
+ Chord ["chord"]
+ PieSlice ["pieslice"]
+}
+
+subtype option(arc) {
+ Extent ["-extent"; float]
+ Dash ["-dash"; string]
+ % Fill is used by packer
+ FillColor ["-fill"; Color]
+ Outline ["-outline"; Color]
+ OutlineStipple ["-outlinestipple"; Bitmap]
+ Start ["-start"; float]
+ Stipple ["-stipple"; Bitmap]
+ ArcStyle ["-style"; ArcStyle]
+ Tags ["-tags"; [TagOrId/string list]]
+ Width
+ }
+
+% Bitmap item configuration
+subtype option(bitmap) {
+ Anchor
+ Background
+ Bitmap
+ Foreground
+ Tags
+}
+
+% Image item configuration
+subtype option(image) {
+ Anchor
+##ifdef CAMLTK
+ ImagePhoto
+ ImageBitmap
+##else
+ Image
+##endif
+ Tags
+}
+
+% Line item configuration
+type ArrowStyle {
+ Arrow_None ["none"]
+ Arrow_First ["first"]
+ Arrow_Last ["last"]
+ Arrow_Both ["both"]
+}
+
+type CapStyle {
+ Cap_Butt ["butt"]
+ Cap_Projecting ["projecting"]
+ Cap_Round ["round"]
+}
+
+type JoinStyle {
+ Join_Bevel ["bevel"]
+ Join_Miter ["miter"]
+ Join_Round ["round"]
+}
+
+subtype option(line) {
+ ArrowStyle ["-arrow"; ArrowStyle]
+ ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]]
+ CapStyle ["-capstyle"; CapStyle]
+ Dash
+ FillColor
+ JoinStyle ["-joinstyle"; JoinStyle]
+ Smooth ["-smooth"; bool]
+ SplineSteps ["-splinesteps"; int]
+ Stipple
+ Tags
+ Width
+ }
+
+% Oval item configuration
+subtype option(oval) {
+ Dash FillColor Outline Stipple Tags Width
+ }
+
+% Polygon item configuration
+subtype option(polygon) {
+ Dash FillColor Outline Smooth SplineSteps
+ Stipple Tags Width
+ }
+
+% Rectangle item configuration
+subtype option(rectangle) {
+ Dash FillColor Outline Stipple Tags Width
+ }
+
+% Text item configuration
+
+##ifndef CAMLTK
+% Only for Labltk. CanvasTextState is unified as State in Camltk
+type CanvasTextState {
+ Normal ["normal"]
+ Disabled ["disabled"]
+ Hidden ["hidden"]
+}
+##endif
+
+subtype option(canvastext) {
+ Anchor FillColor Font Justify
+ Stipple Tags Text Width
+##ifdef CAMLTK
+ State % introduced in tk8.3, requested for Syndex
+##else
+ CanvasTextState ["-state"; CanvasTextState] % introduced in tk8.3, requested for Syndex
+##endif
+ }
+
+% Window item configuration
+subtype option(window) {
+ Anchor Height Tags Width
+ Window ["-window"; widget]
+ Dash
+ }
+
+% Types of items
+type CanvasItem {
+ Arc_item ["arc"]
+ Bitmap_item ["bitmap"]
+ Image_item ["image"]
+ Line_item ["line"]
+ Oval_item ["oval"]
+ Polygon_item ["polygon"]
+ Rectangle_item ["rectangle"]
+ Text_item ["text"]
+ Window_item ["window"]
+ User_item [string]
+}
+
+widget canvas {
+ % Standard options
+ option Background
+ option BorderWidth
+ option Cursor
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option InsertBackground
+ option InsertBorderWidth
+ option InsertOffTime
+ option InsertOnTime
+ option InsertWidth
+ option Relief
+ option SelectBackground
+ option SelectBorderWidth
+ option SelectForeground
+ option TakeFocus
+ option XScrollCommand
+ option YScrollCommand
+ % Widget specific options
+ option CloseEnough ["-closeenough"; float]
+ option Confine ["-confine"; bool]
+ option Height ["-height"; Units/int]
+ option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]]
+ option Width ["-width"; Units/int]
+ option XScrollIncrement ["-xscrollincrement"; Units/int]
+ option YScrollIncrement ["-yscrollincrement"; Units/int]
+
+
+ function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only
+ % bbox not fully supported. should be builtin because of ambiguous result
+ % will raise Protocol.TkError if no items match TagOrId
+ function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list]
+ external bind "builtin/canvas_bind"
+##ifdef CAMLTK
+ function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units]
+ function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units]
+ function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units]
+ function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units]
+##else
+ function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]]
+ function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]]
+##endif
+ function () configure [widget(canvas); "configure"; option(canvas) list]
+ function (string) configure_get [widget(canvas); "configure"]
+ % TODO: check result
+ function (float list) coords_get [widget(canvas); "coords"; TagOrId]
+##ifdef CAMLTK
+ function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list]
+##else
+ function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list]
+##endif
+ % create variations (see below)
+ function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)]
+ function () delete [widget(canvas); "delete"; TagOrId list]
+ function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string]
+ function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list]
+ % focus variations
+ function () focus_reset [widget(canvas); "focus"; ""]
+ function (TagOrId) focus_get [widget(canvas); "focus"]
+ function () focus [widget(canvas); "focus"; TagOrId]
+ function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId]
+ function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)]
+ function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)]
+ function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string]
+ % itemcget, itemconfigure are defined later
+ function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]]
+##ifdef CAMLTK
+ function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId]
+ function () lower_bot [widget(canvas); "lower"; TagOrId]
+##endif
+ function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int]
+ unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list]
+ % We use raise with Module name
+ function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]]
+##ifdef CAMLTK
+ function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId]
+ function () raise_top [widget(canvas); "raise"; TagOrId]
+##endif
+ function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float]
+ % For scan, use x:int and y:int since common usage is with mouse coordinates
+ function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int]
+ function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int]
+ % select variations
+ function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)]
+ function () select_clear [widget(canvas); "select"; "clear"]
+ function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)]
+ function (TagOrId) select_item [widget(canvas); "select"; "item"]
+ function () select_to [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)]
+
+ function (CanvasItem) typeof [widget(canvas); "type"; TagOrId]
+ function (float,float) xview_get [widget(canvas); "xview"]
+ function (float,float) yview_get [widget(canvas); "yview"]
+ function () xview [widget(canvas); "xview"; scroll: ScrollValue]
+ function () yview [widget(canvas); "yview"; scroll: ScrollValue]
+
+ % create and configure variations
+ function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list]
+ function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list]
+ function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list]
+##ifdef CAMLTK
+ function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list]
+ function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list]
+##else
+ function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list]
+ function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list]
+##endif
+ function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list]
+ function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list]
+ function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list]
+ function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list]
+
+ function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId]
+
+ function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list]
+ function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list]
+ function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list]
+ function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list]
+ function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list]
+ function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list]
+ function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list]
+ function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list]
+ function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list]
+ }
+
+
+%%%%% checkbutton(n)
+widget checkbutton {
+ % Standard options
+ option ActiveBackground
+ option ActiveForeground
+ option Anchor
+ option Background
+ option Bitmap
+ option BorderWidth
+ option Cursor
+ option DisabledForeground
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+##ifdef CAMLTK
+ option ImageBitmap
+ option ImagePhoto
+##else
+ option Image
+##endif
+ option Justify
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ option UnderlinedChar
+ option WrapLength
+ % Widget specific options
+ option Command
+ option Height
+ option IndicatorOn ["-indicatoron"; bool]
+ option OffValue ["-offvalue"; string]
+ option OnValue ["-onvalue"; string]
+ option SelectColor ["-selectcolor"; Color]
+##ifdef CAMLTK
+ option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap]
+ option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto]
+##else
+ option SelectImage ["-selectimage"; Image]
+##endif
+ option State
+ option Variable ["-variable"; TextVariable]
+ option Width
+
+ function () configure [widget(checkbutton); "configure"; option(checkbutton) list]
+ function (string) configure_get [widget(checkbutton); "configure"]
+ function () deselect [widget(checkbutton); "deselect"]
+ function () flash [widget(checkbutton); "flash"]
+ function () invoke [widget(checkbutton); "invoke"]
+ function () select [widget(checkbutton); "select"]
+ function () toggle [widget(checkbutton); "toggle"]
+ }
+
+%%%%% clipboard(n)
+subtype icccm(clipboard_append) {
+ ICCCMFormat ["-format"; string]
+ ICCCMType ["-type"; string]
+ }
+
+module Clipboard {
+ function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]]
+ function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string]
+ }
+
+%%%%% destroy(n)
+function () destroy ["destroy"; widget]
+
+%%%%% tk_dialog(n)
+module Dialog {
+ external create "builtin/dialog"
+ }
+
+%%%%% entry(n)
+% Defined internally
+% subtype Index(entry) {
+% Number End Insert SelFirst SelLast At AnchorPoint
+% }
+
+##ifndef CAMLTK
+% Only for Labltk. InputState is unified as State in Camltk
+type InputState {
+ Normal ["normal"]
+ Disabled ["disabled"]
+}
+##endif
+
+widget entry {
+ % Standard options
+ option Background
+ option BorderWidth
+ option Cursor
+ option ExportSelection
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option InsertBackground
+ option InsertBorderWidth
+ option InsertOffTime
+ option InsertOnTime
+ option InsertWidth
+ option Justify
+ option Relief
+ option SelectBackground
+ option SelectBorderWidth
+ option SelectForeground
+ option TakeFocus
+ option TextVariable
+ option XScrollCommand
+
+ % Widget specific options
+ option Show ["-show"; char]
+##ifdef CAMLTK
+ option State
+##else
+ option EntryState ["-state"; InputState]
+##endif
+ option TextWidth (Textwidth) ["-width"; int]
+
+ function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)]
+ function () configure [widget(entry); "configure"; option(entry) list]
+ function (string) configure_get [widget(entry); "configure"]
+ function () delete_single [widget(entry); "delete"; index: Index(entry)]
+ function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)]
+ function (string) get [widget(entry); "get"]
+ function () icursor [widget(entry); "icursor"; index: Index(entry)]
+ function (int) index [widget(entry); "index"; index: Index(entry)]
+ function () insert [widget(entry); "insert"; index: Index(entry); text: string]
+ function () scan_mark [widget(entry); "scan"; "mark"; x: int]
+ function () scan_dragto [widget(entry); "scan"; "dragto"; x: int]
+ % selection variation
+ function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)]
+ function () selection_clear [widget(entry); "selection"; "clear"]
+ function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)]
+ function (bool) selection_present [widget(entry); "selection"; "present"]
+ function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)]
+ function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)]
+
+ function (float,float) xview_get [widget(entry); "xview"]
+ function () xview [widget(entry); "xview"; scroll: ScrollValue]
+ function () xview_index [widget(entry); "xview"; index: Index(entry)]
+ function (float, float) xview_get [widget(entry); "xview"]
+ }
+
+
+%%%%% focus(n)
+%%%%% tk_focusNext(n)
+module Focus {
+ unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]]
+ unsafe function (widget) displayof ["focus"; "-displayof"; widget]
+ function () set ["focus"; widget]
+ function () force ["focus"; "-force"; widget]
+ unsafe function (widget) lastfor ["focus"; "-lastfor"; widget]
+ unsafe function (widget) next ["tk_focusNext"; widget]
+ unsafe function (widget) prev ["tk_focusPrev"; widget]
+ function () follows_mouse ["tk_focusFollowsMouse"]
+}
+
+type font external % builtin/builtin_font.ml
+
+type weight {
+ Weight_Normal(Normal) ["normal"]
+ Weight_Bold(Bold) ["bold"]
+}
+
+type slant {
+ Slant_Roman(Roman) ["roman"]
+ Slant_Italic(Italic) ["italic"]
+}
+
+type fontMetrics {
+ Ascent ["-ascent"]
+ Descent ["-descent"]
+ Linespace ["-linespace"]
+ Fixed ["-fixed"]
+}
+
+subtype options(font) {
+ Font_Family ["-family"; string]
+ Font_Size ["-size"; int]
+ Font_Weight ["-weight"; weight]
+ Font_Slant ["-slant"; slant]
+ Font_Underline ["-underline"; bool]
+ Font_Overstrike ["-overstrike"; bool]
+% later, JP only
+% Charset ["-charset"; string]
+%% Beware of the order of Compound ! Put it as the first option
+% Compound ["-compound"; [font list]]
+% Copy ["-copy"; string]
+}
+
+module Font {
+ function (string) actual_family ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-family"]
+ function (int) actual_size ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-size"]
+ function (string) actual_weight ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-weight"]
+ function (string) actual_slant ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-slant"]
+ function (bool) actual_underline ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-underline"]
+ function (bool) actual_overstrike ["font"; "actual"; font;
+ ?displayof:["-displayof"; widget];
+ "-overstrike"]
+
+ function () configure ["font"; "configure"; font; options(font) list]
+ function (font) create ["font"; "create"; ?name:[string]; options(font) list]
+##ifdef CAMLTK
+ function (font) create_named ["font"; "create"; string; options(font) list]
+##endif
+ function () delete ["font"; "delete"; font]
+ function (string list) families ["font"; "families";
+ ?displayof:["-displayof"; widget]]
+##ifdef CAMLTK
+ function (string list) families_displayof ["font"; "families";
+ "-displayof"; widget]
+##endif
+ function (int) measure ["font"; "measure"; font; string;
+ ?displayof:["-displayof"; widget]]
+##ifdef CAMLTK
+ function (int) measure_displayof ["font"; "measure"; font;
+ "-displayof"; widget; string ]
+##endif
+ function (int) metrics ["font"; "metrics"; font;
+ ?displayof:["-displayof"; widget];
+ fontMetrics ]
+##ifdef CAMLTK
+ function (int) metrics_displayof ["font"; "metrics"; font;
+ "-displayof"; widget;
+ fontMetrics ]
+##endif
+ function (string list) names ["font"; "names"]
+% JP
+% function () failsafe ["font"; "failsafe"; string]
+}
+
+%%%%% frame(n)
+type Colormap {
+ NewColormap (New) ["new"]
+ WidgetColormap (Widget) [widget]
+ }
+
+% Visual classes are: directcolor, grayscale, greyscale, pseudocolor,
+% staticcolor, staticgray, staticgrey, truecolor
+type Visual {
+ ClassVisual (Clas) [[string; int]]
+ DefaultVisual ["default"]
+ WidgetVisual (Widget) [widget]
+ BestDepth (Bestdepth) [["best"; int]]
+ Best ["best"]
+ }
+
+widget frame {
+ % Standard options
+ option BorderWidth
+ option Cursor
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option Relief
+ option TakeFocus
+
+ % Widget specific options
+ option Background
+##ifdef CAMLTK
+ option Class ["-class"; string]
+##else
+ option Clas ["-class"; string]
+##endif
+ option Colormap ["-colormap"; Colormap]
+ option Container ["-container"; bool]
+ option Height
+ option Visual ["-visual"; Visual]
+ option Width
+
+ % Class and Colormap and Visual cannot be changed
+ function () configure [widget(frame); "configure"; option(frame) list]
+ function (string) configure_get [widget(frame); "configure"]
+ }
+
+
+
+%%%%% grab(n)
+type GrabStatus {
+ GrabNone ["none"]
+ GrabLocal ["local"]
+ GrabGlobal ["global"]
+}
+type GrabGlobal external
+module Grab {
+ function () set ["grab"; "set"; ?global:[GrabGlobal]; widget]
+##ifdef CAMLTK
+ function () set_global ["grab"; "set"; "-global"; widget]
+##endif
+ unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]]
+##ifdef CAMLTK
+ % all_current is now current.
+ % The old current is now current_of
+ unsafe function (widget list) current_of ["grab"; "current"; widget]
+##endif
+ function () release ["grab"; "release"; widget]
+ function (GrabStatus) status ["grab"; "status"; widget]
+}
+
+subtype option(rowcolumnconfigure) {
+ Minsize ["-minsize"; Units/int]
+ Weight ["-weight"; int]
+ Pad ["-pad"; Units/int]
+}
+
+subtype option(grid) {
+ Column ["-column"; int]
+ ColumnSpan ["-columnspan"; int]
+ In(Inside) ["-in"; widget]
+ IPadX ["-ipadx"; Units/int]
+ IPadY ["-ipady"; Units/int]
+ PadX
+ PadY
+ Row ["-row"; int]
+ RowSpan ["-rowspan"; int]
+ Sticky ["-sticky"; string]
+ }
+
+% Same as pack
+function () grid ["grid"; widget list; option(grid) list]
+
+module Grid {
+ function (int,int,int,int) bbox ["grid"; "bbox"; widget]
+ function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int]
+ function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int]
+ function () column_configure
+ ["grid"; "columnconfigure"; widget; int;
+ option(rowcolumnconfigure) list]
+ function () configure ["grid"; "configure"; widget list; option(grid) list]
+ function (string) column_configure_get ["grid"; "columnconfigure"; widget;
+ int]
+ function () forget ["grid"; "forget"; widget list]
+ %% info returns only a string
+ function (string) info ["grid"; "info"; widget]
+ %% TODO: check result values
+ function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int]
+ function (bool) propagate_get ["grid"; "propagate"; widget]
+ function () propagate_set ["grid"; "propagate"; widget; bool]
+ function () row_configure
+ ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list]
+ function (string) row_configure_get ["grid"; "rowconfigure"; widget; int]
+ function (int,int) size ["grid"; "size"; widget]
+
+##ifdef CAMLTK
+ function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]]
+ function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int]
+ function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int]
+##else
+ function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]]
+##endif
+ }
+
+%%%%% image(n)
+%%%%% cf Imagephoto and Imagebitmap
+% Some functions on images are implemented in Imagephoto or Imagebitmap.
+module Image {
+ external names "builtin/image"
+}
+
+%%%%% label(n)
+widget label {
+ % Standard options
+ option Anchor
+ option Background
+ option Bitmap
+ option BorderWidth
+ option Cursor
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+##ifdef CAMLTK
+ option ImageBitmap
+ option ImagePhoto
+##else
+ option Image
+##endif
+ option Justify
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ option UnderlinedChar
+ option WrapLength
+
+ % Widget specific options
+ option Height
+ % use according to label contents
+ option Width
+ option TextWidth
+
+ function () configure [widget(label); "configure"; option(label) list]
+ function (string) configure_get [widget(label); "configure"]
+ }
+
+
+%%%%% listbox(n)
+
+% Defined internally
+% subtype Index(listbox) {
+% Number Active AnchorPoint End AtXY
+%}
+
+type SelectModeType {
+ Single ["single"]
+ Browse ["browse"]
+ Multiple ["multiple"]
+ Extended ["extended"]
+ }
+
+
+widget listbox {
+ % Standard options
+ option Background
+ option BorderWidth
+ option Cursor
+ option ExportSelection
+ option Font
+ option Foreground
+ % Height is TextHeight
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option Relief
+ option SelectBackground
+ option SelectBorderWidth
+ option SelectForeground
+ option SetGrid
+ option TakeFocus
+ % Width is TextWidth
+ option XScrollCommand
+ option YScrollCommand
+ % Widget specific options
+ option TextHeight ["-height"; int]
+ option TextWidth
+ option SelectMode ["-selectmode"; SelectModeType]
+
+ function () activate [widget(listbox); "activate"; index: Index(listbox)]
+ function (int,int,int,int) bbox [widget(listbox); "bbox"; index: Index(listbox)]
+ function () configure [widget(listbox); "configure"; option(listbox) list]
+ function (string) configure_get [widget(listbox); "configure"]
+ function (Index(listbox) as "[>`Num of int]" list) curselection [widget(listbox); "curselection"]
+ function () delete [widget(listbox); "delete"; first: Index(listbox); last: Index(listbox)]
+ function (string) get [widget(listbox); "get"; index: Index(listbox)]
+ function (string list) get_range [widget(listbox); "get"; first: Index(listbox); last: Index(listbox)]
+ function (Index(listbox) as "[>`Num of int]") index [widget(listbox); "index"; index: Index(listbox)]
+ function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list]
+ function (Index(listbox) as "[>`Num of int]") nearest [widget(listbox); "nearest"; y: int]
+ function () scan_mark [widget(listbox); "scan"; "mark"; x: int; y: int]
+ function () scan_dragto [widget(listbox); "scan"; "dragto"; x: int; y: int]
+ function () see [widget(listbox); "see"; index: Index(listbox)]
+ function () selection_anchor [widget(listbox); "selection"; "anchor"; index: Index(listbox)]
+ function () selection_clear [widget(listbox); "selection"; "clear"; first: Index(listbox); last: Index(listbox)]
+ function (bool) selection_includes [widget(listbox); "selection"; "includes"; index: Index(listbox)]
+ function () selection_set [widget(listbox); "selection"; "set"; first: Index(listbox); last: Index(listbox)]
+ function (int) size [widget(listbox); "size"]
+
+ function (float,float) xview_get [widget(listbox); "xview"]
+ function (float,float) yview_get [widget(listbox); "yview"]
+ function () xview_index [widget(listbox); "xview"; index: Index(listbox)]
+ function () yview_index [widget(listbox); "yview"; index: Index(listbox)]
+ function () xview [widget(listbox); "xview"; scroll: ScrollValue]
+ function () yview [widget(listbox); "yview"; scroll: ScrollValue]
+ }
+
+%%%%% lower(n)
+function () lower_window ["lower"; widget; ?below:[widget]]
+##ifdef CAMLTK
+function () lower_window_below ["lower"; widget; below: widget]
+##endif
+
+
+%%%%% menu(n)
+%%%%% tk_popup(n)
+% defined internally
+% subtype Index(menu) {
+% Number Active End Last None At Pattern
+% }
+
+type MenuItem {
+ Cascade_Item ["cascade"]
+ Checkbutton_Item ["checkbutton"]
+ Command_Item ["command"]
+ Radiobutton_Item ["radiobutton"]
+ Separator_Item ["separator"]
+ TearOff_Item ["tearoff"]
+}
+
+% notused as a subtype. just for cleaning up the rest.
+subtype option(menuentry) {
+ ActiveBackground
+ ActiveForeground
+ Accelerator ["-accelerator"; string]
+ Background
+ Bitmap
+ ColumnBreak ["-columnbreak"; bool]
+ Command
+ Font
+ Foreground
+ HideMargin ["-hidemargin"; bool]
+##ifdef CAMLTK
+ ImageBitmap
+ ImagePhoto
+##else
+ Image
+##endif
+ IndicatorOn
+ Label ["-label"; string]
+ Menu ["-menu"; widget(menu)]
+ OffValue
+ OnValue
+ SelectColor
+##ifdef CAMLTK
+ SelectImageBitmap
+ SelectImagePhoto
+##else
+ SelectImage
+##endif
+ State
+ UnderlinedChar
+ Value ["-value"; string]
+ Variable
+ }
+
+% Options for cascade entry
+subtype option(menucascade) {
+ ActiveBackground ActiveForeground Accelerator
+ Background Bitmap ColumnBreak Command Font Foreground
+ HideMargin
+##ifdef CAMLTK
+ ImageBitmap ImagePhoto
+##else
+ Image
+##endif
+ IndicatorOn Label Menu State UnderlinedChar
+ }
+
+% Options for radiobutton entry
+subtype option(menuradio) {
+ ActiveBackground ActiveForeground Accelerator
+ Background Bitmap ColumnBreak Command Font Foreground
+##ifdef CAMLTK
+ ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto
+##else
+ Image SelectImage
+##endif
+ IndicatorOn Label SelectColor
+ State UnderlinedChar Value Variable
+ }
+
+% Options for checkbutton entry
+subtype option(menucheck) {
+ ActiveBackground ActiveForeground Accelerator
+ Background Bitmap ColumnBreak Command Font Foreground
+##ifdef CAMLTK
+ ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto
+##else
+ Image SelectImage
+##endif
+ IndicatorOn Label
+ OffValue OnValue SelectColor
+ State UnderlinedChar Variable
+ }
+
+% Options for command entry
+subtype option(menucommand) {
+ ActiveBackground ActiveForeground Accelerator
+ Background Bitmap ColumnBreak Command Font Foreground
+##ifdef CAMLTK
+ ImageBitmap ImagePhoto
+##else
+ Image
+##endif
+ Label State UnderlinedChar
+ }
+
+type menuType {
+ Menu_Menubar ["menubar"]
+ Menu_Tearoff ["tearoff"]
+ Menu_Normal ["normal"]
+}
+
+% Separators and tearoffs don't have options
+
+widget menu {
+ % Standard options
+ option ActiveBackground
+ option ActiveBorderWidth
+ option ActiveForeground
+ option Background
+ option BorderWidth
+ option Cursor
+ option DisabledForeground
+ option Font
+ option Foreground
+ option Relief
+ option TakeFocus
+ % Widget specific options
+ option PostCommand ["-postcommand"; function()]
+ option SelectColor
+ option TearOff ["-tearoff"; bool]
+ option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ]
+ option MenuTitle ["-title"; string]
+ option MenuType ["-type"; menuType]
+
+ function () activate [widget(menu); "activate"; index: Index(menu)]
+ % add variations
+ function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list]
+ function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list]
+ function () add_command [widget(menu); "add"; "command"; option(menucommand) list]
+ function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list]
+ function () add_separator [widget(menu); "add"; "separator"]
+ % not for user: function clone [widget(menu); "clone"; ???; menuType]
+ function () configure [widget(menu); "configure"; option(menu) list]
+ function (string) configure_get [widget(menu); "configure"]
+ % beware of possible callback leak when deleting menu entries
+ function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)]
+ function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list]
+ function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list]
+ function () configure_command [widget(menu); "entryconfigure"; Index(menu); option(menucommand) list]
+ function () configure_radiobutton [widget(menu); "entryconfigure"; Index(menu); option(menuradio) list]
+ function (string) entryconfigure_get [widget(menu); "entryconfigure"; Index(menu)]
+ function (int) index [widget(menu); "index"; Index(menu)]
+ function () insert_cascade [widget(menu); "insert"; index: Index(menu); "cascade"; option(menucascade) list]
+ function () insert_checkbutton [widget(menu); "insert"; index: Index(menu); "checkbutton"; option(menucheck) list]
+ function () insert_command [widget(menu); "insert"; index: Index(menu); "command"; option(menucommand) list]
+ function () insert_radiobutton [widget(menu); "insert"; index: Index(menu); "radiobutton"; option(menuradio) list]
+ function () insert_separator [widget(menu); "insert"; index: Index(menu); "separator"]
+ function (string) invoke [widget(menu); "invoke"; index: Index(menu)]
+ function () post [widget(menu); "post"; x: int; y: int]
+ function () postcascade [widget(menu); "postcascade"; index: Index(menu)]
+ % can't use type of course
+ function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)]
+ function () unpost [widget(menu); "unpost"]
+ function (int) yposition [widget(menu); "yposition"; index: Index(menu)]
+
+ function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]]
+##ifdef CAMLTK
+ function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)]
+##endif
+ }
+
+
+%%%%% menubutton(n)
+
+type menubuttonDirection {
+ Dir_Above ["above"]
+ Dir_Below ["below"]
+ Dir_Left ["left"]
+ Dir_Right ["right"]
+}
+
+widget menubutton {
+ % Standard options
+ option ActiveBackground
+ option ActiveForeground
+ option Anchor
+ option Background
+ option Bitmap
+ option BorderWidth
+ option Cursor
+ option DisabledForeground
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+##ifdef CAMLTK
+ option ImageBitmap
+ option ImagePhoto
+##else
+ option Image
+##endif
+ option Justify
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ option UnderlinedChar
+ option WrapLength
+ % Widget specific options
+ option Direction ["-direction"; menubuttonDirection ]
+ option Height
+ option IndicatorOn
+ option Menu ["-menu"; widget(menu)]
+ option State
+ option Width
+ option TextWidth
+
+ function () configure [widget(menubutton); "configure"; option(menubutton) list]
+ function (string) configure_get [widget(menubutton); "configure"]
+ }
+
+
+
+%%%%% message(n)
+widget message {
+ % Standard options
+ option Anchor
+ option Background
+ option BorderWidth
+ option Cursor
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ % Widget specific options
+ option Aspect ["-aspect"; int]
+ option Justify
+ option Width
+
+ function () configure [widget(message); "configure"; option(message) list]
+ function (string) configure_get [widget(message); "configure"]
+ }
+
+
+%%%%% option(n)
+type OptionPriority {
+ WidgetDefault ["widgetDefault"]
+ StartupFile ["startupFile"]
+ UserDefault ["userDefault"]
+ Interactive ["interactive"]
+ Priority [int]
+ }
+
+##ifdef CAMLTK
+
+module Option {
+ unsafe function () add ["option"; "add"; string; string; OptionPriority]
+ function () clear ["option"; "clear"]
+ function (string) get ["option"; "get"; widget; string; string]
+ unsafe function () readfile ["option"; "readfile"; string; OptionPriority]
+ }
+%% Resource is now superseded by Option
+module Resource {
+ unsafe function () add ["option"; "add"; string; string; OptionPriority]
+ function () clear ["option"; "clear"]
+ function (string) get ["option"; "get"; widget; string; string]
+ unsafe function () readfile ["option"; "readfile"; string; OptionPriority]
+ }
+##else
+module Option {
+ unsafe function () add
+ ["option"; "add"; path: string; string; ?priority:[OptionPriority]]
+ function () clear ["option"; "clear"]
+ function (string) get ["option"; "get"; widget; name: string; clas: string]
+ unsafe function () readfile
+ ["option"; "readfile"; string; ?priority:[OptionPriority]]
+ }
+##endif
+
+%%%%% tk_optionMenu(n)
+module Optionmenu {
+ external create "builtin/optionmenu"
+ }
+
+
+%%%%% pack(n)
+type Side {
+ Side_Left ["left"]
+ Side_Right ["right"]
+ Side_Top ["top"]
+ Side_Bottom ["bottom"]
+}
+
+type FillMode {
+ Fill_None ["none"]
+ Fill_X ["x"]
+ Fill_Y ["y"]
+ Fill_Both ["both"]
+}
+
+subtype option(pack) {
+ After ["-after"; widget]
+ Anchor
+ Before ["-before"; widget]
+ Expand ["-expand"; bool]
+ Fill ["-fill"; FillMode]
+ In(Inside) ["-in"; widget]
+ IPadX ["-ipadx"; Units/int]
+ IPadY ["-ipady"; Units/int]
+ PadX
+ PadY
+ Side ["-side"; Side]
+}
+
+function () pack ["pack"; widget list; option(pack) list]
+
+module Pack {
+ function () configure ["pack"; "configure"; widget list; option(pack) list]
+ function () forget ["pack"; "forget"; widget list]
+ function (string) info ["pack"; "info"; widget]
+ function (bool) propagate_get ["pack"; "propagate"; widget]
+ function () propagate_set ["pack"; "propagate"; widget; bool]
+ function (widget list) slaves ["pack"; "slaves"; widget]
+ }
+
+subtype TkPalette(any) { % Not sophisticated...
+ PaletteActiveBackground ["activeBackground"; Color]
+ PaletteActiveForeground ["activeForeground"; Color]
+ PaletteBackground ["background"; Color]
+ PaletteDisabledForeground ["disabledForeground"; Color]
+ PaletteForeground ["foreground"; Color]
+ PaletteHighlightBackground ["hilightBackground"; Color]
+ PaletteHighlightColor ["highlightColor"; Color]
+ PaletteInsertBackground ["insertBackground"; Color]
+ PaletteSelectColor ["selectColor"; Color]
+ PaletteSelectBackground ["selectBackground"; Color]
+ PaletteForegroundselectColor ["selectForeground"; Color]
+ PaletteTroughColor ["troughColor"; Color]
+}
+
+%%%%% tk_setPalette(n)
+%%%% can't simply encode general form of tk_setPalette
+module Palette {
+ function () set_background ["tk_setPalette"; Color]
+ function () set ["tk_setPalette"; TkPalette(any) list]
+ function () bisque ["tk_bisque"]
+ }
+
+%%%%% photo(n)
+type PaletteType external % builtin_palette.ml
+
+subtype option(photoimage) {
+ % Channel ["-channel"; file_descr] % removed in 8.3 ?
+ Data
+ Format ["-format"; string]
+ File
+ Gamma ["-gamma"; float]
+ Height
+ Palette ["-palette"; PaletteType]
+ Width
+ }
+
+subtype photo(copy) {
+ ImgFrom(Src_area) ["-from"; int; int; int; int]
+ ImgTo(Dst_area) ["-to"; int; int; int; int]
+ Shrink ["-shrink"]
+ Zoom ["-zoom"; int; int]
+ Subsample ["-subsample"; int; int]
+ }
+
+subtype photo(put) {
+ ImgTo
+ }
+
+subtype photo(read) {
+ ImgFormat ["-format"; string]
+ ImgFrom
+ Shrink
+ TopLeft(Dst_pos) ["-to"; int; int]
+ }
+
+subtype photo(write) {
+ ImgFormat ImgFrom
+ }
+
+module Imagephoto {
+ function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list]
+##ifdef CAMLTK
+ function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list]
+##endif
+ function () delete ["image"; "delete"; ImagePhoto]
+ function (int) height ["image"; "height"; ImagePhoto]
+ function (int) width ["image"; "width"; ImagePhoto]
+
+%name
+%type
+
+ function () blank [ImagePhoto; "blank"]
+ function () configure [ImagePhoto; "configure"; option(photoimage) list]
+ function (string) configure_get [ImagePhoto; "configure"]
+ function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list]
+ function (int, int, int) get [ImagePhoto; "get"; x: int; y: int]
+% it is buggy ? can't express nested lists ?
+ function () put [ImagePhoto; "put"; [Color list list]; photo(put) list]
+% external put "builtin/imagephoto_put"
+ function () read [ImagePhoto; "read"; file: string; photo(read) list]
+ function () redither [ImagePhoto; "redither"]
+ function () write [ImagePhoto; "write"; file: string; photo(write) list]
+ % Functions inherited from the "image" TK class
+ }
+
+
+%%%%% place(n)
+type BorderMode {
+ Inside ["inside"]
+ Outside ["outside"]
+ Ignore ["ignore"]
+}
+
+subtype option(place) {
+ In
+ X
+ RelX ["-relx"; float]
+ Y
+ RelY ["-rely"; float]
+ Anchor
+ Width
+ RelWidth ["-relwidth"; float]
+ Height
+ RelHeight ["-relheight"; float]
+ BorderMode ["-bordermode"; BorderMode]
+}
+
+function () place ["place"; widget; option(place) list]
+
+module Place {
+ function () configure ["place"; "configure"; widget; option(place) list]
+ function () forget ["place"; "forget"; widget]
+ function (string) info ["place"; "info"; widget]
+ function (widget list) slaves ["place"; "slaves"; widget]
+}
+
+
+%%%%% radiobutton(n)
+
+widget radiobutton {
+ % Standard options
+ option ActiveBackground
+ option ActiveForeground
+ option Anchor
+ option Background
+ option Bitmap
+ option BorderWidth
+ option Cursor
+ option DisabledForeground
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+##ifdef CAMLTK
+ option ImageBitmap
+ option ImagePhoto
+##else
+ option Image
+##endif
+ option Justify
+ option PadX
+ option PadY
+ option Relief
+ option TakeFocus
+ option Text
+ option TextVariable
+ option UnderlinedChar
+ option WrapLength
+
+ % Widget specific options
+ option Command
+ option Height
+ option IndicatorOn
+ option SelectColor
+##ifdef CAMLTK
+ option SelectImageBitmap
+ option SelectImagePhoto
+##else
+ option SelectImage
+##endif
+ option State
+ option Value
+ option Variable
+ option Width
+
+ function () configure [widget(radiobutton); "configure"; option(radiobutton) list]
+ function (string) configure_get [widget(radiobutton); "configure"]
+ function () deselect [widget(radiobutton); "deselect"]
+ function () flash [widget(radiobutton); "flash"]
+ function () invoke [widget(radiobutton); "invoke"]
+ function () select [widget(radiobutton); "select"]
+ }
+
+
+%%%%% raise(n)
+% We cannot use raise !!
+function () raise_window ["raise"; widget; ?above:[widget]]
+##ifdef CAMLTK
+function () raise_window_above ["raise"; widget; widget]
+##endif
+
+%%%%% scale(n)
+%% shared with scrollbars
+##ifdef CAMLTK
+subtype WidgetElement(scale) {
+ Slider ["slider"]
+ Trough1 ["trough1"]
+ Trough2 ["trough2"]
+ Beyond [""]
+ }
+##else
+type ScaleElement {
+ Slider ["slider"]
+ Trough1 ["trough1"]
+ Trough2 ["trough2"]
+ Beyond [""]
+ }
+##endif
+
+widget scale {
+ % Standard options
+ option ActiveBackground
+ option Background
+ option BorderWidth
+ option Cursor
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option Orient
+ option Relief
+ option RepeatDelay
+ option RepeatInterval
+ option TakeFocus
+ option TroughColor
+
+ % Widget specific options
+ option BigIncrement ["-bigincrement"; float]
+ option ScaleCommand ["-command"; function (float)]
+ option Digits ["-digits"; int]
+ option From(Min) ["-from"; float]
+ option Label ["-label"; string]
+ option Length ["-length"; Units/int]
+ option Resolution ["-resolution"; float]
+ option ShowValue ["-showvalue"; bool]
+ option SliderLength ["-sliderlength"; Units/int]
+ option State
+ option TickInterval ["-tickinterval"; float]
+ option To(Max) ["-to"; float]
+ option Variable
+ option Width
+
+##ifdef CAMLTK
+ function (int,int) coords [widget(scale); "coords"]
+ function (int,int) coords_at [widget(scale); "coords"; at: float]
+##else
+ function (int,int) coords [widget(scale); "coords"; ?at: [float]]
+##endif
+ function () configure [widget(scale); "configure"; option(scale) list]
+ function (string) configure_get [widget(scale); "configure"]
+ function (float) get [widget(scale); "get"]
+ function (float) get_xy [widget(scale); "get"; x: int; y: int]
+ function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int]
+ function () set [widget(scale); "set"; float]
+ }
+
+
+%%%%% scrollbar(n)
+##ifdef CAMLTK
+subtype WidgetElement(scrollbar) {
+ Arrow1 ["arrow1"]
+ Trough1
+ Trough2
+ Slider
+ Arrow2 ["arrow2"]
+ Beyond
+ }
+##else
+type ScrollbarElement {
+ Arrow1 ["arrow1"]
+ Trough1 ["through1"]
+ Trough2 ["through2"]
+ Slider ["slider"]
+ Arrow2 ["arrow2"]
+ Beyond [""]
+ }
+##endif
+
+widget scrollbar {
+ % Standard options
+ option ActiveBackground
+ option Background
+ option BorderWidth
+ option Cursor
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option Jump
+ option Orient
+ option Relief
+ option RepeatDelay
+ option RepeatInterval
+ option TakeFocus
+ option TroughColor
+ % Widget specific options
+ option ActiveRelief ["-activerelief"; Relief]
+ option ScrollCommand ["-command"; function(scroll: ScrollValue)]
+ option ElementBorderWidth ["-elementborderwidth"; Units/int]
+ option Width
+
+##ifdef CAMLTK
+ function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)]
+##else
+ function () activate [widget(scrollbar); "activate"; element: ScrollbarElement]
+##endif
+ function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"]
+ function () configure [widget(scrollbar); "configure"; option(scrollbar) list]
+ function (string) configure_get [widget(scrollbar); "configure"]
+ function (float) delta [widget(scrollbar); "delta"; x: int; y: int]
+ function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int]
+ function (float, float) get [widget(scrollbar); "get"]
+ function (int,int,int,int) old_get [widget(scrollbar); "get"]
+ function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int]
+ function () set [widget(scrollbar); "set"; first: float; last: float]
+ function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int]
+ }
+
+
+%%%%% selection(n)
+
+subtype icccm(selection_clear) {
+ DisplayOf ["-displayof"; widget]
+ Selection ["-selection"; string]
+ }
+
+subtype icccm(selection_get) {
+ DisplayOf
+ Selection
+ ICCCMType
+ }
+
+subtype icccm(selection_ownset) {
+ LostCommand ["-command"; function()]
+ Selection
+ }
+
+subtype icccm(selection_handle) {
+ Selection
+ ICCCMType
+ ICCCMFormat ["-format"; string]
+ }
+
+module Selection {
+ function () clear ["selection"; "clear"; icccm(selection_clear) list]
+ function (string) get ["selection"; "get"; icccm(selection_get) list]
+
+ % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)]
+ external handle_set "builtin/selection_handle_set"
+ unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list]
+ % builtin
+ % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list]
+ external own_set "builtin/selection_own_set"
+ }
+
+
+%%%%% send(n)
+type SendOption {
+ SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm !
+ SendAsync ["-async"]
+}
+
+unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list]
+
+%%%%% text(n)
+
+type TextIndex external
+type TextTag external
+type TextMark external
+
+
+type TabType {
+ TabLeft [Units/int; "left"]
+ TabRight [Units/int; "right"]
+ TabCenter [Units/int; "center"]
+ TabNumeric [Units/int; "numeric"]
+ }
+
+type WrapMode {
+ WrapNone ["none"]
+ WrapChar ["char"]
+ WrapWord ["word"]
+}
+
+type Comparison {
+ LT (Lt) ["<"]
+ LE (Le) ["<="]
+ EQ (Eq) ["=="]
+ GE (Ge) [">="]
+ GT (Gt) [">"]
+ NEQ (Neq) ["!="]
+}
+
+type MarkDirection {
+ Mark_Left ["left"]
+ Mark_Right ["right"]
+ }
+
+type AlignType {
+ Align_Top ["top"]
+ Align_Bottom ["bottom"]
+ Align_Center ["center"]
+ Align_Baseline ["baseline"]
+ }
+
+subtype option(embeddedi) {
+ Align ["-align"; AlignType]
+##ifdef CAMLTK
+ ImageBitmap
+ ImagePhoto
+##else
+ Image
+##endif
+ Name ["-name"; string]
+ PadX
+ PadY
+ }
+
+subtype option(embeddedw) {
+ Align ["-align"; AlignType]
+ PadX
+ PadY
+ Stretch ["-stretch"; bool]
+ Window
+ }
+
+type TextSearch {
+ Forwards ["-forwards"]
+ Backwards ["-backwards"]
+ Exact ["-exact"]
+ Regexp ["-regexp"]
+ Nocase ["-nocase"]
+ Count ["-count"; TextVariable]
+ }
+
+type text_dump {
+ DumpAll ["-all"]
+ DumpCommand ["-command"; function (key: string, value: string, index: string)]
+ DumpMark ["-mark"]
+ DumpTag ["-tag"]
+ DumpText ["-text"]
+ DumpWindow ["-window"]
+ }
+
+widget text {
+ % Standard options
+ option Background
+ option BorderWidth
+ option Cursor
+ option ExportSelection
+ option Font
+ option Foreground
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option InsertBackground
+ option InsertBorderWidth
+ option InsertOffTime
+ option InsertOnTime
+ option InsertWidth
+ option PadX
+ option PadY
+ option Relief
+ option SelectBackground
+ option SelectBorderWidth
+ option SelectForeground
+ option SetGrid
+ option TakeFocus
+ option XScrollCommand
+ option YScrollCommand
+
+ % Widget specific options
+ option TextHeight
+ option Spacing1 ["-spacing1"; Units/int]
+ option Spacing2 ["-spacing2"; Units/int]
+ option Spacing3 ["-spacing3"; Units/int]
+##ifdef CAMLTK
+ option State
+##else
+ option EntryState
+##endif
+ option Tabs ["-tabs"; [TabType list]]
+ option TextWidth
+ option Wrap ["-wrap"; WrapMode]
+
+ function (int,int,int,int) bbox [widget(text); "bbox"; index: TextIndex]
+ function (bool) compare [widget(text); "compare"; index: TextIndex; op: Comparison; index: TextIndex]
+ function () configure [widget(text); "configure"; option(text) list]
+ function (string) configure_get [widget(text); "configure"]
+ function () debug [widget(text); "debug"; bool]
+ function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex]
+ function () delete_char [widget(text); "delete"; index: TextIndex]
+ function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex]
+
+ % require result parser
+ function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex]
+ function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex]
+
+ function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex]
+ function (string) get_char [widget(text); "get"; index: TextIndex]
+ function () image_configure
+ [widget(text); "image"; "configure"; name: string; option(embeddedi) list]
+ function (string) image_configure_get
+ [widget(text); "image"; "cgets"; name: string]
+ function (string) image_create
+ [widget(text); "image"; "create"; index: TextIndex; option(embeddedi) list]
+ function (string list) image_names [widget(text); "image"; "names"]
+ function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex]
+##ifdef CAMLTK
+ function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]]
+##else
+ function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]]
+##endif
+ % Mark
+ function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection]
+ function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark]
+ function (TextMark list) mark_names [widget(text); "mark"; "names"]
+ function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex]
+ function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex]
+ function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex]
+ function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list]
+ % Scan
+ function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int]
+ function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int]
+##ifdef CAMLTK
+ function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex]
+##else
+ function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]]
+##endif
+ function () see [widget(text); "see"; index: TextIndex]
+ % Tags
+ function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex]
+ function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex]
+ external tag_bind "builtin/text_tag_bind"
+ function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list]
+ function () tag_delete [widget(text); "tag"; "delete"; TextTag list]
+
+ function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]]
+##ifdef CAMLTK
+ function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag]
+ function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag]
+##endif
+
+ function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]]
+##ifdef CAMLTK
+ function (TextTag list) tag_allnames [widget(text); "tag"; "names"]
+ function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex]
+##endif
+
+##ifdef CAMLTK
+ function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex]
+ function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex]
+##else
+ function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]]
+ function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]]
+##endif
+
+ function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]]
+##ifdef CAMLTK
+ function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag]
+ function () tag_raise_top [widget(text); "tag"; "raise"; TextTag]
+##endif
+
+##ifdef CAMLTK
+ function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag]
+##else
+ function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag]
+##endif
+
+ function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex]
+ function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex]
+
+ function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list]
+ function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list]
+ function (widget list) window_names [widget(text); "window"; "names"]
+ % scrolling
+ function (float,float) xview_get [widget(text); "xview"]
+ function (float,float) yview_get [widget(text); "yview"]
+ function () xview [widget(text); "xview"; scroll: ScrollValue]
+ function () yview [widget(text); "yview"; scroll: ScrollValue]
+ function () yview_index [widget(text); "yview"; index: TextIndex]
+ function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex]
+ function () yview_line [widget(text); "yview"; line: int] % obsolete
+ }
+
+subtype option(texttag) {
+ Background
+ BgStipple ["-bgstipple"; Bitmap]
+ BorderWidth
+ FgStipple ["-fgstipple"; Bitmap]
+ Font
+ Foreground
+ Justify
+ LMargin1 ["-lmargin1"; Units/int]
+ LMargin2 ["-lmargin2"; Units/int]
+ Offset ["-offset"; Units/int]
+ OverStrike ["-overstrike"; bool]
+ Relief
+ RMargin ["-rmargin"; Units/int]
+ Spacing1
+ Spacing2
+ Spacing3
+ Tabs
+ Underline ["-underline"; bool]
+ Wrap ["-wrap"; WrapMode]
+ }
+
+
+%%%%% tk(n)
+unsafe function () appname_set ["tk"; "appname"; string]
+unsafe function (string) appname_get ["tk"; "appname"]
+function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]]
+unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float]
+
+%%%%% tk_chooseColor(n)
+
+subtype option(chooseColor){
+ InitialColor ["-initialcolor"; Color]
+ Parent ["-parent"; widget]
+ Title ["-title"; string]
+ }
+function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list]
+
+%%%%% tkwait(n)
+module Tkwait {
+ function () variable ["tkwait"; "variable"; TextVariable]
+ function () visibility ["tkwait"; "visibility"; widget]
+ function () window ["tkwait"; "window"; widget]
+ }
+
+
+%%%%% toplevel(n)
+% This module will be renamed "toplevelw" to avoid collision with
+% Caml Light standard toplevel module.
+widget toplevel {
+ % Standard options
+ option BorderWidth
+ option Cursor
+ option HighlightBackground
+ option HighlightColor
+ option HighlightThickness
+ option Relief
+ option TakeFocus
+
+ % Widget specific options
+ option Background
+##ifdef CAMLTK
+ option Class
+##else
+ option Clas
+##endif
+ option Colormap
+ option Container ["-container"; bool]
+ option Height
+ option Menu
+ option Screen ["-screen"; string]
+ option Use ["-use"; string] % must be hexadecimal "0x????"
+ option Visual
+ option Width
+
+ function () configure [widget(toplevel); "configure"; option(toplevel) list]
+ function (string) configure_get [widget(toplevel); "configure"]
+ }
+
+
+%%%%% update(n)
+function () update ["update"]
+function () update_idletasks ["update"; "idletasks"]
+
+
+%%%%% winfo(n)
+
+type AtomId {
+ AtomId [int]
+ }
+
+module Winfo {
+
+ unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string]
+ unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId]
+##ifdef CAMLTK
+ unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string]
+ unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId]
+##endif
+ function (int) cells ["winfo"; "cells"; widget]
+ function (widget list) children ["winfo"; "children"; widget]
+ function (string) class_name ["winfo"; "class"; widget]
+ function (bool) colormapfull ["winfo"; "colormapfull"; widget]
+ unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int]
+##ifdef CAMLTK
+ unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int]
+##endif
+ % addition for applets
+ external contained "builtin/winfo_contained"
+ function (int) depth ["winfo"; "depth"; widget]
+ function (bool) exists ["winfo"; "exists"; widget]
+ function (float) fpixels ["winfo"; "fpixels"; widget; length: Units]
+ function (string) geometry ["winfo"; "geometry"; widget]
+ function (int) height ["winfo"; "height"; widget]
+ unsafe function (string) id ["winfo"; "id"; widget]
+ unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]]
+##ifdef CAMLTK
+ unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget]
+##endif
+ function (bool) ismapped ["winfo"; "ismapped"; widget]
+ function (string) manager ["winfo"; "manager"; widget]
+ function (string) name ["winfo"; "name"; widget]
+ unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top
+ unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string]
+##ifdef CAMLTK
+ unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string]
+##endif
+ function (int) pixels ["winfo"; "pixels"; widget; length: Units]
+ function (int) pointerx ["winfo"; "pointerx"; widget]
+ function (int) pointery ["winfo"; "pointery"; widget]
+ function (int, int) pointerxy ["winfo"; "pointerxy"; widget]
+ function (int) reqheight ["winfo"; "reqheight"; widget]
+ function (int) reqwidth ["winfo"; "reqwidth"; widget]
+ function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color]
+ function (int) rootx ["winfo"; "rootx"; widget]
+ function (int) rooty ["winfo"; "rooty"; widget]
+ unsafe function (string) screen ["winfo"; "screen"; widget]
+ function (int) screencells ["winfo"; "screencells"; widget]
+ function (int) screendepth ["winfo"; "screendepth"; widget]
+ function (int) screenheight ["winfo"; "screenheight"; widget]
+ function (int) screenmmheight ["winfo"; "screenmmheight"; widget]
+ function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget]
+ function (string) screenvisual ["winfo"; "screenvisual"; widget]
+ function (int) screenwidth ["winfo"; "screenwidth"; widget]
+ unsafe function (string) server ["winfo"; "server"; widget]
+ unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget]
+ function (bool) viewable ["winfo"; "viewable"; widget]
+ function (string) visual ["winfo"; "visual"; widget]
+ function (int) visualid ["winfo"; "visualid"; widget]
+ % need special parser
+ function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]]
+ function (int) vrootheight ["winfo"; "vrootheight"; widget]
+ function (int) vrootwidth ["winfo"; "vrootwidth"; widget]
+ function (int) vrootx ["winfo"; "vrootx"; widget]
+ function (int) vrooty ["winfo"; "vrooty"; widget]
+ function (int) width ["winfo"; "width"; widget]
+ function (int) x ["winfo"; "x"; widget]
+ function (int) y ["winfo"; "y"; widget]
+}
+
+
+%%%%% wm(n)
+
+type FocusModel {
+ FocusActive ["active"]
+ FocusPassive ["passive"]
+}
+
+type WmFrom {
+ User ["user"]
+ Program ["program"]
+}
+
+module Wm {
+%%% Aspect
+ function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int]
+ % aspect: problem with empty return
+ function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)]
+%%% WM_CLIENT_MACHINE
+ function () client_set ["wm"; "client"; widget(toplevel); name: string]
+ function (string) client_get ["wm"; "client"; widget(toplevel)]
+%%% WM_COLORMAP_WINDOWS
+ function () colormapwindows_set
+ ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]]
+ unsafe function (widget list) colormapwindows_get
+ ["wm"; "colormapwindows"; widget(toplevel)]
+%%% WM_COMMAND
+ function () command_clear ["wm"; "command"; widget(toplevel); ""]
+ function () command_set ["wm"; "command"; widget(toplevel); [string list]]
+ function (string list) command_get ["wm"; "command"; widget(toplevel)]
+
+ function () deiconify ["wm"; "deiconify"; widget(toplevel)]
+
+%%% Focus model
+ function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel]
+ function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)]
+
+ function (string) frame ["wm"; "frame"; widget(toplevel)]
+
+%%% Geometry
+ function () geometry_set ["wm"; "geometry"; widget(toplevel); string]
+ function (string) geometry_get ["wm"; "geometry"; widget(toplevel)]
+
+%%% Grid
+ function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""]
+ function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int]
+ function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)]
+
+%%% Groups
+ function () group_clear ["wm"; "group"; widget(toplevel); ""]
+ function () group_set ["wm"; "group"; widget(toplevel); leader: widget]
+ unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)]
+%%% Icon bitmap
+ function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""]
+ function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap]
+ function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)]
+
+ function () iconify ["wm"; "iconify"; widget(toplevel)]
+
+%%% Icon mask
+ function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""]
+ function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap]
+ function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)]
+
+%%% Icon name
+ function () iconname_set ["wm"; "iconname"; widget(toplevel); string]
+ function (string) iconname_get ["wm"; "iconname"; widget(toplevel)]
+%%% Icon position
+ function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""]
+ function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int]
+ function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)]
+%%% Icon window
+ function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""]
+ function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)]
+ unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)]
+
+%%% Sizes
+ function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int]
+ function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)]
+ function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int]
+ function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)]
+%%% Override
+ unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool]
+ function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)]
+%%% Position
+ function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""]
+ function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom]
+ function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)]
+%%% Protocols
+ function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()]
+ function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""]
+ function (string list) protocols ["wm"; "protocol"; widget(toplevel)]
+%%% Resize
+ function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool]
+ function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)]
+%%% Sizefrom
+ function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""]
+ function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom]
+ function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)]
+
+ function (string) state ["wm"; "state"; widget(toplevel)]
+
+%%% Title
+ function (string) title_get ["wm"; "title"; widget(toplevel)]
+ function () title_set ["wm"; "title"; widget(toplevel); string]
+%%% Transient
+ function () transient_clear ["wm"; "transient"; widget(toplevel); ""]
+ function () transient_set ["wm"; "transient"; widget(toplevel); master: widget]
+ unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)]
+
+ function () withdraw ["wm"; "withdraw"; widget(toplevel)]
+
+}
+
+%%%%% tk_getOpenFile(n) (since version 8.0)
+type FilePattern external
+
+subtype option(getFile) {
+ DefaultExtension ["-defaultextension"; string]
+ FileTypes ["-filetypes"; [FilePattern list]]
+ InitialDir ["-initialdir"; string]
+ InitialFile ["-initialfile"; string]
+ Parent ["-parent"; widget]
+ Title ["-title"; string]
+}
+
+function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list]
+function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list]
+
+%%%%% tk_messageBox
+type MessageIcon {
+ Error ["error"]
+ Info ["info"]
+ Question ["question"]
+ Warning ["warning"]
+}
+type MessageType {
+ AbortRetryIgnore ["abortretryignore"]
+ Ok ["ok"]
+ OkCancel ["okcancel"]
+ RetryCancel ["retrycancel"]
+ YesNo ["yesno"]
+ YesNoCancel ["yesnocancel"]
+}
+subtype option(messageBox) {
+ MessageDefault ["-default"; string]
+ MessageIcon ["-icon"; MessageIcon]
+ Message ["-message"; string]
+ Parent
+ Title
+ MessageType ["-type"; MessageType]
+}
+
+function (string) messageBox ["tk_messageBox"; option(messageBox) list]
+
+module Tkvars {
+ function (string) library ["set"; "tk_library"]
+ function (string) patchLevel ["set"; "tk_patchLevel"]
+ function (bool) strictMotif ["set"; "tk_strictMotif"]
+ function () set_strictMotif ["set"; "tk_strictMotif"; bool]
+ function (string) version ["set"; "tk_version"]
+}
+
+% Direct API calls, non Tcl-based modules
+
+module Pixmap {
+ external create "builtin/rawimg"
+ }
+
+%%% encodings : require if you want write your application international
+
+module Encoding {
+ function (string) convertfrom ["encoding"; "convertfrom";
+ ?encoding: [string]; string]
+ function (string) convertto ["encoding"; "convertto";
+ ?encoding: [string]; string]
+ function (string list) names ["encoding"; "names"]
+ function () system_set ["encoding"; "system"; string]
+ function (string) system_get ["encoding"; "system"]
+}
+
+% sample addition: ttk::labelframe
+% widget "ttk::labelframe" {
+% function (string) after [int]
+% }
+% subtype option("ttk::labelframe") {
+% Text
+% }
diff --git a/browser/.depend b/browser/.depend
new file mode 100644
index 0000000..5f32843
--- /dev/null
+++ b/browser/.depend
@@ -0,0 +1,168 @@
+editor.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \
+ viewer.cmi typecheck.cmi ../labltk/toplevel.cmi ../labltk/tk.cmo \
+ ../support/timer.cmi ../support/textvariable.cmi ../labltk/text.cmi \
+ shell.cmi setpath.cmi ../labltk/selection.cmi searchpos.cmi searchid.cmi \
+ ../support/protocol.cmi ../labltk/pack.cmi mytypes.cmi ../labltk/menu.cmi \
+ ../labltk/listbox.cmi lexical.cmi ../labltk/label.cmi jg_toplevel.cmo \
+ jg_tk.cmo jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo \
+ jg_bind.cmi ../labltk/frame.cmi ../labltk/focus.cmi fileselect.cmi \
+ ../labltk/entry.cmi ../labltk/clipboard.cmi ../labltk/checkbutton.cmi \
+ ../labltk/button.cmi editor.cmi
+editor.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \
+ viewer.cmx typecheck.cmx ../labltk/toplevel.cmx ../labltk/tk.cmx \
+ ../support/timer.cmx ../support/textvariable.cmx ../labltk/text.cmx \
+ shell.cmx setpath.cmx ../labltk/selection.cmx searchpos.cmx searchid.cmx \
+ ../support/protocol.cmx ../labltk/pack.cmx mytypes.cmi ../labltk/menu.cmx \
+ ../labltk/listbox.cmx lexical.cmx ../labltk/label.cmx jg_toplevel.cmx \
+ jg_tk.cmx jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx \
+ jg_bind.cmx ../labltk/frame.cmx ../labltk/focus.cmx fileselect.cmx \
+ ../labltk/entry.cmx ../labltk/clipboard.cmx ../labltk/checkbutton.cmx \
+ ../labltk/button.cmx editor.cmi
+fileselect.cmo : useunix.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \
+ ../support/textvariable.cmi setpath.cmi ../labltk/pack.cmi \
+ ../labltk/listbox.cmi list2.cmo ../labltk/label.cmi jg_toplevel.cmo \
+ jg_memo.cmi jg_entry.cmo jg_box.cmo ../labltk/grab.cmi \
+ ../labltk/frame.cmi ../labltk/focus.cmi ../labltk/checkbutton.cmi \
+ ../labltk/button.cmi fileselect.cmi
+fileselect.cmx : useunix.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \
+ ../support/textvariable.cmx setpath.cmx ../labltk/pack.cmx \
+ ../labltk/listbox.cmx list2.cmx ../labltk/label.cmx jg_toplevel.cmx \
+ jg_memo.cmx jg_entry.cmx jg_box.cmx ../labltk/grab.cmx \
+ ../labltk/frame.cmx ../labltk/focus.cmx ../labltk/checkbutton.cmx \
+ ../labltk/button.cmx fileselect.cmi
+help.cmo :
+help.cmx :
+jg_bind.cmo : ../labltk/tk.cmo ../labltk/focus.cmi ../labltk/button.cmi \
+ jg_bind.cmi
+jg_bind.cmx : ../labltk/tk.cmx ../labltk/focus.cmx ../labltk/button.cmx \
+ jg_bind.cmi
+jg_box.cmo : ../labltk/winfo.cmi ../labltk/tk.cmo ../labltk/scrollbar.cmi \
+ ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/frame.cmi
+jg_box.cmx : ../labltk/winfo.cmx ../labltk/tk.cmx ../labltk/scrollbar.cmx \
+ ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/frame.cmx
+jg_button.cmo : ../labltk/tk.cmo ../labltk/button.cmi
+jg_button.cmx : ../labltk/tk.cmx ../labltk/button.cmx
+jg_completion.cmo : ../support/timer.cmi jg_completion.cmi
+jg_completion.cmx : ../support/timer.cmx jg_completion.cmi
+jg_config.cmo : ../support/widget.cmi ../labltk/option.cmi jg_tk.cmo \
+ jg_config.cmi
+jg_config.cmx : ../support/widget.cmx ../labltk/option.cmx jg_tk.cmx \
+ jg_config.cmi
+jg_entry.cmo : ../labltk/tk.cmo jg_bind.cmi ../labltk/entry.cmi
+jg_entry.cmx : ../labltk/tk.cmx jg_bind.cmx ../labltk/entry.cmx
+jg_memo.cmo : jg_memo.cmi
+jg_memo.cmx : jg_memo.cmi
+jg_menu.cmo : ../labltk/toplevel.cmi ../labltk/tk.cmo ../labltk/menu.cmi
+jg_menu.cmx : ../labltk/toplevel.cmx ../labltk/tk.cmx ../labltk/menu.cmx
+jg_message.cmo : ../labltk/wm.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \
+ ../support/textvariable.cmi ../labltk/text.cmi ../labltk/message.cmi \
+ jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi ../labltk/grab.cmi \
+ ../labltk/frame.cmi ../labltk/button.cmi jg_message.cmi
+jg_message.cmx : ../labltk/wm.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \
+ ../support/textvariable.cmx ../labltk/text.cmx ../labltk/message.cmx \
+ jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx ../labltk/grab.cmx \
+ ../labltk/frame.cmx ../labltk/button.cmx jg_message.cmi
+jg_multibox.cmo : ../labltk/tk.cmo ../labltk/scrollbar.cmi \
+ ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/focus.cmi \
+ jg_multibox.cmi
+jg_multibox.cmx : ../labltk/tk.cmx ../labltk/scrollbar.cmx \
+ ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/focus.cmx \
+ jg_multibox.cmi
+jg_text.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../labltk/tk.cmo \
+ ../support/textvariable.cmi ../labltk/text.cmi ../labltk/scrollbar.cmi \
+ ../labltk/radiobutton.cmi ../support/protocol.cmi ../labltk/label.cmi \
+ jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi ../labltk/frame.cmi \
+ ../labltk/focus.cmi ../labltk/entry.cmi ../labltk/button.cmi jg_text.cmi
+jg_text.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../labltk/tk.cmx \
+ ../support/textvariable.cmx ../labltk/text.cmx ../labltk/scrollbar.cmx \
+ ../labltk/radiobutton.cmx ../support/protocol.cmx ../labltk/label.cmx \
+ jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx ../labltk/frame.cmx \
+ ../labltk/focus.cmx ../labltk/entry.cmx ../labltk/button.cmx jg_text.cmi
+jg_tk.cmo : ../labltk/tk.cmo
+jg_tk.cmx : ../labltk/tk.cmx
+jg_toplevel.cmo : ../labltk/wm.cmi ../support/widget.cmi \
+ ../labltk/toplevel.cmi ../labltk/tk.cmo
+jg_toplevel.cmx : ../labltk/wm.cmx ../support/widget.cmx \
+ ../labltk/toplevel.cmx ../labltk/tk.cmx
+lexical.cmo : ../labltk/tk.cmo ../labltk/text.cmi jg_tk.cmo lexical.cmi
+lexical.cmx : ../labltk/tk.cmx ../labltk/text.cmx jg_tk.cmx lexical.cmi
+list2.cmo :
+list2.cmx :
+main.cmo : viewer.cmi ../labltk/tk.cmo shell.cmi searchpos.cmi searchid.cmi \
+ ../support/protocol.cmi ../labltk/message.cmi jg_config.cmi editor.cmi \
+ ../labltk/button.cmi
+main.cmx : viewer.cmx ../labltk/tk.cmx shell.cmx searchpos.cmx searchid.cmx \
+ ../support/protocol.cmx ../labltk/message.cmx jg_config.cmx editor.cmx \
+ ../labltk/button.cmx
+searchid.cmo : list2.cmo searchid.cmi
+searchid.cmx : list2.cmx searchid.cmi
+searchpos.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \
+ ../labltk/tk.cmo ../labltk/text.cmi ../support/support.cmi searchid.cmi \
+ ../labltk/pack.cmi ../labltk/option.cmi ../labltk/menu.cmi lexical.cmi \
+ ../labltk/label.cmi jg_tk.cmo jg_text.cmi jg_message.cmi jg_memo.cmi \
+ jg_bind.cmi ../labltk/button.cmi searchpos.cmi
+searchpos.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \
+ ../labltk/tk.cmx ../labltk/text.cmx ../support/support.cmx searchid.cmx \
+ ../labltk/pack.cmx ../labltk/option.cmx ../labltk/menu.cmx lexical.cmx \
+ ../labltk/label.cmx jg_tk.cmx jg_text.cmx jg_message.cmx jg_memo.cmx \
+ jg_bind.cmx ../labltk/button.cmx searchpos.cmi
+setpath.cmo : useunix.cmi ../labltk/tk.cmo ../support/textvariable.cmi \
+ ../support/protocol.cmi ../labltk/listbox.cmi list2.cmo \
+ ../labltk/label.cmi jg_toplevel.cmo jg_button.cmo jg_box.cmo jg_bind.cmi \
+ ../labltk/frame.cmi ../labltk/entry.cmi ../labltk/button.cmi setpath.cmi
+setpath.cmx : useunix.cmx ../labltk/tk.cmx ../support/textvariable.cmx \
+ ../support/protocol.cmx ../labltk/listbox.cmx list2.cmx \
+ ../labltk/label.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx jg_bind.cmx \
+ ../labltk/frame.cmx ../labltk/entry.cmx ../labltk/button.cmx setpath.cmi
+shell.cmo : ../labltk/winfo.cmi ../labltk/toplevel.cmi ../labltk/tk.cmo \
+ ../support/timer.cmi ../labltk/text.cmi ../labltk/menu.cmi list2.cmo \
+ lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_message.cmi \
+ jg_menu.cmo jg_memo.cmi fileselect.cmi ../support/fileevent.cmi shell.cmi
+shell.cmx : ../labltk/winfo.cmx ../labltk/toplevel.cmx ../labltk/tk.cmx \
+ ../support/timer.cmx ../labltk/text.cmx ../labltk/menu.cmx list2.cmx \
+ lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \
+ jg_menu.cmx jg_memo.cmx fileselect.cmx ../support/fileevent.cmx shell.cmi
+typecheck.cmo : ../labltk/tk.cmo ../labltk/text.cmi mytypes.cmi jg_tk.cmo \
+ jg_text.cmi jg_message.cmi typecheck.cmi
+typecheck.cmx : ../labltk/tk.cmx ../labltk/text.cmx mytypes.cmi jg_tk.cmx \
+ jg_text.cmx jg_message.cmx typecheck.cmi
+useunix.cmo : useunix.cmi
+useunix.cmx : useunix.cmi
+viewer.cmo : ../labltk/wm.cmi useunix.cmi ../labltk/toplevel.cmi \
+ ../labltk/tk.cmo ../support/textvariable.cmi ../labltk/text.cmi shell.cmi \
+ setpath.cmi searchpos.cmi searchid.cmi ../labltk/radiobutton.cmi \
+ ../support/protocol.cmi ../labltk/pack.cmi mytypes.cmi ../labltk/menu.cmi \
+ ../labltk/listbox.cmi ../labltk/label.cmi jg_toplevel.cmo jg_tk.cmo \
+ jg_text.cmi jg_multibox.cmi jg_message.cmi jg_menu.cmo jg_entry.cmo \
+ jg_completion.cmi jg_button.cmo jg_box.cmo jg_bind.cmi help.cmo \
+ ../labltk/frame.cmi ../labltk/focus.cmi ../labltk/entry.cmi \
+ ../labltk/button.cmi viewer.cmi
+viewer.cmx : ../labltk/wm.cmx useunix.cmx ../labltk/toplevel.cmx \
+ ../labltk/tk.cmx ../support/textvariable.cmx ../labltk/text.cmx shell.cmx \
+ setpath.cmx searchpos.cmx searchid.cmx ../labltk/radiobutton.cmx \
+ ../support/protocol.cmx ../labltk/pack.cmx mytypes.cmi ../labltk/menu.cmx \
+ ../labltk/listbox.cmx ../labltk/label.cmx jg_toplevel.cmx jg_tk.cmx \
+ jg_text.cmx jg_multibox.cmx jg_message.cmx jg_menu.cmx jg_entry.cmx \
+ jg_completion.cmx jg_button.cmx jg_box.cmx jg_bind.cmx help.cmx \
+ ../labltk/frame.cmx ../labltk/focus.cmx ../labltk/entry.cmx \
+ ../labltk/button.cmx viewer.cmi
+dummyUnix.cmi :
+dummyWin.cmi :
+editor.cmi : ../support/widget.cmi
+fileselect.cmi :
+jg_bind.cmi : ../support/widget.cmi
+jg_completion.cmi :
+jg_config.cmi :
+jg_memo.cmi :
+jg_message.cmi : ../support/widget.cmi
+jg_multibox.cmi : ../support/widget.cmi ../labltk/tk.cmo
+jg_text.cmi : ../support/widget.cmi ../labltk/tk.cmo
+lexical.cmi : ../support/widget.cmi ../labltk/tk.cmo
+mytypes.cmi : ../support/widget.cmi ../support/textvariable.cmi shell.cmi
+searchid.cmi :
+searchpos.cmi : ../support/widget.cmi
+setpath.cmi : ../support/widget.cmi
+shell.cmi : ../support/widget.cmi
+typecheck.cmi : ../support/widget.cmi mytypes.cmi
+useunix.cmi :
+viewer.cmi : ../support/widget.cmi
diff --git a/browser/.gitignore b/browser/.gitignore
new file mode 100644
index 0000000..8d7632f
--- /dev/null
+++ b/browser/.gitignore
@@ -0,0 +1,3 @@
+ocamlbrowser
+dummy.mli
+help.ml
diff --git a/browser/Makefile b/browser/Makefile
new file mode 100644
index 0000000..e9e4c30
--- /dev/null
+++ b/browser/Makefile
@@ -0,0 +1,20 @@
+#########################################################################
+# #
+# OCaml LablTk library #
+# #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file ../../../LICENSE. #
+# #
+#########################################################################
+
+# $Id$
+
+include Makefile.shared
+
+dummy.ml:
+ cp dummyUnix.ml dummy.ml
diff --git a/browser/Makefile.nt b/browser/Makefile.nt
new file mode 100644
index 0000000..a51b4b4
--- /dev/null
+++ b/browser/Makefile.nt
@@ -0,0 +1,33 @@
+#########################################################################
+# #
+# OCaml LablTk library #
+# #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2000 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file ../../../LICENSE. #
+# #
+#########################################################################
+
+# $Id$
+
+CCFLAGS=-I$(LIBDIR)/caml $(TK_DEFS)
+
+include ../support/Makefile.common
+
+ifeq ($(CCOMPTYPE),cc)
+WINDOWS_APP=-ccopt "-link -Wl,--subsystem,windows"
+else
+WINDOWS_APP=-ccopt "-link /subsystem:windows"
+endif
+
+XTRAOBJ=winmain.$(O)
+XTRALIBS=threads.cma -custom $(WINDOWS_APP)
+
+include Makefile.shared
+
+dummy.ml:
+ cp dummyWin.ml dummy.ml
diff --git a/browser/Makefile.shared b/browser/Makefile.shared
new file mode 100644
index 0000000..b44814b
--- /dev/null
+++ b/browser/Makefile.shared
@@ -0,0 +1,73 @@
+include ../support/Makefile.common
+
+#########################################################################
+# #
+# OCaml LablTk library #
+# #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file ../../../LICENSE. #
+# #
+#########################################################################
+
+LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs
+INCLUDES=$(LABLTKLIB)
+
+OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
+ fileselect.cmo searchid.cmo searchpos.cmo \
+ dummy.cmo shell.cmo help.cmo \
+ viewer.cmo typecheck.cmo editor.cmo main.cmo
+
+JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \
+ jg_box.cmo \
+ jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \
+ jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo
+
+# Default rules
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O)
+
+.ml.cmo:
+ $(CAMLCOMP) $(INCLUDES) $<
+
+.mli.cmi:
+ $(CAMLCOMP) $(INCLUDES) $<
+
+.c.$(O):
+ $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
+
+all: ocamlbrowser$(EXE)
+
+ocamlbrowser$(EXE): jglib.cma $(OBJ) ../support/lib$(LIBNAME).$(A) $(XTRAOBJ)
+ $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \
+ ocamlcommon.cma \
+ unix.cma str.cma $(XTRALIBS) $(LIBNAME).cma jglib.cma \
+ $(OBJ) $(XTRAOBJ)
+
+ocamlbrowser.cma: jglib.cma $(OBJ)
+ $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ)
+
+jglib.cma: $(JG)
+ $(CAMLC) -a -o $@ $(JG)
+
+help.ml:
+ echo 'let text = "\\' > $@
+ sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@
+ echo '";;' >> $@
+
+install:
+ cp ocamlbrowser$(EXE) $(INSTALLBINDIR)
+
+clean:
+ rm -f *.cm? ocamlbrowser$(EXE) dummy.ml *~ *.orig *.$(O) help.ml
+
+depend: help.ml
+ $(CAMLDEP) $(LABLTKLIB) *.ml *.mli > .depend
+
+shell.cmo: dummy.cmi
+
+include .depend
diff --git a/browser/README b/browser/README
new file mode 100644
index 0000000..e895354
--- /dev/null
+++ b/browser/README
@@ -0,0 +1,170 @@
+
+ Installing and Using OCamlBrowser
+
+
+INSTALLATION
+ If you installed it with LablTk, nothing to do.
+ Otherwise, the source is in labltk/browser.
+ After installing LablTk, simply do "make" and "make install".
+ The name of the command is `ocamlbrowser'.
+
+USE
+ OCamlBrowser is composed of three tools, the Viewer, to walk around
+ compiled modules, the Editor, which allows one to
+ edit/typecheck/analyse .mli and .ml files, and the Shell, to run an
+ OCaml subshell. You may only have one instance of Editor and
+ Viewer, but you may use several subshells.
+
+ As with the compiler, you may specify a different path for the
+ standard library by setting CAMLLIB. You may also extend the
+ initial load path (only standard library by default) by using the
+ -I command line option, or set various other options (see -help).
+
+ If you prefered the old GUI, it is still available with the option
+ -oldui, otherwise you get a new Smalltalkish user interface.
+
+1) Viewer
+
+ Menus
+
+ File - Open and File - Editor give access to the editor.
+
+ File - Shell opens an OCaml shell.
+
+ View - Show all defs displays all the interface of the currently
+ selected module
+ View - Search entry shows/hides the search entry at the top of the
+ window
+
+ Modules - Path editor changes the load path.
+ Pressing [Add to path] or Insert key adds selected directories
+ to the load path.
+ Pressing [Remove from path] or Delete key removes selected
+ paths from the load path.
+ Modules - Reset cache rescans the load path and resets the module
+ cache. Do it if you recompile some interface, or change the load
+ path in a conflictual way.
+
+ Modules - Search symbol allows to search a symbol either by its
+ name, like the bottom line of the viewer, or, more
+ interestingly, by its type. Exact type searches for a type
+ with exactly the same information as the pattern (variables
+ match only variables), included type allows to give only
+ partial information: the actual type may take more arguments
+ and return more results, and variables in the pattern match
+ anything. In both cases, argument and tuple order is
+ irrelevant (*), and unlabeled arguments in the pattern match
+ any label.
+
+ (*) To avoid combinatorial explosion of the search space, optional
+ arguments in the actual type are ignored if (1) there are to many
+ of them, and (2) they do not appear explicitly in the pattern.
+
+ Search entry
+
+ The entry line at the top allows one to search for an identifier
+ in all modules, either by its name (? and * patterns allowed) or by
+ its type. When search by type is used, it is done in inclusion mode
+ (cf. Modules - search symbol)
+
+ The Close all button at the bottom is there to dismiss the windows
+ created by the Detach button. By double-clicking on it you will
+ quit the browser.
+
+ Module browsing
+
+ You select a module in the leftmost box by either cliking on it or
+ pressing return when it is selected. Fast access is available in
+ all boxes pressing the first few letter of the desired
+ name. Double-clicking / double-return displays the whole signature
+ for the module.
+
+ Defined identifiers inside the module are displayed in a box to the
+ right of the previous one. If you click on one, this will either
+ display its contents in another box (if this is a sub-module) or
+ display the signature for this identifier below.
+
+ Signatures are clickable. Double clicking with the left mouse
+ button on an identifier in a signature brings you to its signature.
+ A single click on the right button pops up a menu displaying the
+ type declaration for the selected identifier. Its title, when
+ selectable, also brings you to its signature.
+
+ At the bottom, a series of buttons, depending on the context.
+ * Detach copies the currently displayed signature in a new window,
+ to keep it. You can discard these windows with Close all.
+ * Impl and Intf bring you to the implementation or interface of
+ the currently displayed signature, if it is available.
+
+ C-s opens a text search dialog for the displayed signature.
+
+2) Editor
+ You can edit files with it, but there is no auto-save nor undo at
+ the moment. Otherwise you can use it as a browser, making
+ occasional corrections.
+
+ The Edit menu contains commands for jump (C-g), search (C-s), and
+ sending the current selection to a sub-shell (M-x). For this last
+ option, you may choose the shell via a dialog.
+
+ Essential function are in the Compiler menu.
+
+ Preferences opens a dialog to set internals of the editor and
+ type checker.
+
+ Lex (M-l) adds colors according to lexical categories.
+
+ Typecheck (M-t) verifies typing, and memorizes it to let one see an
+ expression's type by double-clicking on it. This is also valid for
+ interfaces. If an error occurs, the part of the interface preceding
+ the error is computed.
+
+ After typechecking, pressing the right button pops up a menu giving
+ the type of the pointed expression, and eventually allowing to
+ follow some links.
+
+ Clear errors dismisses type checker error messages and warnings.
+
+ Signature shows the signature of the current file.
+
+3) Shell
+ When you create a shell, a dialog is presented to you, letting you
+ choose which command you want to run, and the title of the shell
+ (to choose it in the Editor).
+
+ You may change the default command by setting the OLABL environment
+ variable.
+
+ The executed subshell is given the current load path.
+ File: use a source file or load a bytecode file.
+ You may also import the browser's path into the subprocess.
+ History: M-p and M-n browse up and down.
+ Signal: C-c interrupts and you can kill the subprocess.
+
+BUGS
+
+* This not really a bug, but OCamlBrowser is a huge memory consumer.
+ Go and buy some.
+
+* When you quit the editor and some file was modified, a dialogue is
+ displayed asking wether you want to really quit or not. But 1) if
+ you quit directly from the viewer, there is no dialogue at all, and
+ 2) if you close from the window manager, the dialogue is displayed,
+ but you cannot cancel the destruction... Beware.
+
+* When you run it through xon, the shell hangs at the first error. But
+ its ok if you start ocamlbrowser from a remote shell...
+
+TODO
+
+* Complete cross-references.
+
+* Power up editor.
+
+* Add support for the debugger.
+
+* Make this a real programming environment, both for beginners an
+ experimented users.
+
+
+Bug reports and comments to
diff --git a/browser/dummyUnix.ml b/browser/dummyUnix.ml
new file mode 100644
index 0000000..447574f
--- /dev/null
+++ b/browser/dummyUnix.ml
@@ -0,0 +1,27 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+module Mutex = struct
+ type t
+ external create : unit -> t = "%ignore"
+ external lock : t -> unit = "%ignore"
+ external unlock : t -> unit = "%ignore"
+end
+
+module Thread = struct
+ type t
+ external create : ('a -> 'b) -> 'a -> t = "caml_ml_input"
+end
diff --git a/browser/dummyWin.ml b/browser/dummyWin.ml
new file mode 100644
index 0000000..3f8c26e
--- /dev/null
+++ b/browser/dummyWin.ml
@@ -0,0 +1,15 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
diff --git a/browser/editor.ml b/browser/editor.ml
new file mode 100644
index 0000000..c8297ba
--- /dev/null
+++ b/browser/editor.ml
@@ -0,0 +1,667 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Parsetree
+open Location
+open Jg_tk
+open Mytypes
+
+let lex_on_load = ref true
+and type_on_load = ref false
+
+let compiler_preferences master =
+ let tl = Jg_toplevel.titled "Compiler" in
+ Wm.transient_set tl ~master;
+ let mk_chkbutton ~text ~ref ~invert =
+ let variable = Textvariable.create ~on:tl () in
+ if (if invert then not !ref else !ref) then
+ Textvariable.set variable "1";
+ Checkbutton.create tl ~text ~variable,
+ (fun () ->
+ ref := Textvariable.get variable = (if invert then "0" else "1"))
+ in
+ let use_pp = ref (!Clflags.preprocessor <> None) in
+ let chkbuttons, setflags = List.split
+ (List.map
+ ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert)
+ [ "No pervasives", Clflags.nopervasives, false;
+ "No warnings", Typecheck.nowarnings, false;
+ "No labels", Clflags.classic, false;
+ "Recursive types", Clflags.recursive_types, false;
+ "Lex on load", lex_on_load, false;
+ "Type on load", type_on_load, false;
+ "Preprocessor", use_pp, false ])
+ in
+ let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in
+ begin match !Clflags.preprocessor with None -> ()
+ | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp
+ end;
+ let buttons = Frame.create tl in
+ let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command:
+ begin fun () ->
+ List.iter ~f:(fun f -> f ()) setflags;
+ Clflags.preprocessor :=
+ if !use_pp then Some (Entry.get pp_command) else None;
+ destroy tl
+ end
+ and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
+ in
+ pack chkbuttons ~side:`Top ~anchor:`W;
+ pack [pp_command] ~side:`Top ~anchor:`E;
+ pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
+ pack [buttons] ~side:`Bottom ~fill:`X
+
+let rec exclude txt = function
+ [] -> []
+ | x :: l -> if txt.number = x.number then l else x :: exclude txt l
+
+let goto_line tw =
+ let tl = Jg_toplevel.titled "Go to" in
+ Wm.transient_set tl ~master:(Winfo.toplevel tw);
+ Jg_bind.escape_destroy tl;
+ let ef = Frame.create tl in
+ let fl = Frame.create ef
+ and fi = Frame.create ef in
+ let ll = Label.create fl ~text:"Line ~number:"
+ and il = Entry.create fi ~width:10
+ and lc = Label.create fl ~text:"Col ~number:"
+ and ic = Entry.create fi ~width:10
+ and get_int ew =
+ try int_of_string (Entry.get ew)
+ with Failure _ (*"int_of_string"*) -> 0
+ in
+ let buttons = Frame.create tl in
+ let ok = Button.create buttons ~text:"Ok" ~command:
+ begin fun () ->
+ let l = get_int il
+ and c = get_int ic in
+ Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]);
+ Text.see tw ~index:(`Mark "insert", []);
+ destroy tl
+ end
+ and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
+
+ Focus.set il;
+ List.iter [il; ic] ~f:
+ begin fun w ->
+ Jg_bind.enter_focus w;
+ Jg_bind.return_invoke w ~button:ok
+ end;
+ pack [ll; lc] ~side:`Top ~anchor:`W;
+ pack [il; ic] ~side:`Top ~fill:`X ~expand:true;
+ pack [fl; fi] ~side:`Left ~fill:`X ~expand:true;
+ pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true;
+ pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true
+
+let select_shell txt =
+ let shells = Shell.get_all () in
+ let shells = List.sort shells ~cmp:compare in
+ let tl = Jg_toplevel.titled "Select Shell" in
+ Jg_bind.escape_destroy tl;
+ Wm.transient_set tl ~master:(Winfo.toplevel txt.tw);
+ let label = Label.create tl ~text:"Send to:"
+ and box = Listbox.create tl
+ and frame = Frame.create tl in
+ Jg_bind.enter_focus box;
+ let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel"
+ and ok = Button.create frame ~text:"Ok" ~command:
+ begin fun () ->
+ try
+ let name = Listbox.get box ~index:`Active in
+ txt.shell <- Some (name, List.assoc name shells);
+ destroy tl
+ with Not_found -> txt.shell <- None; destroy tl
+ end
+ in
+ Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells);
+ Listbox.configure box ~height:(List.length shells);
+ bind box ~events:[`KeyPressDetail"Return"] ~breakable:true
+ ~action:(fun _ -> Button.invoke ok; break ());
+ bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true
+ ~fields:[`MouseX;`MouseY]
+ ~action:(fun ev ->
+ Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY));
+ Button.invoke ok; break ());
+ pack [label] ~side:`Top ~anchor:`W;
+ pack [box] ~side:`Top ~fill:`Both;
+ pack [frame] ~side:`Bottom ~fill:`X ~expand:true;
+ pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true
+
+open Parser
+
+let send_phrase txt =
+ if txt.shell = None then begin
+ match Shell.get_all () with [] -> ()
+ | [sh] -> txt.shell <- Some sh
+ | l -> select_shell txt
+ end;
+ match txt.shell with None -> ()
+ | Some (_,sh) ->
+ try
+ let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in
+ let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in
+ sh#send phrase;
+ if Str.string_match (Str.regexp ";;") phrase 0
+ then sh#send "\n" else sh#send ";;\n"
+ with Not_found | Protocol.TkError _ ->
+ let text = Text.get txt.tw ~start:tstart ~stop:tend in
+ let buffer = Lexing.from_string text in
+ let start = ref 0
+ and block_start = ref []
+ and pend = ref (-1)
+ and after = ref false in
+ while !pend = -1 do
+ let token = Lexer.token buffer in
+ let pos =
+ if token = SEMISEMI then Lexing.lexeme_end buffer
+ else Lexing.lexeme_start buffer
+ in
+ let bol = (pos = 0) || text.[pos-1] = '\n' in
+ if not !after &&
+ Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge)
+ ~index:(`Mark"insert",[])
+ then begin
+ after := true;
+ let anon, real =
+ List.partition !block_start ~f:(fun x -> x = -1) in
+ block_start := anon;
+ if real <> [] then start := List.hd real;
+ end;
+ match token with
+ CLASS | EXTERNAL | EXCEPTION | FUNCTOR
+ | LET | MODULE | OPEN | TYPE | VAL | HASH when bol ->
+ if !block_start = [] then
+ if !after then pend := pos else start := pos
+ else block_start := pos :: List.tl !block_start
+ | SEMISEMI ->
+ if !block_start = [] then
+ if !after then pend := Lexing.lexeme_start buffer
+ else start := pos
+ else block_start := pos :: List.tl !block_start
+ | BEGIN | OBJECT ->
+ block_start := -1 :: !block_start
+ | STRUCT | SIG ->
+ block_start := Lexing.lexeme_end buffer :: !block_start
+ | END ->
+ if !block_start = [] then
+ if !after then pend := pos else ()
+ else block_start := List.tl !block_start
+ | EOF ->
+ pend := pos
+ | _ ->
+ ()
+ done;
+ let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in
+ sh#send phrase;
+ sh#send ";;\n"
+
+let search_pos_window txt ~x ~y =
+ if txt.type_info = [] && txt.psignature = [] then () else
+ let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
+ let text = Jg_text.get_all txt.tw in
+ let pos = Searchpos.lines_to_chars l ~text + c in
+ try if txt.type_info <> [] then begin match
+ Searchpos.search_pos_info txt.type_info ~pos
+ with [] -> ()
+ | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env
+ end else begin match
+ Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
+ with [] -> ()
+ | ((kind, lid), env, loc) :: _ ->
+ Searchpos.view_decl lid ~kind ~env
+ end
+ with Not_found -> ()
+
+let search_pos_menu txt ~x ~y =
+ if txt.type_info = [] && txt.psignature = [] then () else
+ let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
+ let text = Jg_text.get_all txt.tw in
+ let pos = Searchpos.lines_to_chars l ~text + c in
+ try if txt.type_info <> [] then begin match
+ Searchpos.search_pos_info txt.type_info ~pos
+ with [] -> ()
+ | (kind, env, loc) :: _ ->
+ let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in
+ let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
+ Menu.popup menu ~x ~y
+ end else begin match
+ Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
+ with [] -> ()
+ | ((kind, lid), env, loc) :: _ ->
+ let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in
+ let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
+ Menu.popup menu ~x ~y
+ end
+ with Not_found -> ()
+
+let string_width s =
+ let width = ref 0 in
+ for i = 0 to String.length s - 1 do
+ if s.[i] = '\t' then width := (!width / 8 + 1) * 8
+ else incr width
+ done;
+ !width
+
+let indent_line =
+ let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in
+ fun tw ->
+ let `Linechar(l,c) = Text.index tw ~index:(ins,[])
+ and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in
+ ignore (Str.string_match reg line 0);
+ let len = Str.match_end () in
+ if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else
+ let width = string_width (Str.matched_string line) in
+ Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]);
+ let indent =
+ if l <= 1 then 2 else
+ let previous =
+ Text.get tw ~start:(ins,[`Line(-1);`Linestart])
+ ~stop:(ins,[`Line(-1);`Lineend]) in
+ ignore (Str.string_match reg previous 0);
+ let previous = Str.matched_string previous in
+ let width_previous = string_width previous in
+ if width_previous <= width then 2 else width_previous - width
+ in
+ Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ')
+
+(* The editor class *)
+
+class editor ~top ~menus = object (self)
+ val file_menu = new Jg_menu.c "File" ~parent:menus
+ val edit_menu = new Jg_menu.c "Edit" ~parent:menus
+ val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus
+ val module_menu = new Jg_menu.c "Modules" ~parent:menus
+ val window_menu = new Jg_menu.c "Windows" ~parent:menus
+ initializer
+ Menu.add_checkbutton menus ~state:`Disabled
+ ~onvalue:"modified" ~offvalue:"unchanged"
+ val mutable current_dir = Unix.getcwd ()
+ val mutable error_messages = []
+ val mutable windows = []
+ val mutable current_tw = Text.create top
+ val vwindow = Textvariable.create ~on:top ()
+ val mutable window_counter = 0
+
+ method has_window name =
+ List.exists windows ~f:(fun x -> x.name = name)
+
+ method reset_window_menu =
+ Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End;
+ List.iter
+ (List.sort windows ~cmp:
+ (fun w1 w2 ->
+ compare (Filename.basename w1.name) (Filename.basename w2.name)))
+ ~f:
+ begin fun txt ->
+ Menu.add_radiobutton window_menu#menu
+ ~label:(Filename.basename txt.name)
+ ~variable:vwindow ~value:txt.number
+ ~command:(fun () -> self#set_edit txt)
+ end
+
+ method set_file_name txt =
+ Menu.configure_checkbutton menus `Last
+ ~label:(Filename.basename txt.name)
+ ~variable:txt.modified
+
+ method set_edit txt =
+ if windows <> [] then
+ Pack.forget [(List.hd windows).frame];
+ windows <- txt :: exclude txt windows;
+ self#reset_window_menu;
+ current_tw <- txt.tw;
+ self#set_file_name txt;
+ Textvariable.set vwindow txt.number;
+ Text.yview txt.tw ~scroll:(`Page 0);
+ pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom
+
+ method new_window name =
+ let tl, tw, sb = Jg_text.create_with_scrollbar top in
+ Text.configure tw ~background:`White;
+ Jg_bind.enter_focus tw;
+ window_counter <- window_counter + 1;
+ let txt =
+ { name = name; tw = tw; frame = tl;
+ number = string_of_int window_counter;
+ modified = Textvariable.create ~on:tw ();
+ shell = None;
+ structure = []; type_info = []; signature = []; psignature = [] }
+ in
+ let control c = Char.chr (Char.code c - 96) in
+ bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore;
+ bind tw ~events:[`KeyPress] ~fields:[`Char]
+ ~action:(fun ev ->
+ if ev.ev_Char <> "" &&
+ (ev.ev_Char.[0] >= ' ' ||
+ List.mem ev.ev_Char.[0]
+ (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y']))
+ then Textvariable.set txt.modified "modified");
+ bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true
+ ~action:(fun _ ->
+ indent_line tw;
+ Textvariable.set txt.modified "modified";
+ break ());
+ bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")]
+ ~action:(fun _ ->
+ let text =
+ Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend])
+ in ignore (Str.string_match (Str.regexp "[ \t]*") text 0);
+ if Str.match_end () <> String.length text then begin
+ Clipboard.clear ();
+ Clipboard.append ~data:text ()
+ end);
+ bind tw ~events:[`KeyRelease] ~fields:[`Char]
+ ~action:(fun ev ->
+ if ev.ev_Char <> "" then
+ Lexical.tag tw ~start:(`Mark"insert", [`Linestart])
+ ~stop:(`Mark"insert", [`Lineend]));
+ bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw);
+ bind tw ~events:[`ButtonPressDetail 2]
+ ~action:(fun _ ->
+ Textvariable.set txt.modified "modified";
+ Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart])
+ ~stop:(`Mark"insert", [`Lineend]));
+ bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~fields:[`MouseX;`MouseY]
+ ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
+ bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY]
+ ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
+
+ pack [sb] ~fill:`Y ~side:`Right;
+ pack [tw] ~fill:`Both ~expand:true ~side:`Left;
+ self#set_edit txt;
+ Textvariable.set txt.modified "unchanged";
+ Lexical.init_tags txt.tw
+
+ method clear_errors () =
+ Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
+ List.iter error_messages
+ ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
+ error_messages <- []
+
+ method typecheck () =
+ self#clear_errors ();
+ error_messages <- Typecheck.f (List.hd windows)
+
+ method lex () =
+ List.iter [ Widget.default_toplevel; top ]
+ ~f:(Toplevel.configure ~cursor:(`Xcursor "watch"));
+ Text.configure current_tw ~cursor:(`Xcursor "watch");
+ ignore (Timer.add ~ms:1 ~callback:
+ begin fun () ->
+ Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
+ Lexical.tag current_tw;
+ Text.configure current_tw ~cursor:(`Xcursor "xterm");
+ List.iter [ Widget.default_toplevel; top ]
+ ~f:(Toplevel.configure ~cursor:(`Xcursor ""))
+ end)
+
+ method save_text ?name:l txt =
+ let l = match l with None -> [txt.name] | Some l -> l in
+ if l = [] then () else
+ let name = List.hd l in
+ if txt.name <> name then current_dir <- Filename.dirname name;
+ try
+ if Sys.file_exists name then
+ if txt.name = name then begin
+ let backup = name ^ "~" in
+ if Sys.file_exists backup then Sys.remove backup;
+ try Sys.rename name backup with Sys_error _ -> ()
+ end else begin
+ match Jg_message.ask ~master:top ~title:"Save"
+ ("File `" ^ name ^ "' exists. Overwrite it?")
+ with `Yes -> Sys.remove name
+ | `No -> raise (Sys_error "")
+ | `Cancel -> raise Exit
+ end;
+ let file = open_out name in
+ let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in
+ output_string file text;
+ close_out file;
+ txt.name <- name;
+ self#set_file_name txt
+ with
+ Sys_error _ ->
+ Jg_message.info ~master:top ~title:"Error"
+ ("Could not save `" ^ name ^ "'.")
+ | Exit -> ()
+
+ method load_text l =
+ if l = [] then () else
+ let name = List.hd l in
+ try
+ let index =
+ try
+ self#set_edit (List.find windows ~f:(fun x -> x.name = name));
+ let txt = List.hd windows in
+ if Textvariable.get txt.modified = "modified" then
+ begin match Jg_message.ask ~master:top ~title:"Open"
+ ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
+ with `Yes -> self#save_text txt
+ | `No -> ()
+ | `Cancel -> raise Exit
+ end;
+ Textvariable.set txt.modified "unchanged";
+ (Text.index current_tw ~index:(`Mark"insert", []), [])
+ with Not_found -> self#new_window name; tstart
+ in
+ current_dir <- Filename.dirname name;
+ let file = open_in name
+ and tw = current_tw
+ and len = ref 0
+ and buf = Bytes.create 4096 in
+ Text.delete tw ~start:tstart ~stop:tend;
+ while
+ len := input file buf 0 4096;
+ !len > 0
+ do
+ Jg_text.output tw ~buf:(Bytes.unsafe_to_string buf) ~pos:0 ~len:!len
+ done;
+ close_in file;
+ Text.mark_set tw ~mark:"insert" ~index;
+ Text.see tw ~index;
+ if Filename.check_suffix name ".ml" ||
+ Filename.check_suffix name ".mli"
+ then begin
+ if !lex_on_load then self#lex ();
+ if !type_on_load then self#typecheck ()
+ end
+ with
+ Sys_error _ | Exit -> ()
+
+ method close_window txt =
+ try
+ if Textvariable.get txt.modified = "modified" then
+ begin match Jg_message.ask ~master:top ~title:"Close"
+ ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
+ with `Yes -> self#save_text txt
+ | `No -> ()
+ | `Cancel -> raise Exit
+ end;
+ windows <- exclude txt windows;
+ if windows = [] then
+ self#new_window (current_dir ^ "/untitled")
+ else self#set_edit (List.hd windows);
+ destroy txt.frame
+ with Exit -> ()
+
+ method open_file () =
+ Fileselect.f ~title:"Open File" ~action:self#load_text
+ ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true ()
+
+ method save_file () = self#save_text (List.hd windows)
+
+ method close_file () = self#close_window (List.hd windows)
+
+ method quit ?(cancel=true) () =
+ try
+ List.iter windows ~f:
+ begin fun txt ->
+ if Textvariable.get txt.modified = "modified" then
+ match Jg_message.ask ~master:top ~title:"Quit" ~cancel
+ ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
+ with `Yes -> self#save_text txt
+ | `No -> ()
+ | `Cancel -> raise Exit
+ end;
+ bind top ~events:[`Destroy];
+ destroy top
+ with Exit -> ()
+
+ method reopen ~file ~pos =
+ if not (Winfo.ismapped top) then Wm.deiconify top;
+ match file with None -> ()
+ | Some file ->
+ self#load_text [file];
+ Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos);
+ try
+ let index =
+ Text.search current_tw ~switches:[`Backwards] ~pattern:"*)"
+ ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in
+ let index =
+ Text.search current_tw ~switches:[`Backwards] ~pattern:"(*"
+ ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in
+ let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart])
+ ~stop:(index,[`Line(-1);`Lineend]) in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with '\t'|' ' -> () | _ -> raise Not_found
+ done;
+ Text.yview_index current_tw ~index:(index,[`Line(-1)])
+ with _ ->
+ Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)])
+
+ initializer
+ (* Create a first window *)
+ self#new_window (current_dir ^ "/untitled");
+
+ (* Bindings for the main window *)
+ List.iter
+ [ [`Control], "s", (fun () -> Jg_text.search_string current_tw);
+ [`Control], "g", (fun () -> goto_line current_tw);
+ [`Alt], "s", self#save_file;
+ [`Alt], "x", (fun () -> send_phrase (List.hd windows));
+ [`Alt], "l", self#lex;
+ [`Alt], "t", self#typecheck ]
+ ~f:begin fun (modi,key,act) ->
+ bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true
+ ~action:(fun _ -> act (); break ())
+ end;
+
+ bind top ~events:[`Destroy] ~fields:[`Widget] ~action:
+ begin fun ev ->
+ if Widget.name ev.ev_Widget = Widget.name top
+ then self#quit ~cancel:false ()
+ end;
+
+ (* File menu *)
+ file_menu#add_command "Open File..." ~command:self#open_file;
+ file_menu#add_command "Reopen"
+ ~command:(fun () -> self#load_text [(List.hd windows).name]);
+ file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s";
+ file_menu#add_command "Save As..." ~underline:5 ~command:
+ begin fun () ->
+ let txt = List.hd windows in
+ Fileselect.f ~title:"Save as File"
+ ~action:(fun name -> self#save_text txt ~name)
+ ~dir:(Filename.dirname txt.name)
+ ~filter:"*.{ml,mli}"
+ ~file:(Filename.basename txt.name)
+ ~sync:true ~usepath:false ()
+ end;
+ file_menu#add_command "Close File" ~command:self#close_file;
+ file_menu#add_command "Close Window" ~command:self#quit ~underline:6;
+
+ (* Edit menu *)
+ edit_menu#add_command "Paste selection" ~command:
+ begin fun () ->
+ Text.insert current_tw ~index:(`Mark"insert",[])
+ ~text:(Selection.get ~displayof:top ())
+ end;
+ edit_menu#add_command "Goto..." ~accelerator:"C-g"
+ ~command:(fun () -> goto_line current_tw);
+ edit_menu#add_command "Search..." ~accelerator:"C-s"
+ ~command:(fun () -> Jg_text.search_string current_tw);
+ edit_menu#add_command "To shell" ~accelerator:"M-x"
+ ~command:(fun () -> send_phrase (List.hd windows));
+ edit_menu#add_command "Select shell..."
+ ~command:(fun () -> select_shell (List.hd windows));
+
+ (* Compiler menu *)
+ compiler_menu#add_command "Preferences..."
+ ~command:(fun () -> compiler_preferences top);
+ compiler_menu#add_command "Lex" ~accelerator:"M-l"
+ ~command:self#lex;
+ compiler_menu#add_command "Typecheck" ~accelerator:"M-t"
+ ~command:self#typecheck;
+ compiler_menu#add_command "Clear errors"
+ ~command:self#clear_errors;
+ compiler_menu#add_command "Signature..." ~command:
+ begin fun () ->
+ let txt = List.hd windows in if txt.signature <> [] then
+ let basename = Filename.basename txt.name in
+ let modname = String.capitalize_ascii
+ (try Filename.chop_extension basename with _ -> basename) in
+ let env =
+ Env.add_module (Ident.create modname)
+ (Types.Mty_signature txt.signature)
+ !Searchid.start_env
+ in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true
+ end;
+
+ (* Modules *)
+ module_menu#add_command "Path editor..."
+ ~command:(fun () -> Setpath.set ~dir:current_dir);
+ module_menu#add_command "Reset cache"
+ ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ());
+ module_menu#add_command "Search symbol..."
+ ~command:Viewer.search_symbol;
+ module_menu#add_command "Close all"
+ ~command:Viewer.close_all_views;
+end
+
+(* The main function starts here ! *)
+
+let already_open : editor list ref = ref []
+
+let editor ?file ?(pos=0) ?(reuse=false) () =
+
+ if !already_open <> [] &&
+ let ed = List.hd !already_open
+ (* try
+ let name = match file with Some f -> f | None -> raise Not_found in
+ List.find !already_open ~f:(fun ed -> ed#has_window name)
+ with Not_found -> List.hd !already_open *)
+ in try
+ ed#reopen ~file ~pos;
+ true
+ with Protocol.TkError _ ->
+ already_open := [] (* List.filter !already_open ~f:((<>) ed) *);
+ false
+ then () else
+ let top = Jg_toplevel.titled "OCamlBrowser Editor" in
+ let menus = Jg_menu.menubar top in
+ let ed = new editor ~top ~menus in
+ already_open := !already_open @ [ed];
+ if file <> None then ed#reopen ~file ~pos
+
+let f ?file ?pos ?(opendialog=false) () =
+ if opendialog then
+ Fileselect.f ~title:"Open File"
+ ~action:(function [file] -> editor ~file () | _ -> ())
+ ~filter:("*.{ml,mli}") ~sync:true ()
+ else editor ?file ?pos ~reuse:(file <> None) ()
diff --git a/browser/editor.mli b/browser/editor.mli
new file mode 100644
index 0000000..2d5e904
--- /dev/null
+++ b/browser/editor.mli
@@ -0,0 +1,20 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit
+ (* open the file editor *)
diff --git a/browser/fileselect.ml b/browser/fileselect.ml
new file mode 100644
index 0000000..52f55b8
--- /dev/null
+++ b/browser/fileselect.ml
@@ -0,0 +1,290 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+(* file selection box *)
+
+open StdLabels
+open Str
+open Filename
+open Tk
+
+open Useunix
+
+(**** Memoized rexgexp *)
+
+let (~!) = Jg_memo.fast ~f:Str.regexp
+
+(************************************************************ Path name *)
+
+(* Convert Windows-style directory separator '\' to caml-style '/' *)
+let caml_dir path =
+ if Sys.os_type = "Win32" then
+ global_replace ~!"\\\\" "/" path
+ else path
+
+let parse_filter s =
+ let s = caml_dir s in
+ (* replace // by / *)
+ let s = global_replace ~!"/+" "/" s in
+ (* replace /./ by / *)
+ let s = global_replace ~!"/\\./" "/" s in
+ (* replace hoge/../ by "" *)
+ let s = global_replace
+ ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in
+ (* replace hoge/..$ by *)
+ let s = global_replace
+ ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in
+ (* replace ^/hoge/../ by / *)
+ let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in
+ if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then
+ let dirs = matched_group 1 s
+ and ptrn = matched_group 2 s
+ in
+ dirs, ptrn
+ else "", s
+
+let rec fixpoint ~f v =
+ let v' = f v in
+ if v = v' then v else fixpoint ~f v'
+
+let unix_regexp s =
+ let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in
+ let s = Str.global_replace ~!"\\*" ".*" s in
+ let s = Str.global_replace ~!"\\?" ".?" s in
+ let s =
+ fixpoint s
+ ~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in
+ let s =
+ Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in
+ Str.regexp s
+
+let exact_match ~pat s =
+ Str.string_match pat s 0 && Str.match_end () = String.length s
+
+let ls ~dir ~pattern =
+ let files = get_files_in_directory dir in
+ let regexp = unix_regexp pattern in
+ List.filter files ~f:(exact_match ~pat:regexp)
+
+(********************************************* Creation *)
+let load_in_path = ref false
+
+let search_in_path ~name = Misc.find_in_path !Config.load_path name
+
+let f ~title ~action:proc ?(dir = Unix.getcwd ())
+ ?filter:(deffilter ="*") ?file:(deffile ="")
+ ?(multi=false) ?(sync=false) ?(usepath=true) () =
+
+ let current_pattern = ref ""
+ and current_dir = ref (caml_dir dir) in
+
+ let may_prefix name =
+ if Filename.is_relative name then concat !current_dir name else name in
+
+ let tl = Jg_toplevel.titled title in
+ Focus.set tl;
+
+ let new_var () = Textvariable.create ~on:tl () in
+ let filter_var = new_var ()
+ and selection_var = new_var ()
+ and sync_var = new_var () in
+ Textvariable.set filter_var deffilter;
+
+ let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
+ let df = Frame.create frm in
+ let dfl = Frame.create df in
+ let dfll = Label.create dfl ~text:"Directories" in
+ let dflf, directory_listbox, directory_scrollbar =
+ Jg_box.create_with_scrollbar dfl in
+ let dfr = Frame.create df in
+ let dfrl = Label.create dfr ~text:"Files" in
+ let dfrf, filter_listbox, filter_scrollbar =
+ Jg_box.create_with_scrollbar dfr in
+ let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
+
+ let configure ~filter =
+ let filter = may_prefix filter in
+ let dir, pattern = parse_filter filter in
+ let dir = if !load_in_path && usepath then "" else
+ (current_dir := Filename.dirname dir; dir)
+ and pattern = if pattern = "" then "*" else pattern in
+ current_pattern := pattern;
+ let filter =
+ if !load_in_path && usepath then pattern else dir ^ pattern in
+ let directories = get_directories_in_files ~path:dir
+ (get_files_in_directory dir) in
+ let matched_files = (* get matched file by subshell call. *)
+ if !load_in_path && usepath then
+ List.fold_left !Config.load_path ~init:[] ~f:
+ begin fun acc dir ->
+ let files = ls ~dir ~pattern in
+ List.merge compare files
+ (List.fold_left files ~init:acc
+ ~f:(fun acc name -> List2.exclude name acc))
+ end
+ else
+ List.fold_left directories ~init:(ls ~dir ~pattern)
+ ~f:(fun acc dir -> List2.exclude dir acc)
+ in
+ Textvariable.set filter_var filter;
+ Textvariable.set selection_var (dir ^ deffile);
+ Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
+ Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
+ Jg_box.recenter filter_listbox ~index:(`Num 0);
+ if !load_in_path && usepath then
+ Listbox.configure directory_listbox ~takefocus:false
+ else
+ begin
+ Listbox.configure directory_listbox ~takefocus:true;
+ Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
+ Listbox.insert directory_listbox ~index:`End ~texts:directories;
+ Jg_box.recenter directory_listbox ~index:(`Num 0)
+ end
+ in
+
+ let selected_files = ref [] in (* used for synchronous mode *)
+ let activate l =
+ Grab.release tl;
+ destroy tl;
+ let l =
+ if !load_in_path && usepath then
+ List.fold_right l ~init:[] ~f:
+ begin fun name acc ->
+ if not (Filename.is_implicit name) then
+ may_prefix name :: acc
+ else try search_in_path ~name :: acc with Not_found -> acc
+ end
+ else
+ List.map l ~f:may_prefix
+ in
+ if sync then
+ begin
+ selected_files := l;
+ Textvariable.set sync_var "1"
+ end
+ else proc l
+ in
+
+ (* entries *)
+ let fl = Label.create frm ~text:"Filter" in
+ let sl = Label.create frm ~text:"Selection" in
+ let filter_entry = Jg_entry.create frm ~textvariable:filter_var
+ ~command:(fun filter -> configure ~filter) in
+ let selection_entry = Jg_entry.create frm ~textvariable:selection_var
+ ~command:(fun file -> activate [file]) in
+
+ (* and buttons *)
+ let set_path = Button.create dfl ~text:"Path editor" ~command:
+ begin fun () ->
+ Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern);
+ let w = Setpath.f ~dir:!current_dir in
+ Grab.set w;
+ bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl)
+ end in
+ let toggle_in_path = Checkbutton.create dfl ~text:"Use load path"
+ ~command:
+ begin fun () ->
+ load_in_path := not !load_in_path;
+ if !load_in_path then
+ pack [set_path] ~side:`Bottom ~fill:`X ~expand:true
+ else
+ Pack.forget [set_path];
+ configure ~filter:(Textvariable.get filter_var)
+ end
+ and okb = Button.create cfrm ~text:"Ok" ~command:
+ begin fun () ->
+ let files =
+ List.map (Listbox.curselection filter_listbox) ~f:
+ begin fun x ->
+ !current_dir ^ Listbox.get filter_listbox ~index:x
+ end
+ in
+ let files = if files = [] then [Textvariable.get selection_var]
+ else files in
+ activate files
+ end
+ and flb = Button.create cfrm ~text:"Filter"
+ ~command:(fun () -> configure ~filter:(Textvariable.get filter_var))
+ and ccb = Button.create cfrm ~text:"Cancel"
+ ~command:(fun () -> activate []) in
+
+ (* binding *)
+ bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []);
+ Jg_box.add_completion filter_listbox
+ ~action:(fun index -> activate [Listbox.get filter_listbox ~index]);
+ if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else
+ bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY]
+ ~action:(fun ev ->
+ let name = Listbox.get filter_listbox
+ ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in
+ if !load_in_path && usepath then
+ try Textvariable.set selection_var (search_in_path ~name)
+ with Not_found -> ()
+ else Textvariable.set selection_var (may_prefix name));
+
+ Jg_box.add_completion directory_listbox ~action:
+ begin fun index ->
+ let filter =
+ may_prefix (Listbox.get directory_listbox ~index) ^
+ "/" ^ !current_pattern
+ in configure ~filter
+ end;
+
+ pack [frm] ~fill:`Both ~expand:true;
+ (* filter *)
+ pack [fl] ~side:`Top ~anchor:`W;
+ pack [filter_entry] ~side:`Top ~fill:`X;
+
+ (* directory + files *)
+ pack [df] ~side:`Top ~fill:`Both ~expand:true;
+ (* directory *)
+ pack [dfl] ~side:`Left ~fill:`Both ~expand:true;
+ pack [dfll] ~side:`Top ~anchor:`W;
+ if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W;
+ pack [dflf] ~side:`Top ~fill:`Both ~expand:true;
+ pack [directory_scrollbar] ~side:`Right ~fill:`Y;
+ pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true;
+ (* files *)
+ pack [dfr] ~side:`Right ~fill:`Both ~expand:true;
+ pack [dfrl] ~side:`Top ~anchor:`W;
+ pack [dfrf] ~side:`Top ~fill:`Both ~expand:true;
+ pack [filter_scrollbar] ~side:`Right ~fill:`Y;
+ pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true;
+
+ (* selection *)
+ pack [sl] ~before:df ~side:`Bottom ~anchor:`W;
+ pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X;
+
+ (* create OK, Filter and Cancel buttons *)
+ pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true;
+ pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X;
+
+ if !load_in_path && usepath then begin
+ load_in_path := false;
+ Checkbutton.invoke toggle_in_path;
+ Checkbutton.select toggle_in_path
+ end
+ else configure ~filter:deffilter;
+
+ Tkwait.visibility tl;
+ Grab.set tl;
+
+ if sync then
+ begin
+ Tkwait.variable sync_var;
+ proc !selected_files
+ end;
+ ()
diff --git a/browser/fileselect.mli b/browser/fileselect.mli
new file mode 100644
index 0000000..ed10eaf
--- /dev/null
+++ b/browser/fileselect.mli
@@ -0,0 +1,39 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+val f :
+ title:string ->
+ action:(string list -> unit) ->
+ ?dir:string ->
+ ?filter:string ->
+ ?file:string ->
+ ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit
+
+(* action
+ [] means canceled
+ if multi select is false, then the list is null or a singleton *)
+
+(* multi
+ If true then more than one file are selectable *)
+
+(* sync
+ If true then synchronous mode *)
+
+(* usepath
+ Enables/disables load path search. Defaults to true *)
+
+val caml_dir : string -> string
+(* Convert Windows-style directory separator '\' to caml-style '/' *)
diff --git a/browser/help.txt b/browser/help.txt
new file mode 100644
index 0000000..3b8c9b8
--- /dev/null
+++ b/browser/help.txt
@@ -0,0 +1,166 @@
+ OCamlBrowser Help
+
+USE
+
+ OCamlBrowser is composed of three tools, the Editor, which allows
+ one to edit/typecheck/analyse .mli and .ml files, the Viewer, to
+ walk around compiled modules, and the Shell, to run an OCaml
+ subshell. You may only have one instance of Editor and Viewer, but
+ you may use several subshells.
+
+ As with the compiler, you may specify a different path for the
+ standard library by setting OCAMLLIB. You may also extend the
+ initial load path (only standard library by default) by using the
+ -I command line option. The -nolabels, -rectypes and -w options are
+ also accepted, and inherited by subshells.
+ The -oldui options selects the old multi-window interface. The
+ default is now more like Smalltalk's class browser.
+
+1) Viewer
+
+ This is the first window you get when you start OCamlBrowser. It
+ displays a search window, and the list of modules in the load path.
+ At the top a row of menus.
+
+ File - Open and File - Editor give access to the editor.
+
+ File - Shell opens an OCaml shell.
+
+ View - Show all defs displays the signature of the currently
+ selected module.
+
+ View - Search entry shows/hides the search entry just
+ below the menu bar.
+
+ Modules - Path editor changes the load path.
+ Pressing [Add to path] or Insert key adds selected directories
+ to the load path.
+ Pressing [Remove from path] or Delete key removes selected
+ paths from the load path.
+
+ Modules - Reset cache rescans the load path and resets the module
+ cache. Do it if you recompile some interface, or change the load
+ path in a conflictual way.
+
+ Modules - Search symbol allows to search a symbol either by its
+ name, like the bottom line of the viewer, or, more interestingly,
+ by its type. Exact type searches for a type with exactly the same
+ information as the pattern (variables match only variables),
+ included type allows to give only partial information: the actual
+ type may take more arguments and return more results, and variables
+ in the pattern match anything. In both cases, argument and tuple
+ order is irrelevant (*), and unlabeled arguments in the pattern
+ match any label.
+
+ (*) To avoid combinatorial explosion of the search space, optional
+ arguments in the actual type are ignored if (1) there are to many
+ of them, and (2) they do not appear explicitly in the pattern.
+
+ The Search entry just below the menu bar allows one to search for
+ an identifier in all modules, either by its name (? and * patterns
+ allowed) or by its type (if there is an arrow in the input). When
+ search by type is used, it is done in inclusion mode (cf. Modules -
+ search symbol)
+
+ The Close all button is there to dismiss the windows created
+ by the Detach button. By double-clicking on it you will quit the
+ browser.
+
+
+2) Module browsing
+
+ You select a module in the leftmost box by either cliking on it or
+ pressing return when it is selected. Fast access is available in
+ all boxes pressing the first few letter of the desired name.
+ Double-clicking / double-return displays the whole signature for
+ the module.
+
+ Defined identifiers inside the module are displayed in a box to the
+ right of the previous one. If you click on one, this will either
+ display its contents in another box (if this is a sub-module) or
+ display the signature for this identifier below.
+
+ Signatures are clickable. Double clicking with the left mouse
+ button on an identifier in a signature brings you to its signature,
+ inside its module box.
+ A single click on the right button pops up a menu displaying the
+ type declaration for the selected identifier. Its title, when
+ selectable, also brings you to its signature.
+
+ At the bottom, a series of buttons, depending on the context.
+ * Detach copies the currently displayed signature in a new window,
+ to keep it.
+ * Impl and Intf bring you to the implementation or interface of
+ the currently displayed signature, if it is available.
+
+ C-s opens a text search dialog for the displayed signature.
+
+3) File editor
+
+ You can edit files with it, but there is no auto-save nor undo at
+ the moment. Otherwise you can use it as a browser, making
+ occasional corrections.
+
+ The Edit menu contains commands for jump (C-g), search (C-s), and
+ sending the current selection to a sub-shell (M-x). For this last
+ option, you may choose the shell via a dialog.
+
+ Essential function are in the Compiler menu.
+
+ Preferences opens a dialog to set internals of the editor and
+ type checker.
+
+ Lex (M-l) adds colors according to lexical categories.
+
+ Typecheck (M-t) verifies typing, and memorizes it to let one see an
+ expression's type by double-clicking on it. This is also valid for
+ interfaces. If an error occurs, the part of the interface preceding
+ the error is computed.
+
+ After typechecking, pressing the right button pops up a menu giving
+ the type of the pointed expression, and eventually allowing to
+ follow some links.
+
+ Clear errors dismisses type checker error messages and warnings.
+
+ Signature shows the signature of the current file.
+
+4) Shell
+
+ When you create a shell, a dialog is presented to you, letting you
+ choose which command you want to run, and the title of the shell
+ (to choose it in the Editor).
+
+ You may change the default command by setting the OLABL environment
+ variable.
+
+ The executed subshell is given the current load path.
+ File: use a source file or load a bytecode file.
+ You may also import the browser's path into the subprocess.
+ History: M-p and M-n browse up and down.
+ Signal: C-c interrupts and you can kill the subprocess.
+
+BUGS
+
+* When you quit the editor and some file was modified, a dialogue is
+ displayed asking wether you want to really quit or not. But 1) if
+ you quit directly from the viewer, there is no dialogue at all, and
+ 2) if you close from the window manager, the dialogue is displayed,
+ but you cannot cancel the destruction... Beware.
+
+* When you run it through xon, the shell hangs at the first error. But
+ its ok if you start ocamlbrowser from a remote shell...
+
+TODO
+
+* Complete cross-references.
+
+* Power up editor.
+
+* Add support for the debugger.
+
+* Make this a real programming environment, both for beginners and
+ experimented users.
+
+
+Bug reports and comments to
diff --git a/browser/jg_bind.ml b/browser/jg_bind.ml
new file mode 100644
index 0000000..3fb854b
--- /dev/null
+++ b/browser/jg_bind.ml
@@ -0,0 +1,28 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let enter_focus w =
+ bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w)
+
+let escape_destroy ?destroy:tl w =
+ let tl = match tl with Some w -> w | None -> w in
+ bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl)
+
+let return_invoke w ~button =
+ bind w ~events:[`KeyPressDetail "Return"]
+ ~action:(fun _ -> Button.invoke button)
diff --git a/browser/jg_bind.mli b/browser/jg_bind.mli
new file mode 100644
index 0000000..70e323b
--- /dev/null
+++ b/browser/jg_bind.mli
@@ -0,0 +1,21 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val enter_focus : 'a widget -> unit
+val escape_destroy : ?destroy:'a widget -> 'a widget ->unit
+val return_invoke : 'a widget -> button:button widget -> unit
diff --git a/browser/jg_box.ml b/browser/jg_box.ml
new file mode 100644
index 0000000..bc865f6
--- /dev/null
+++ b/browser/jg_box.ml
@@ -0,0 +1,82 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let add_scrollbar lb =
+ let sb =
+ Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in
+ Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb
+
+let create_with_scrollbar ?selectmode parent =
+ let frame = Frame.create parent in
+ let lb = Listbox.create frame ?selectmode in
+ frame, lb, add_scrollbar lb
+
+(* from frx_listbox,adapted *)
+
+let recenter lb ~index =
+ Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
+ (* Activate it, to keep consistent with Up/Down.
+ You have to be in Extended or Browse mode *)
+ Listbox.activate lb ~index;
+ Listbox.selection_anchor lb ~index;
+ Listbox.yview_index lb ~index
+
+class timed ?wait ?nocase get_texts = object
+ val get_texts = get_texts
+ inherit Jg_completion.timed [] ?wait ?nocase as super
+ method! reset =
+ texts <- get_texts ();
+ super#reset
+end
+
+let add_completion ?action ?wait ?nocase ?(double=true) lb =
+ let comp =
+ new timed ?wait ?nocase
+ (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in
+
+ Jg_bind.enter_focus lb;
+
+ bind lb ~events:[`KeyPress] ~fields:[`Char] ~action:
+ begin fun ev ->
+ (* consider only keys producing characters. The callback is called
+ even if you press Shift. *)
+ if ev.ev_Char <> "" then
+ recenter lb ~index:(`Num (comp#add ev.ev_Char))
+ end;
+
+ begin match action with
+ Some action ->
+ bind lb ~events:[`KeyPressDetail "Return"]
+ ~action:(fun _ -> action `Active);
+ let bmod = if double then [`Double] else [] in
+ bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)]
+ ~breakable:true ~fields:[`MouseY]
+ ~action:
+ begin fun ev ->
+ let index = Listbox.nearest lb ~y:ev.ev_MouseY in
+ if not double then begin
+ Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
+ Listbox.selection_set lb ~first:index ~last:index;
+ end;
+ action index;
+ break ()
+ end
+ | None -> ()
+ end;
+
+ recenter lb ~index:(`Num 0) (* so that first item is active *)
diff --git a/browser/jg_button.ml b/browser/jg_button.ml
new file mode 100644
index 0000000..de8d358
--- /dev/null
+++ b/browser/jg_button.ml
@@ -0,0 +1,25 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let create_destroyer ~parent ?(text="Ok") tl =
+ Button.create parent ~text ~command:(fun () -> destroy tl)
+
+let add_destroyer ?text tl =
+ let b = create_destroyer tl ~parent:tl ?text in
+ pack [b] ~side:`Bottom ~fill:`X;
+ b
diff --git a/browser/jg_completion.ml b/browser/jg_completion.ml
new file mode 100644
index 0000000..fa6b76a
--- /dev/null
+++ b/browser/jg_completion.ml
@@ -0,0 +1,54 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+let compare_string ?(nocase=false) s1 s2 =
+ if nocase then compare (String.lowercase_ascii s1) (String.lowercase_ascii s2)
+ else compare s1 s2
+
+class completion ?nocase texts = object
+ val mutable texts = texts
+ val nocase = nocase
+ val mutable prefix = ""
+ val mutable current = 0
+ method add c =
+ prefix <- prefix ^ c;
+ while current < List.length texts - 1 &&
+ compare_string (List.nth texts current) prefix ?nocase < 0
+ do
+ current <- current + 1
+ done;
+ current
+ method current = current
+ method get_current = List.nth texts current
+ method reset =
+ prefix <- "";
+ current <- 0
+end
+
+class timed ?nocase ?wait texts = object (self)
+ inherit completion texts ?nocase as super
+ val wait = match wait with None -> 500 | Some n -> n
+ val mutable timer = None
+ method! add c =
+ begin match timer with
+ None -> self#reset
+ | Some t -> Timer.remove t
+ end;
+ timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset));
+ super#add c
+ method! reset =
+ timer <- None; super#reset
+end
diff --git a/browser/jg_completion.mli b/browser/jg_completion.mli
new file mode 100644
index 0000000..2090800
--- /dev/null
+++ b/browser/jg_completion.mli
@@ -0,0 +1,25 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+val compare_string : ?nocase:bool -> string -> string -> int
+
+class timed : ?nocase:bool -> ?wait:int -> string list -> object
+ val mutable texts : string list
+ method add : string -> int
+ method current : int
+ method get_current : string
+ method reset : unit
+end
diff --git a/browser/jg_config.ml b/browser/jg_config.ml
new file mode 100644
index 0000000..fbbd2ef
--- /dev/null
+++ b/browser/jg_config.ml
@@ -0,0 +1,40 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Jg_tk
+
+let fixed = if wingui then "{Courier New} 8" else "fixed"
+let variable = if wingui then "Arial 9" else "variable"
+
+let init () =
+ if wingui then Option.add ~path:"*font" fixed;
+ let font =
+ let font =
+ Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in
+ if font = "" then variable else font
+ in
+ List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"]
+ ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font);
+ Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile;
+ Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile;
+ Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile;
+ Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile;
+ let foreground =
+ Option.get Widget.default_toplevel
+ ~name:"disabledForeground" ~clas:"Foreground" in
+ if foreground = "" then
+ Option.add ~path:"*disabledForeground" "black"
diff --git a/browser/jg_config.mli b/browser/jg_config.mli
new file mode 100644
index 0000000..fdaab3f
--- /dev/null
+++ b/browser/jg_config.mli
@@ -0,0 +1,17 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+val init: unit -> unit
diff --git a/browser/jg_entry.ml b/browser/jg_entry.ml
new file mode 100644
index 0000000..1f7aab7
--- /dev/null
+++ b/browser/jg_entry.ml
@@ -0,0 +1,27 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let create ?command ?width ?textvariable parent =
+ let ew = Entry.create parent ?width ?textvariable in
+ Jg_bind.enter_focus ew;
+ begin match command with Some command ->
+ bind ew ~events:[`KeyPressDetail "Return"]
+ ~action:(fun _ -> command (Entry.get ew))
+ | None -> ()
+ end;
+ ew
diff --git a/browser/jg_memo.ml b/browser/jg_memo.ml
new file mode 100644
index 0000000..fb1c05e
--- /dev/null
+++ b/browser/jg_memo.ml
@@ -0,0 +1,33 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+type ('a, 'b) assoc_list =
+ Nil
+ | Cons of 'a * 'b * ('a, 'b) assoc_list
+
+let rec assq key = function
+ Nil -> raise Not_found
+ | Cons (a, b, l) ->
+ if key == a then b else assq key l
+
+let fast ~f =
+ let memo = ref Nil in
+ fun key ->
+ try assq key !memo
+ with Not_found ->
+ let data = f key in
+ memo := Cons(key, data, !memo);
+ data
diff --git a/browser/jg_memo.mli b/browser/jg_memo.mli
new file mode 100644
index 0000000..14443ad
--- /dev/null
+++ b/browser/jg_memo.mli
@@ -0,0 +1,19 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+val fast : f:('a -> 'b) -> 'a -> 'b
+(* "fast" memoizer: uses a List.assq like function *)
+(* Good for a smallish number of keys, phisically equal *)
diff --git a/browser/jg_menu.ml b/browser/jg_menu.ml
new file mode 100644
index 0000000..880ca77
--- /dev/null
+++ b/browser/jg_menu.ml
@@ -0,0 +1,44 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+class c ~parent ?(underline=0) label = object (self)
+ val menu =
+ let menu = Menu.create parent in
+ Menu.add_cascade parent ~menu ~label ~underline;
+ menu
+ method menu = menu
+ method virtual add_command :
+ ?underline:int ->
+ ?accelerator:string -> ?activebackground:color ->
+ ?activeforeground:color -> ?background:color ->
+ ?bitmap:bitmap -> ?command:(unit -> unit) ->
+ ?font:string -> ?foreground:color ->
+ ?image:image -> ?state:state ->
+ string -> unit
+ method add_command ?(underline=0) ?accelerator ?activebackground
+ ?activeforeground ?background ?bitmap ?command ?font ?foreground
+ ?image ?state label =
+ Menu.add_command menu ~label ~underline ?accelerator
+ ?activebackground ?activeforeground ?background ?bitmap
+ ?command ?font ?foreground ?image ?state
+end
+
+let menubar tl =
+ let menu = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+ Toplevel.configure tl ~menu;
+ menu
diff --git a/browser/jg_message.ml b/browser/jg_message.ml
new file mode 100644
index 0000000..d4d3ebb
--- /dev/null
+++ b/browser/jg_message.ml
@@ -0,0 +1,111 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Jg_tk
+
+(*
+class formatted ~parent ~width ~maxheight ~minheight =
+ val parent = (parent : Widget.any Widget.widget)
+ val width = width
+ val maxheight = maxheight
+ val minheight = minheight
+ val tw = Text.create ~parent ~width ~wrap:`Word
+ val fof = Format.get_formatter_output_functions ()
+ method parent = parent
+ method init =
+ pack [tw] ~side:`Left ~fill:`Both ~expand:true;
+ Format.print_flush ();
+ Format.set_margin (width - 2);
+ Format.set_formatter_output_functions ~out:(Jg_text.output tw)
+ ~flush:(fun () -> ())
+ method finish =
+ Format.print_flush ();
+ Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof);
+ let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in
+ Text.configure tw ~height:(max minheight (min l maxheight));
+ if l > 5 then
+ pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y
+end
+*)
+
+let formatted ~title ?on ?(ppf = Format.std_formatter)
+ ?(width=60) ?(maxheight=10) ?(minheight=0) () =
+ let tl, frame =
+ match on with
+ Some frame ->
+(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in
+ pack [label] ~side:`Top ~fill:`X;
+ let frame2 = Frame.create frame in
+ pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *)
+ coe frame, frame
+ | None ->
+ let tl = Jg_toplevel.titled title in
+ Jg_bind.escape_destroy tl;
+ let frame = Frame.create tl in
+ pack [frame] ~side:`Top ~fill:`Both ~expand:true;
+ coe tl, frame
+ in
+ let tw = Text.create frame ~width ~wrap:`Word in
+ pack [tw] ~side:`Left ~fill:`Both ~expand:true;
+ Format.pp_print_flush ppf ();
+ Format.pp_set_margin ppf (width - 2);
+ let fof,fff = Format.pp_get_formatter_output_functions ppf () in
+ Format.pp_set_formatter_output_functions ppf
+ (fun buf pos len -> Jg_text.output tw ~buf ~pos ~len)
+ ignore;
+ tl, tw,
+ begin fun () ->
+ Format.pp_print_flush ppf ();
+ Format.pp_set_formatter_output_functions ppf fof fff;
+ let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in
+ Text.configure tw ~height:(max minheight (min l maxheight));
+ if l > 5 then
+ pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y
+ end
+
+let ask ~title ?master ?(no=true) ?(cancel=true) text =
+ let tl = Jg_toplevel.titled title in
+ begin match master with None -> ()
+ | Some master -> Wm.transient_set tl ~master
+ end;
+ let mw = Message.create tl ~text ~padx:20 ~pady:10
+ ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W
+ and fw = Frame.create tl
+ and sync = Textvariable.create ~on:tl ()
+ and r = ref (`Cancel : [`Yes|`No|`Cancel]) in
+ let accept = Button.create fw
+ ~text:(if no || cancel then "Yes" else "Dismiss")
+ ~command:(fun () -> r := `Yes; destroy tl)
+ and refuse = Button.create fw ~text:"No"
+ ~command:(fun () -> r := `No; destroy tl)
+ and cancelB = Button.create fw ~text:"Cancel"
+ ~command:(fun () -> r := `Cancel; destroy tl)
+ in
+ bind tl ~events:[`Destroy] ~extend:true
+ ~action:(fun _ -> Textvariable.set sync "1");
+ pack [accept] ~side:`Left ~fill:`X ~expand:true;
+ if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true;
+ if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true;
+ pack [mw] ~side:`Top ~fill:`Both;
+ pack [fw] ~side:`Bottom ~fill:`X ~expand:true;
+ Grab.set tl;
+ Tkwait.variable sync;
+ !r
+
+let info ~title ?master text =
+ ignore (ask ~title ?master ~no:false ~cancel:false text)
diff --git a/browser/jg_message.mli b/browser/jg_message.mli
new file mode 100644
index 0000000..0e123ac
--- /dev/null
+++ b/browser/jg_message.mli
@@ -0,0 +1,33 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val formatted :
+ title:string ->
+ ?on:frame widget ->
+ ?ppf:Format.formatter ->
+ ?width:int ->
+ ?maxheight:int ->
+ ?minheight:int ->
+ unit -> any widget * text widget * (unit -> unit)
+
+val ask :
+ title:string -> ?master:toplevel widget ->
+ ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes]
+
+val info :
+ title:string -> ?master:toplevel widget -> string -> unit
diff --git a/browser/jg_multibox.ml b/browser/jg_multibox.ml
new file mode 100644
index 0000000..39082e3
--- /dev/null
+++ b/browser/jg_multibox.ml
@@ -0,0 +1,185 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+
+let rec gen_list ~f:f ~len =
+ if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1)
+
+let rec make_list ~len ~fill =
+ if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill
+
+(* By column version
+let rec firsts ~len l =
+ if len = 0 then ([],l) else
+ match l with
+ a::l ->
+ let (f,l) = firsts l len:(len - 1) in
+ (a::f,l)
+ | [] ->
+ (l,[])
+
+let rec split ~len = function
+ [] -> []
+ | l ->
+ let (f,r) = firsts l ~len in
+ let ret = split ~len r in
+ f :: ret
+
+let extend l ~len ~fill =
+ if List.length l >= len then l
+ else l @ make_list ~fill len:(len - List.length l)
+*)
+
+(* By row version *)
+
+let rec first l ~len =
+ if len = 0 then [], l else
+ match l with
+ [] -> make_list ~len ~fill:"", []
+ | a::l ->
+ let (l',r) = first ~len:(len - 1) l in a::l',r
+
+let rec split l ~len =
+ if l = [] then make_list ~len ~fill:[] else
+ let (cars,r) = first l ~len in
+ let cdrs = split r ~len in
+ List.map2 cars cdrs ~f:(fun a l -> a::l)
+
+
+open Tk
+
+class c ~cols ~texts ?maxheight ?width parent = object (self)
+ val parent' = coe parent
+ val length = List.length texts
+ val boxes =
+ let height = (List.length texts - 1) / cols + 1 in
+ let height =
+ match maxheight with None -> height
+ | Some max -> min max height
+ in
+ gen_list ~len:cols ~f:
+ begin fun () ->
+ Listbox.create parent ~height ?width
+ ~highlightthickness:0
+ ~borderwidth:1
+ end
+ val mutable current = 0
+ method cols = cols
+ method texts = texts
+ method parent = parent'
+ method boxes = boxes
+ method current = current
+ method recenter ?(aligntop=false) n =
+ current <-
+ if n < 0 then 0 else
+ if n < length then n else length - 1;
+ (* Activate it, to keep consistent with Up/Down.
+ You have to be in Extended or Browse mode *)
+ let box = List.nth boxes (current mod cols)
+ and index = `Num (current / cols) in
+ List.iter boxes ~f:
+ begin fun box ->
+ Listbox.selection_clear box ~first:(`Num 0) ~last:`End;
+ Listbox.selection_anchor box ~index;
+ Listbox.activate box ~index
+ end;
+ Focus.set box;
+ if aligntop then Listbox.yview_index box ~index
+ else Listbox.see box ~index;
+ let (first,last) = Listbox.yview_get box in
+ List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first))
+ method init =
+ let textl = split ~len:cols texts in
+ List.iter2 boxes textl ~f:
+ begin fun box texts ->
+ Jg_bind.enter_focus box;
+ Listbox.insert box ~texts ~index:`End
+ end;
+ pack boxes ~side:`Left ~expand:true ~fill:`Both;
+ self#bind_mouse ~events:[`ButtonPressDetail 1]
+ ~action:(fun _ ~index:n -> self#recenter n; break ());
+ let current_height () =
+ let (top,bottom) = Listbox.yview_get (List.hd boxes) in
+ truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes))
+ +. 0.99)
+ in
+ List.iter
+ [ "Right", (fun n -> n+1);
+ "Left", (fun n -> n-1);
+ "Up", (fun n -> n-cols);
+ "Down", (fun n -> n+cols);
+ "Prior", (fun n -> n - current_height () * cols);
+ "Next", (fun n -> n + current_height () * cols);
+ "Home", (fun _ -> 0);
+ "End", (fun _ -> List.length texts) ]
+ ~f:begin fun (key,f) ->
+ self#bind_kbd ~events:[`KeyPressDetail key]
+ ~action:(fun _ ~index:n -> self#recenter (f n); break ())
+ end;
+ self#recenter 0
+ method bind_mouse ~events ~action =
+ let i = ref 0 in
+ List.iter boxes ~f:
+ begin fun box ->
+ let b = !i in
+ bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY]
+ ~action:(fun ev ->
+ let `Num n = Listbox.nearest box ~y:ev.ev_MouseY
+ in action ev ~index:(n * cols + b));
+ incr i
+ end
+ method bind_kbd ~events ~action =
+ let i = ref 0 in
+ List.iter boxes ~f:
+ begin fun box ->
+ let b = !i in
+ bind box ~events ~breakable:true ~fields:[`Char]
+ ~action:(fun ev ->
+ let `Num n = Listbox.index box ~index:`Active in
+ action ev ~index:(n * cols + b));
+ incr i
+ end
+end
+
+let add_scrollbar (box : c) =
+ let boxes = box#boxes in
+ let sb =
+ Scrollbar.create (box#parent)
+ ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in
+ List.iter boxes
+ ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb));
+ pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y;
+ sb
+
+let add_completion ?action ?wait (box : c) =
+ let comp = new Jg_completion.timed (box#texts) ?wait in
+ box#bind_kbd ~events:[`KeyPress]
+ ~action:(fun ev ~index ->
+ (* consider only keys producing characters. The callback is called
+ * even if you press Shift. *)
+ if ev.ev_Char <> "" then
+ box#recenter (comp#add ev.ev_Char) ~aligntop:true);
+ match action with
+ Some action ->
+ box#bind_kbd ~events:[`KeyPressDetail "space"]
+ ~action:(fun ev ~index -> action (box#current));
+ box#bind_kbd ~events:[`KeyPressDetail "Return"]
+ ~action:(fun ev ~index -> action (box#current));
+ box#bind_mouse ~events:[`ButtonPressDetail 1]
+ ~action:(fun ev ~index ->
+ box#recenter index; action (box#current); break ())
+ | None -> ()
diff --git a/browser/jg_multibox.mli b/browser/jg_multibox.mli
new file mode 100644
index 0000000..bccca50
--- /dev/null
+++ b/browser/jg_multibox.mli
@@ -0,0 +1,35 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+class c :
+ cols:int -> texts:string list ->
+ ?maxheight:int -> ?width:int -> 'a Widget.widget ->
+object
+ method cols : int
+ method texts : string list
+ method parent : Widget.any Widget.widget
+ method boxes : Widget.listbox Widget.widget list
+ method current : int
+ method init : unit
+ method recenter : ?aligntop:bool -> int -> unit
+ method bind_mouse :
+ events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit
+ method bind_kbd :
+ events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit
+end
+
+val add_scrollbar : c -> Widget.scrollbar Widget.widget
+val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit
diff --git a/browser/jg_text.ml b/browser/jg_text.ml
new file mode 100644
index 0000000..76eeb92
--- /dev/null
+++ b/browser/jg_text.ml
@@ -0,0 +1,104 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Jg_tk
+
+let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1)
+
+let tag_and_see tw ~tag ~start ~stop =
+ Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag;
+ Text.tag_add tw ~start ~stop ~tag;
+ try
+ Text.see tw ~index:(`Tagfirst tag, []);
+ Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, [])
+ with Protocol.TkError _ -> ()
+
+let output tw ~buf ~pos ~len =
+ Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len)
+
+let add_scrollbar tw =
+ let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw)
+ in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb
+
+let create_with_scrollbar parent =
+ let frame = Frame.create parent in
+ let tw = Text.create frame in
+ frame, tw, add_scrollbar tw
+
+let goto_tag tw ~tag =
+ let index = (`Tagfirst tag, []) in
+ try Text.see tw ~index;
+ Text.mark_set tw ~index ~mark:"insert"
+ with Protocol.TkError _ -> ()
+
+let search_string tw =
+ let tl = Jg_toplevel.titled "Search" in
+ Wm.transient_set tl ~master:(Winfo.toplevel tw);
+ let fi = Frame.create tl
+ and fd = Frame.create tl
+ and fm = Frame.create tl
+ and buttons = Frame.create tl
+ and direction = Textvariable.create ~on:tl ()
+ and mode = Textvariable.create ~on:tl ()
+ and count = Textvariable.create ~on:tl ()
+ in
+ let label = Label.create fi ~text:"Pattern:"
+ and text = Entry.create fi ~width:20
+ and back = Radiobutton.create fd ~variable:direction
+ ~text:"Backwards" ~value:"backward"
+ and forw = Radiobutton.create fd ~variable:direction
+ ~text:"Forwards" ~value:"forward"
+ and exact = Radiobutton.create fm ~variable:mode
+ ~text:"Exact" ~value:"exact"
+ and nocase = Radiobutton.create fm ~variable:mode
+ ~text:"No case" ~value:"nocase"
+ and regexp = Radiobutton.create fm ~variable:mode
+ ~text:"Regexp" ~value:"regexp"
+ in
+ let search = Button.create buttons ~text:"Search" ~command:
+ begin fun () ->
+ try
+ let pattern = Entry.get text in
+ let dir, ofs = match Textvariable.get direction with
+ "forward" -> `Forwards, 1
+ | "backward" -> `Backwards, -1
+ | _ -> assert false
+ and mode = match Textvariable.get mode with "exact" -> [`Exact]
+ | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> []
+ in
+ let ndx =
+ Text.search tw ~pattern ~switches:([dir;`Count count] @ mode)
+ ~start:(`Mark "insert", [`Char ofs])
+ in
+ tag_and_see tw ~tag:"sel" ~start:(ndx,[])
+ ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))])
+ with Invalid_argument _ -> ()
+ end
+ and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
+
+ Focus.set text;
+ Jg_bind.return_invoke text ~button:search;
+ Jg_bind.escape_destroy tl;
+ Textvariable.set direction "forward";
+ Textvariable.set mode "nocase";
+ pack [label] ~side:`Left;
+ pack [text] ~side:`Right ~fill:`X ~expand:true;
+ pack [back; forw] ~side:`Left;
+ pack [exact; nocase; regexp] ~side:`Left;
+ pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
+ pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X
diff --git a/browser/jg_text.mli b/browser/jg_text.mli
new file mode 100644
index 0000000..44cba02
--- /dev/null
+++ b/browser/jg_text.mli
@@ -0,0 +1,28 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val get_all : text widget -> string
+val tag_and_see :
+ text widget ->
+ tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit
+val output : text widget -> buf:string -> pos:int -> len:int -> unit
+val add_scrollbar : text widget -> scrollbar widget
+val create_with_scrollbar :
+ 'a widget -> frame widget * text widget * scrollbar widget
+val goto_tag : text widget -> tag:string -> unit
+val search_string : text widget -> unit
diff --git a/browser/jg_tk.ml b/browser/jg_tk.ml
new file mode 100644
index 0000000..16106ee
--- /dev/null
+++ b/browser/jg_tk.ml
@@ -0,0 +1,24 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi
+and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi
+let tstart : textIndex = `Linechar (1,0), []
+and tend : textIndex = `End, []
+
+let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin"
diff --git a/browser/jg_toplevel.ml b/browser/jg_toplevel.ml
new file mode 100644
index 0000000..d77845d
--- /dev/null
+++ b/browser/jg_toplevel.ml
@@ -0,0 +1,25 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Tk
+
+let titled ?iconname title =
+ let iconname = match iconname with None -> title | Some s -> s in
+ let tl = Toplevel.create Widget.default_toplevel in
+ Wm.title_set tl title;
+ Wm.iconname_set tl iconname;
+ Wm.group_set tl ~leader: Widget.default_toplevel;
+ tl
diff --git a/browser/jglib.mllib b/browser/jglib.mllib
new file mode 100644
index 0000000..5c254ff
--- /dev/null
+++ b/browser/jglib.mllib
@@ -0,0 +1,13 @@
+Jg_tk
+Jg_config
+Jg_bind
+Jg_completion
+Jg_box
+Jg_button
+Jg_toplevel
+Jg_text
+Jg_message
+Jg_menu
+Jg_entry
+Jg_multibox
+Jg_memo
diff --git a/browser/lexical.ml b/browser/lexical.ml
new file mode 100644
index 0000000..a423edc
--- /dev/null
+++ b/browser/lexical.ml
@@ -0,0 +1,145 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Jg_tk
+open Parser
+
+let tags =
+ ["control"; "define"; "structure"; "char";
+ "infix"; "label"; "uident"]
+and colors =
+ ["blue"; "forestgreen"; "purple"; "gray40";
+ "indianred4"; "saddlebrown"; "midnightblue"]
+
+let init_tags tw =
+ List.iter2 tags colors ~f:
+ begin fun tag col ->
+ Text.tag_configure tw ~tag ~foreground:(`Color col)
+ end;
+ Text.tag_configure tw ~tag:"error" ~foreground:`Red;
+ Text.tag_configure tw ~tag:"error" ~relief:`Raised;
+ Text.tag_raise tw ~tag:"error"
+
+let tag ?(start=tstart) ?(stop=tend) tw =
+ let tpos c = (Text.index tw ~index:start, [`Char c]) in
+ let text = Text.get tw ~start ~stop in
+ let buffer = Lexing.from_string text in
+ Location.init buffer "";
+ Location.input_name := "";
+ List.iter tags
+ ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag);
+ let last = ref (EOF, 0, 0) in
+ try
+ while true do
+ let token = Lexer.token buffer
+ and start = Lexing.lexeme_start buffer
+ and stop = Lexing.lexeme_end buffer in
+ let tag =
+ match token with
+ AMPERAMPER
+ | AMPERSAND
+ | BARBAR
+ | DO | DONE
+ | DOWNTO
+ | ELSE
+ | FOR
+ | IF
+ | LAZY
+ | MATCH
+ | OR
+ | THEN
+ | TO
+ | TRY
+ | WHEN
+ | WHILE
+ | WITH
+ -> "control"
+ | AND
+ | AS
+ | BAR
+ | CLASS
+ | CONSTRAINT
+ | EXCEPTION
+ | EXTERNAL
+ | FUN
+ | FUNCTION
+ | FUNCTOR
+ | IN
+ | INHERIT
+ | INITIALIZER
+ | LET
+ | METHOD
+ | MODULE
+ | MUTABLE
+ | NEW
+ | OF
+ | PRIVATE
+ | REC
+ | TYPE
+ | VAL
+ | VIRTUAL
+ -> "define"
+ | BEGIN
+ | END
+ | INCLUDE
+ | OBJECT
+ | OPEN
+ | SIG
+ | STRUCT
+ -> "structure"
+ | CHAR _
+ | STRING _
+ -> "char"
+ | BACKQUOTE
+ | INFIXOP1 _
+ | INFIXOP2 _
+ | INFIXOP3 _
+ | INFIXOP4 _
+ | PREFIXOP _
+ | HASH
+ -> "infix"
+ | LABEL _
+ | OPTLABEL _
+ | QUESTION
+ | TILDE
+ -> "label"
+ | UIDENT _ -> "uident"
+ | LIDENT _ ->
+ begin match !last with
+ (QUESTION | TILDE), _, _ -> "label"
+ | _ -> ""
+ end
+ | COLON ->
+ begin match !last with
+ LIDENT _, lstart, lstop ->
+ if lstop = start then
+ Text.tag_add tw ~tag:"label"
+ ~start:(tpos lstart) ~stop:(tpos stop);
+ ""
+ | _ -> ""
+ end
+ | EOF -> raise End_of_file
+ | _ -> ""
+ in
+ if tag <> "" then
+ Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop);
+ last := (token, start, stop)
+ done
+ with
+ End_of_file -> ()
+ | Lexer.Error (err, loc) -> ()
diff --git a/browser/lexical.mli b/browser/lexical.mli
new file mode 100644
index 0000000..52d09e3
--- /dev/null
+++ b/browser/lexical.mli
@@ -0,0 +1,20 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val init_tags : text widget -> unit
+val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit
diff --git a/browser/list2.ml b/browser/list2.ml
new file mode 100644
index 0000000..4439e74
--- /dev/null
+++ b/browser/list2.ml
@@ -0,0 +1,23 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+
+let exclude x l = List.filter l ~f:((<>) x)
+
+let rec flat_map ~f = function
+ [] -> []
+ | x :: l -> f x @ flat_map ~f l
diff --git a/browser/main.ml b/browser/main.ml
new file mode 100644
index 0000000..2346a2f
--- /dev/null
+++ b/browser/main.ml
@@ -0,0 +1,135 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+module Unix = UnixLabels
+open Tk
+
+let fatal_error text =
+ let top = openTk ~clas:"OCamlBrowser" () in
+ let mw = Message.create top ~text ~padx:20 ~pady:10
+ ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W
+ and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in
+ pack [mw] ~side:`Top ~fill:`Both;
+ pack [b] ~side:`Bottom;
+ mainLoop ();
+ exit 0
+
+let rec get_incr key = function
+ [] -> raise Not_found
+ | (k, c, d) :: rem ->
+ if k = key then
+ match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true
+ else get_incr key rem
+
+let check ~spec argv =
+ let i = ref 1 in
+ while !i < Array.length argv do
+ try
+ let a = get_incr argv.(!i) spec in
+ incr i; if a then incr i
+ with Not_found ->
+ i := Array.length argv + 1
+ done;
+ !i = Array.length argv
+
+open Printf
+
+let print_version () =
+ printf "The OCaml browser, version %s\n" Sys.ocaml_version;
+ exit 0;
+;;
+
+let print_version_num () =
+ printf "%s\n" Sys.ocaml_version;
+ exit 0;
+;;
+
+let usage ~spec errmsg =
+ let b = Buffer.create 1024 in
+ bprintf b "%s\n" errmsg;
+ List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec;
+ Buffer.contents b
+
+let _ =
+ let is_win32 = Sys.os_type = "Win32" in
+ if is_win32 then
+ Format.pp_set_formatter_output_functions Format.err_formatter
+ (fun _ _ _ -> ()) (fun _ -> ());
+
+ let path = ref [] in
+ let st = ref true in
+ let spec =
+ [ "-I", Arg.String (fun s -> path := s :: !path),
+ " Add to the list of include directories";
+ "-labels", Arg.Clear Clflags.classic, " ";
+ "-nolabels", Arg.Set Clflags.classic,
+ " Ignore non-optional labels in types";
+ "-oldui", Arg.Clear st, " Revert back to old UI";
+ "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s),
+ " Pipe sources through preprocessor ";
+ "-rectypes", Arg.Set Clflags.recursive_types,
+ " Allow arbitrary recursive types";
+ "-safe-string", Arg.Clear Clflags.unsafe_string,
+ " Make strings immutable";
+ "-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types";
+ "-version", Arg.Unit print_version,
+ " Print version and exit";
+ "-vnum", Arg.Unit print_version_num, " Print version number and exit";
+ "-w", Arg.String (fun s -> Shell.warnings := s),
+ " Enable or disable warnings according to "; ]
+ and errmsg = "Command line: ocamlbrowser " in
+ if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg);
+ Arg.parse spec
+ (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
+ errmsg;
+ Config.load_path :=
+ Sys.getcwd ()
+ :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
+ @ [Config.standard_library];
+ Warnings.parse_options false !Shell.warnings;
+ Unix.putenv "TERM" "noterminal";
+ begin
+ try Searchid.start_env := Compmisc.initial_env ()
+ with _ ->
+ fatal_error
+ (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'"
+ "Couldn't initialize environment."
+ (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB")
+ "points to the OCaml library."
+ Config.standard_library)
+ end;
+
+ Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env);
+ Searchpos.editor_ref := Editor.f;
+
+ let top = openTk ~clas:"OCamlBrowser" () in
+ Jg_config.init ();
+
+ (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *)
+ at_exit Shell.kill_all;
+
+
+ if !st then Viewer.st_viewer ~on:top ()
+ else Viewer.f ~on:top ();
+
+ while true do
+ try
+ if is_win32 then mainLoop ()
+ else Printexc.print mainLoop ()
+ with Protocol.TkError _ ->
+ if not is_win32 then flush stderr
+ done
diff --git a/browser/mytypes.mli b/browser/mytypes.mli
new file mode 100644
index 0000000..217fc11
--- /dev/null
+++ b/browser/mytypes.mli
@@ -0,0 +1,29 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+type edit_window =
+ { mutable name: string;
+ tw: text widget;
+ frame: frame widget;
+ modified: Textvariable.textVariable;
+ mutable shell: (string * Shell.shell) option;
+ mutable structure: Typedtree.structure_item list;
+ mutable type_info: Stypes.annotation list;
+ mutable signature: Types.signature;
+ mutable psignature: Parsetree.signature;
+ number: string }
diff --git a/browser/searchid.ml b/browser/searchid.ml
new file mode 100644
index 0000000..5d7aabe
--- /dev/null
+++ b/browser/searchid.ml
@@ -0,0 +1,568 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Asttypes
+open StdLabels
+open Location
+open Longident
+open Path
+open Types
+open Typedtree
+open Env
+open Btype
+open Ctype
+
+(* only empty here, but replaced by Pervasives later *)
+let start_env = ref Env.empty
+let module_list = ref []
+
+type pkind =
+ Pvalue
+ | Ptype
+ | Plabel
+ | Pconstructor
+ | Pmodule
+ | Pmodtype
+ | Pclass
+ | Pcltype
+
+let string_of_kind = function
+ Pvalue -> "v"
+ | Ptype -> "t"
+ | Plabel -> "l"
+ | Pconstructor -> "cn"
+ | Pmodule -> "m"
+ | Pmodtype -> "s"
+ | Pclass -> "c"
+ | Pcltype -> "ct"
+
+let rec longident_of_path = function
+ Pident id -> Lident (Ident.name id)
+ | Pdot (path, s, _) -> Ldot (longident_of_path path, s)
+ | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2)
+
+let rec remove_prefix lid ~prefix =
+ let rec remove_hd lid ~name =
+ match lid with
+ Ldot (Lident s1, s2) when s1 = name -> Lident s2
+ | Ldot (l, s) -> Ldot (remove_hd ~name l, s)
+ | _ -> raise Not_found
+ in
+ match prefix with
+ [] -> lid
+ | name :: prefix ->
+ try remove_prefix ~prefix (remove_hd ~name lid)
+ with Not_found -> lid
+
+let rec permutations l = match l with
+ [] | [_] -> [l]
+ | [a;b] -> [l; [b;a]]
+ | _ ->
+ let _, perms =
+ List.fold_left l ~init:(l,[]) ~f:
+ begin fun (l, perms) a ->
+ let l = List.tl l in
+ l @ [a],
+ List.map (permutations l) ~f:(fun l -> a :: l) @ perms
+ end
+ in perms
+
+let rec choose n ~card:l =
+ let len = List.length l in
+ if n = len then [l] else
+ if n = 1 then List.map l ~f:(fun x -> [x]) else
+ if n = 0 then [[]] else
+ if n > len then [] else
+ match l with [] -> []
+ | a :: l ->
+ List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l)
+ @ choose n ~card:l
+
+let rec arr p ~card:n =
+ if p = 0 then 1 else n * arr (p-1) ~card:(n-1)
+
+let rec all_args ty =
+ let ty = repr ty in
+ match ty.desc with
+ Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty)
+ | _ -> ([], ty)
+
+let rec equal ~prefix t1 t2 =
+ match (repr t1).desc, (repr t2).desc with
+ Tvar _, Tvar _ -> true
+ | Tvariant row1, Tvariant row2 ->
+ let row1 = row_repr row1 and row2 = row_repr row2 in
+ let fields1 = filter_row_fields false row1.row_fields
+ and fields2 = filter_row_fields false row1.row_fields
+ in
+ let r1, r2, pairs = merge_row_fields fields1 fields2 in
+ row1.row_closed = row2.row_closed && r1 = [] && r2 = [] &&
+ List.for_all pairs ~f:
+ begin fun (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ Rpresent None, Rpresent None -> true
+ | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix
+ | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+ c1 = c2 && List.length tl1 = List.length tl2 &&
+ List.for_all2 tl1 tl2 ~f:(equal ~prefix)
+ | _ -> false
+ end
+ | Tarrow _, Tarrow _ ->
+ let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
+ equal t1 t2 ~prefix &&
+ List.length l1 = List.length l2 &&
+ List.exists (permutations l1) ~f:
+ begin fun l1 ->
+ List.for_all2 l1 l2 ~f:
+ begin fun (p1,t1) (p2,t2) ->
+ (p1 = Nolabel || p1 = p2) && equal t1 t2 ~prefix
+ end
+ end
+ | Ttuple l1, Ttuple l2 ->
+ List.length l1 = List.length l2 &&
+ List.for_all2 l1 l2 ~f:(equal ~prefix)
+ | Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
+ remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
+ && List.length l1 = List.length l2
+ && List.for_all2 l1 l2 ~f:(equal ~prefix)
+ | _ -> false
+
+let get_options = List.filter ~f:Btype.is_optional
+
+let rec included ~prefix t1 t2 =
+ match (repr t1).desc, (repr t2).desc with
+ Tvar _, _ -> true
+ | Tvariant row1, Tvariant row2 ->
+ let row1 = row_repr row1 and row2 = row_repr row2 in
+ let fields1 = filter_row_fields false row1.row_fields
+ and fields2 = filter_row_fields false row2.row_fields
+ in
+ let r1, r2, pairs = merge_row_fields fields1 fields2 in
+ r1 = [] &&
+ List.for_all pairs ~f:
+ begin fun (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ Rpresent None, Rpresent None -> true
+ | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix
+ | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+ c1 = c2 && List.length tl1 = List.length tl2 &&
+ List.for_all2 tl1 tl2 ~f:(included ~prefix)
+ | _ -> false
+ end
+ | Tarrow _, Tarrow _ ->
+ let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
+ included t1 t2 ~prefix &&
+ let len1 = List.length l1 and len2 = List.length l2 in
+ let l2 = if arr len1 ~card:len2 < 100 then l2 else
+ let ll1 = get_options (fst (List.split l1)) in
+ List.filter l2
+ ~f:(fun (l,_) -> not (is_optional l) || List.mem l ll1)
+ in
+ len1 <= len2 &&
+ List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
+ begin fun l2 ->
+ List.for_all2 l1 l2 ~f:
+ begin fun (p1,t1) (p2,t2) ->
+ (p1 = Nolabel || p1 = p2) && included t1 t2 ~prefix
+ end
+ end
+ | Ttuple l1, Ttuple l2 ->
+ let len1 = List.length l1 in
+ len1 <= List.length l2 &&
+ List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
+ begin fun l2 ->
+ List.for_all2 l1 l2 ~f:(included ~prefix)
+ end
+ | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix
+ | Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
+ remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
+ && List.length l1 = List.length l2
+ && List.for_all2 l1 l2 ~f:(included ~prefix)
+ | _ -> false
+
+let mklid = function
+ [] -> raise (Invalid_argument "Searchid.mklid")
+ | x :: l ->
+ List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x))
+
+let mkpath = function
+ [] -> raise (Invalid_argument "Searchid.mklid")
+ | x :: l ->
+ List.fold_left l ~init:(Pident (Ident.create x))
+ ~f:(fun acc x -> Pdot (acc, x, 0))
+
+let get_fields ~prefix ~sign self =
+ (*let env = open_signature Fresh (mkpath prefix) sign !start_env in*)
+ let env = add_signature sign !start_env in
+ match (expand_head env self).desc with
+ Tobject (ty_obj, _) ->
+ let l,_ = flatten_fields ty_obj in l
+ | _ -> []
+
+let rec search_type_in_signature t ~sign ~prefix ~mode =
+ let matches = match mode with
+ `Included -> included t ~prefix
+ | `Exact -> equal t ~prefix
+ and lid_of_id id = mklid (prefix @ [Ident.name id]) in
+ let constructor_matches = function
+ Types.Cstr_tuple l -> List.exists l ~f:matches
+ | Cstr_record l -> List.exists l ~f:(fun d -> matches d.Types.ld_type)
+ in
+ List2.flat_map sign ~f:
+ begin fun item -> match item with
+ Sig_value (id, vd) ->
+ if matches vd.val_type then [lid_of_id id, Pvalue] else []
+ | Sig_type (id, td, _) ->
+ if
+ matches (newconstr (Pident id) td.type_params) ||
+ begin match td.type_manifest with
+ None -> false
+ | Some t -> matches t
+ end ||
+ begin match td.type_kind with
+ Type_abstract
+ | Type_open -> false
+ | Type_variant l ->
+ List.exists l ~f:
+ begin fun {Types.cd_args=args; cd_res=r} ->
+ constructor_matches args ||
+ match r with None -> false | Some x -> matches x
+ end
+ | Type_record(l, rep) ->
+ List.exists l ~f:(fun {Types.ld_type=t} -> matches t)
+ end
+ then [lid_of_id id, Ptype] else []
+ | Sig_typext (id, l, _) ->
+ if constructor_matches l.ext_args
+ then [lid_of_id id, Pconstructor]
+ else []
+ | Sig_module (id, {md_type=Mty_signature sign}, _) ->
+ search_type_in_signature t ~sign ~mode
+ ~prefix:(prefix @ [Ident.name id])
+ | Sig_module _ -> []
+ | Sig_modtype _ -> []
+ | Sig_class (id, cl, _) ->
+ let self = self_type cl.cty_type in
+ if matches self
+ || (match cl.cty_new with None -> false | Some ty -> matches ty)
+ (* || List.exists (get_fields ~prefix ~sign self)
+ ~f:(fun (_,_,ty_field) -> matches ty_field) *)
+ then [lid_of_id id, Pclass] else []
+ | Sig_class_type (id, cl, _) ->
+ let self = self_type cl.clty_type in
+ if matches self
+ (* || List.exists (get_fields ~prefix ~sign self)
+ ~f:(fun (_,_,ty_field) -> matches ty_field) *)
+ then [lid_of_id id, Pclass] else []
+ end
+
+let search_all_types t ~mode =
+ let tl = match mode, t.desc with
+ `Exact, _ -> [t]
+ | `Included, Tarrow _ -> [t]
+ | `Included, _ ->
+ [t; newty(Tarrow(Nolabel,t,newvar(),Cok)); newty(Tarrow(Nolabel,newvar(),t,Cok))]
+ in List2.flat_map !module_list ~f:
+ begin fun modname ->
+ let mlid = Lident modname in
+ try match find_module (lookup_module ~load:true mlid !start_env) !start_env
+ with {md_type=Mty_signature sign} ->
+ List2.flat_map tl
+ ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode)
+ | _ -> []
+ with Not_found | Env.Error _ -> []
+ end
+
+exception Error of int * int
+
+let search_string_type text ~mode =
+ try
+ let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in
+ let sign =
+ try (Typemod.transl_signature !start_env sexp).sig_type with _ ->
+ let env = List.fold_left !module_list ~init:!start_env ~f:
+ begin fun acc m ->
+ try open_pers_signature m acc with Env.Error _ -> acc
+ end in
+ try (Typemod.transl_signature env sexp).sig_type
+ with Env.Error err -> []
+ | Typemod.Error (l,_,_) ->
+ let start_c = l.loc_start.Lexing.pos_cnum in
+ let end_c = l.loc_end.Lexing.pos_cnum in
+ raise (Error (start_c - 8, end_c - 8))
+ | Typetexp.Error (l,_,_) ->
+ let start_c = l.loc_start.Lexing.pos_cnum in
+ let end_c = l.loc_end.Lexing.pos_cnum in
+ raise (Error (start_c - 8, end_c - 8))
+ in match sign with
+ [ Sig_value (_, vd) ] ->
+ search_all_types vd.val_type ~mode
+ | _ -> []
+ with
+ Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) ->
+ let start_c = l.loc_start.Lexing.pos_cnum in
+ let end_c = l.loc_end.Lexing.pos_cnum in
+ raise (Error (start_c - 8, end_c - 8))
+ | Syntaxerr.Error(Syntaxerr.Other l) ->
+ let start_c = l.loc_start.Lexing.pos_cnum in
+ let end_c = l.loc_end.Lexing.pos_cnum in
+ raise (Error (start_c - 8, end_c - 8))
+ | Lexer.Error (_, l) ->
+ let start_c = l.loc_start.Lexing.pos_cnum in
+ let end_c = l.loc_end.Lexing.pos_cnum in
+ raise (Error (start_c - 8, end_c - 8))
+
+let longident_of_string text =
+ let exploded = ref [] and l = ref 0 in
+ for i = 0 to String.length text - 2 do
+ if text.[i] ='.' then
+ (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1)
+ done;
+ let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in
+ let rec mklid = function
+ [s] -> Lident s
+ | s :: l -> Ldot (mklid l, s)
+ | [] -> assert false in
+ sym, fun l -> mklid (sym :: !exploded @ l)
+
+
+let explode s =
+ let l = ref [] in
+ for i = String.length s - 1 downto 0 do
+ l := s.[i] :: !l
+ done; !l
+
+let rec check_match ~pattern s =
+ match pattern, s with
+ [], [] -> true
+ | '*'::l, l' -> check_match ~pattern:l l'
+ || check_match ~pattern:('?'::'*'::l) l'
+ | '?'::l, _::l' -> check_match ~pattern:l l'
+ | x::l, y::l' when x == y -> check_match ~pattern:l l'
+ | _ -> false
+
+let search_pattern_symbol text =
+ if text = "" then [] else
+ let pattern = explode text in
+ let check i = check_match ~pattern (explode (Ident.name i)) in
+ let l = List.map !module_list ~f:
+ begin fun modname -> Lident modname,
+ try match
+ find_module (lookup_module ~load:true (Lident modname) !start_env)
+ !start_env
+ with {md_type=Mty_signature sign} ->
+ List2.flat_map sign ~f:
+ begin function
+ Sig_value (i, _) when check i -> [i, Pvalue]
+ | Sig_type (i, _, _) when check i -> [i, Ptype]
+ | Sig_typext (i, _, _) when check i -> [i, Pconstructor]
+ | Sig_module (i, _, _) when check i -> [i, Pmodule]
+ | Sig_modtype (i, _) when check i -> [i, Pmodtype]
+ | Sig_class (i, cl, _) when check i
+ || List.exists
+ (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type))
+ ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
+ -> [i, Pclass]
+ | Sig_class_type (i, cl, _) when check i
+ || List.exists
+ (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type))
+ ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
+ -> [i, Pcltype]
+ | _ -> []
+ end
+ | _ -> []
+ with Env.Error _ -> []
+ end
+ in
+ List2.flat_map l ~f:
+ begin fun (m, l) ->
+ List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p)
+ end
+
+(*
+let is_pattern s =
+ try for i = 0 to String.length s -1 do
+ if s.[i] = '?' || s.[i] = '*' then raise Exit
+ done; false
+ with Exit -> true
+*)
+
+let search_string_symbol text =
+ if text = "" then [] else
+ let lid = snd (longident_of_string text) [] in
+ let try_lookup f k =
+ try let _ = f lid !start_env in [lid, k]
+ with Not_found | Env.Error _ -> []
+ in
+ try_lookup lookup_constructor Pconstructor @
+ try_lookup (lookup_module ~load:true) Pmodule @
+ try_lookup lookup_modtype Pmodtype @
+ try_lookup lookup_value Pvalue @
+ try_lookup lookup_type Ptype @
+ try_lookup lookup_label Plabel @
+ try_lookup lookup_class Pclass
+
+open Parsetree
+
+let rec bound_variables pat =
+ match pat.ppat_desc with
+ Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _
+ | Ppat_interval _ -> []
+ | Ppat_var s -> [s.txt]
+ | Ppat_alias (pat,s) -> s.txt :: bound_variables pat
+ | Ppat_tuple l -> List2.flat_map l ~f:bound_variables
+ | Ppat_construct (_,None) -> []
+ | Ppat_construct (_,Some pat) -> bound_variables pat
+ | Ppat_variant (_,None) -> []
+ | Ppat_variant (_,Some pat) -> bound_variables pat
+ | Ppat_record (l, _) ->
+ List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat)
+ | Ppat_array l ->
+ List2.flat_map l ~f:bound_variables
+ | Ppat_or (pat1,pat2) ->
+ bound_variables pat1 @ bound_variables pat2
+ | Ppat_constraint (pat,_) -> bound_variables pat
+ | Ppat_lazy pat -> bound_variables pat
+ | Ppat_extension _ -> []
+ | Ppat_exception pat -> bound_variables pat
+ | Ppat_open (_, pat) -> bound_variables pat
+
+let search_structure str ~name ~kind ~prefix =
+ let loc = ref 0 in
+ let rec search_module str ~prefix =
+ match prefix with [] -> str
+ | modu::prefix ->
+ let str =
+ List.fold_left ~init:[] str ~f:
+ begin fun acc item ->
+ match item.pstr_desc with
+ Pstr_module x when x.pmb_name.txt = modu ->
+ loc := x.pmb_expr.pmod_loc.loc_start.Lexing.pos_cnum;
+ begin match x.pmb_expr.pmod_desc with
+ Pmod_structure str -> str
+ | _ -> []
+ end
+ | _ -> acc
+ end
+ in search_module str ~prefix
+ in
+ List.iter (search_module str ~prefix) ~f:
+ begin fun item ->
+ if match item.pstr_desc with
+ Pstr_value (_, l) when kind = Pvalue ->
+ List.iter l ~f:
+ begin fun {pvb_pat=pat} ->
+ if List.mem name (bound_variables pat)
+ then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Pstr_primitive vd when kind = Pvalue -> name = vd.pval_name.txt
+ | Pstr_type (_, l) when kind = Ptype ->
+ List.iter l ~f:
+ begin fun td ->
+ if td.ptype_name.txt = name
+ then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Pstr_typext l when kind = Ptype ->
+ List.iter l.ptyext_constructors ~f:
+ begin fun td ->
+ if td.pext_name.txt = name
+ then loc := td.pext_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Pstr_exception pcd when kind = Pconstructor -> name = pcd.pext_name.txt
+ | Pstr_module x when kind = Pmodule -> name = x.pmb_name.txt
+ | Pstr_modtype x when kind = Pmodtype -> name = x.pmtd_name.txt
+ | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
+ List.iter l ~f:
+ begin fun c ->
+ if c.pci_name.txt = name
+ then loc := c.pci_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Pstr_class_type l when kind = Pcltype || kind = Ptype ->
+ List.iter l ~f:
+ begin fun c ->
+ if c.pci_name.txt = name
+ then loc := c.pci_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | _ -> false
+ then loc := item.pstr_loc.loc_start.Lexing.pos_cnum
+ end;
+ !loc
+
+let search_signature sign ~name ~kind ~prefix =
+ ignore (name = "");
+ ignore (prefix = [""]);
+ let loc = ref 0 in
+ let rec search_module_type sign ~prefix =
+ match prefix with [] -> sign
+ | modu::prefix ->
+ let sign =
+ List.fold_left ~init:[] sign ~f:
+ begin fun acc item ->
+ match item.psig_desc with
+ Psig_module pmd when pmd.pmd_name.txt = modu ->
+ loc := pmd.pmd_type.pmty_loc.loc_start.Lexing.pos_cnum;
+ begin match pmd.pmd_type.pmty_desc with
+ Pmty_signature sign -> sign
+ | _ -> []
+ end
+ | _ -> acc
+ end
+ in search_module_type sign ~prefix
+ in
+ List.iter (search_module_type sign ~prefix) ~f:
+ begin fun item ->
+ if match item.psig_desc with
+ Psig_value vd when kind = Pvalue -> name = vd.pval_name.txt
+ | Psig_type (_, l) when kind = Ptype ->
+ List.iter l ~f:
+ begin fun td ->
+ if td.ptype_name.txt = name
+ then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Psig_typext l when kind = Pconstructor ->
+ List.iter l.ptyext_constructors ~f:
+ begin fun td ->
+ if td.pext_name.txt = name
+ then loc := td.pext_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Psig_exception pcd when kind = Pconstructor -> name = pcd.pext_name.txt
+ | Psig_module pmd when kind = Pmodule -> name = pmd.pmd_name.txt
+ | Psig_modtype pmtd when kind = Pmodtype -> name = pmtd.pmtd_name.txt
+ | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
+ List.iter l ~f:
+ begin fun c ->
+ if c.pci_name.txt = name
+ then loc := c.pci_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | Psig_class_type l when kind = Ptype || kind = Pcltype ->
+ List.iter l ~f:
+ begin fun c ->
+ if c.pci_name.txt = name
+ then loc := c.pci_loc.loc_start.Lexing.pos_cnum
+ end;
+ false
+ | _ -> false
+ then loc := item.psig_loc.loc_start.Lexing.pos_cnum
+ end;
+ !loc
diff --git a/browser/searchid.mli b/browser/searchid.mli
new file mode 100644
index 0000000..9e0c8ad
--- /dev/null
+++ b/browser/searchid.mli
@@ -0,0 +1,45 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+val start_env : Env.t ref
+val module_list : string list ref
+val longident_of_path : Path.t ->Longident.t
+
+type pkind =
+ Pvalue
+ | Ptype
+ | Plabel
+ | Pconstructor
+ | Pmodule
+ | Pmodtype
+ | Pclass
+ | Pcltype
+
+val string_of_kind : pkind -> string
+
+exception Error of int * int
+
+val search_string_type :
+ string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list
+val search_pattern_symbol : string -> (Longident.t * pkind) list
+val search_string_symbol : string -> (Longident.t * pkind) list
+
+val search_structure :
+ Parsetree.structure ->
+ name:string -> kind:pkind -> prefix:string list -> int
+val search_signature :
+ Parsetree.signature ->
+ name:string -> kind:pkind -> prefix:string list -> int
diff --git a/browser/searchpos.ml b/browser/searchpos.ml
new file mode 100644
index 0000000..125c833
--- /dev/null
+++ b/browser/searchpos.ml
@@ -0,0 +1,923 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Asttypes
+open StdLabels
+open Support
+open Tk
+open Jg_tk
+open Parsetree
+open Typedtree
+open Types
+open Location
+open Longident
+open Path
+open Env
+open Searchid
+
+(* auxiliary functions *)
+
+let (~!) = Jg_memo.fast ~f:Str.regexp
+
+let lines_to_chars n ~text:s =
+ let l = String.length s in
+ let rec ltc n ~pos =
+ if n = 1 || pos >= l then pos else
+ if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1)
+ in ltc n ~pos:0
+
+let in_loc loc ~pos =
+ loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum
+ && pos < loc.loc_end.Lexing.pos_cnum
+
+let le_loc loc1 loc2 =
+ loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum
+ && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum
+
+let add_found ~found sol ~env ~loc =
+ if loc.loc_ghost then () else
+ if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then ()
+ else found := (sol, env, loc) ::
+ List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc))
+
+let observe ~ref ?init f x =
+ let old = !ref in
+ begin match init with None -> () | Some x -> ref := x end;
+ try (f x : unit); let v = !ref in ref := old; v
+ with exn -> ref := old; raise exn
+
+let rec string_of_longident = function
+ Lident s -> s
+ | Ldot (id,s) -> string_of_longident id ^ "." ^ s
+ | Lapply (id1, id2) ->
+ string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")"
+
+let string_of_path p = string_of_longident (Searchid.longident_of_path p)
+
+let parent_path = function
+ Pdot (path, _, _) -> Some path
+ | Pident _ | Papply _ -> None
+
+let ident_of_path ~default = function
+ Pident i -> i
+ | Pdot (_, s, _) -> Ident.create s
+ | Papply _ -> Ident.create default
+
+let rec head_id = function
+ Pident id -> id
+ | Pdot (path,_,_) -> head_id path
+ | Papply (path,_) -> head_id path (* wrong, but ... *)
+
+let rec list_of_path = function
+ Pident id -> [Ident.name id]
+ | Pdot (path, s, _) -> list_of_path path @ [s]
+ | Papply (path, _) -> list_of_path path (* wrong, but ... *)
+
+(* a simple wrapper *)
+
+class buffer ~size = object
+ val buffer = Buffer.create size
+ method out buf = Buffer.add_substring buffer buf
+ method get = Buffer.contents buffer
+end
+
+(* Search in a signature *)
+
+type skind = [`Type|`Class|`Module|`Modtype]
+
+let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list)
+let add_found_sig = add_found ~found:found_sig
+
+let rec search_pos_type t ~pos ~env =
+ if in_loc ~pos t.ptyp_loc then
+ begin match t.ptyp_desc with
+ Ptyp_any
+ | Ptyp_var _ -> ()
+ | Ptyp_variant(tl, _, _) ->
+ List.iter tl ~f:
+ begin function
+ Rtag (_,_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)
+ | Rinherit st -> search_pos_type ~pos ~env st
+ end
+ | Ptyp_arrow (_, t1, t2) ->
+ search_pos_type t1 ~pos ~env;
+ search_pos_type t2 ~pos ~env
+ | Ptyp_tuple tl ->
+ List.iter tl ~f:(search_pos_type ~pos ~env)
+ | Ptyp_constr (lid, tl) ->
+ List.iter tl ~f:(search_pos_type ~pos ~env);
+ add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc
+ | Ptyp_object (fl, _) ->
+ List.iter fl ~f:
+ (function Oinherit ty | Otag (_, _, ty) -> search_pos_type ty ~pos ~env)
+ | Ptyp_class (lid, tl) ->
+ List.iter tl ~f:(search_pos_type ~pos ~env);
+ add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc
+ | Ptyp_alias (t, _)
+ | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t
+ | Ptyp_package (_, stl) ->
+ List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env)
+ | Ptyp_extension _ -> ()
+ end
+
+let rec search_pos_class_type cl ~pos ~env =
+ if in_loc cl.pcty_loc ~pos then
+ begin match cl.pcty_desc with
+ Pcty_constr (lid, _) ->
+ add_found_sig (`Class, lid.txt) ~env ~loc:cl.pcty_loc
+ | Pcty_signature cl ->
+ List.iter cl.pcsig_fields ~f: (fun fl ->
+ begin match fl.pctf_desc with
+ Pctf_inherit cty -> search_pos_class_type cty ~pos ~env
+ | Pctf_val (_, _, _, ty)
+ | Pctf_method (_, _, _, ty) ->
+ if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env
+ | Pctf_constraint (ty1, ty2) ->
+ if in_loc fl.pctf_loc ~pos then begin
+ search_pos_type ty1 ~pos ~env;
+ search_pos_type ty2 ~pos ~env
+ end
+ | Pctf_attribute _
+ | Pctf_extension _ -> ()
+ end)
+ | Pcty_arrow (_, ty, cty) ->
+ search_pos_type ty ~pos ~env;
+ search_pos_class_type cty ~pos ~env
+ | Pcty_extension _ -> ()
+ | Pcty_open (_, _, cty) ->
+ search_pos_class_type cty ~pos ~env
+ end
+
+let search_pos_arguments ~pos ~env = function
+ Pcstr_tuple l -> List.iter l ~f:(search_pos_type ~pos ~env)
+ | Pcstr_record l -> List.iter l ~f:(fun ld -> search_pos_type ld.pld_type ~pos ~env)
+
+let search_pos_constructor pcd ~pos ~env =
+ if in_loc ~pos pcd.pcd_loc then begin
+ Misc.may (search_pos_type ~pos ~env) pcd.pcd_res;
+ search_pos_arguments ~pos ~env pcd.pcd_args
+ end
+
+let search_pos_type_decl td ~pos ~env =
+ if in_loc ~pos td.ptype_loc then begin
+ begin match td.ptype_manifest with
+ Some t -> search_pos_type t ~pos ~env
+ | None -> ()
+ end;
+ let rec search_tkind = function
+ Ptype_abstract
+ | Ptype_open -> ()
+ | Ptype_variant dl ->
+ List.iter dl ~f:(search_pos_constructor ~pos ~env)
+ | Ptype_record dl ->
+ List.iter dl ~f:(fun pld -> search_pos_type pld.pld_type ~pos ~env) in
+ search_tkind td.ptype_kind;
+ List.iter td.ptype_cstrs ~f:
+ begin fun (t1, t2, _) ->
+ search_pos_type t1 ~pos ~env;
+ search_pos_type t2 ~pos ~env
+ end
+ end
+
+let search_pos_extension ext ~pos ~env =
+ begin match ext.pext_kind with
+ Pext_decl (l, _) -> search_pos_arguments l ~pos ~env
+ | Pext_rebind _ -> ()
+ end
+
+let rec search_pos_signature l ~pos ~env =
+ ignore (
+ List.fold_left l ~init:env ~f:
+ begin fun env pt ->
+ let env = match pt.psig_desc with
+ Psig_open {popen_override=ovf; popen_lid=id} ->
+ let path, mt = Typetexp.find_module env Location.none id.txt in
+ begin match open_signature ovf path env with
+ Some env -> env
+ | None -> env
+ end
+ | sign_item ->
+ try add_signature (Typemod.transl_signature env [pt]).sig_type env
+ with Typemod.Error _ | Typeclass.Error _
+ | Typetexp.Error _ | Typedecl.Error _ -> env
+ in
+ if in_loc ~pos pt.psig_loc then
+ begin match pt.psig_desc with
+ Psig_value desc -> search_pos_type desc.pval_type ~pos ~env
+ | Psig_type (_, l) ->
+ List.iter l ~f:(search_pos_type_decl ~pos ~env)
+ | Psig_typext pty ->
+ List.iter pty.ptyext_constructors
+ ~f:(search_pos_extension ~pos ~env);
+ add_found_sig (`Type, pty.ptyext_path.txt) ~env ~loc:pt.psig_loc
+ | Psig_exception ext ->
+ search_pos_extension ext ~pos ~env;
+ add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc
+ | Psig_module pmd ->
+ search_pos_module pmd.pmd_type ~pos ~env
+ | Psig_recmodule decls ->
+ List.iter decls ~f:(fun pmd -> search_pos_module pmd.pmd_type ~pos ~env)
+ | Psig_modtype {pmtd_type=Some t} ->
+ search_pos_module t ~pos ~env
+ | Psig_modtype _ -> ()
+ | Psig_class l ->
+ List.iter l
+ ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
+ | Psig_class_type l ->
+ List.iter l
+ ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
+ (* The last cases should not happen in generated interfaces *)
+ | Psig_open {popen_lid=lid} ->
+ add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc
+ | Psig_include {pincl_mod=t} -> search_pos_module t ~pos ~env
+ | Psig_attribute _ | Psig_extension _ -> ()
+ end;
+ env
+ end)
+
+and search_pos_module m ~pos ~env =
+ if in_loc m.pmty_loc ~pos then begin
+ begin match m.pmty_desc with
+ Pmty_ident lid -> add_found_sig (`Modtype, lid.txt) ~env ~loc:m.pmty_loc
+ | Pmty_alias lid -> add_found_sig (`Module, lid.txt) ~env ~loc:m.pmty_loc
+ | Pmty_signature sg -> search_pos_signature sg ~pos ~env
+ | Pmty_functor (_ , m1, m2) ->
+ Misc.may (search_pos_module ~pos ~env) m1;
+ search_pos_module m2 ~pos ~env
+ | Pmty_with (m, l) ->
+ search_pos_module m ~pos ~env;
+ List.iter l ~f:
+ begin function
+ Pwith_type (_, t) -> search_pos_type_decl t ~pos ~env
+ | _ -> ()
+ end
+ | Pmty_typeof md ->
+ () (* TODO? *)
+ | Pmty_extension _ -> ()
+ end
+ end
+
+let search_pos_signature l ~pos ~env =
+ observe ~ref:found_sig (search_pos_signature ~pos ~env) l
+
+(* the module display machinery *)
+
+type module_widgets =
+ { mw_frame: Widget.frame Widget.widget;
+ mw_title: Widget.label Widget.widget option;
+ mw_detach: Widget.button Widget.widget;
+ mw_edit: Widget.button Widget.widget;
+ mw_intf: Widget.button Widget.widget }
+
+let shown_modules = Hashtbl.create 17
+let default_frame = ref None
+let set_path = ref (fun _ ~sign -> assert false)
+let filter_modules () =
+ Hashtbl.iter
+ (fun key data ->
+ if not (Winfo.exists data.mw_frame) then
+ Hashtbl.remove shown_modules key)
+ shown_modules
+let add_shown_module path ~widgets =
+ Hashtbl.add shown_modules path widgets
+let find_shown_module path =
+ try
+ filter_modules ();
+ Hashtbl.find shown_modules path
+ with Not_found ->
+ match !default_frame with
+ None -> raise Not_found
+ | Some mw -> mw
+
+let is_shown_module path =
+ !default_frame <> None ||
+ (filter_modules (); Hashtbl.mem shown_modules path)
+
+(* Viewing a signature *)
+
+(* Forward definitions of Viewer.view_defined and Editor.editor *)
+let view_defined_ref = ref (fun lid ~env -> ())
+let editor_ref = ref (fun ?file ?pos ?opendialog () -> ())
+
+let edit_source ~file ~path ~sign =
+ match sign with
+ [item] ->
+ let id, kind =
+ match item with
+ Sig_value (id, _) -> id, Pvalue
+ | Sig_type (id, _, _) -> id, Ptype
+ | Sig_typext (id, _, _) -> id, Pconstructor
+ | Sig_module (id, _, _) -> id, Pmodule
+ | Sig_modtype (id, _) -> id, Pmodtype
+ | Sig_class (id, _, _) -> id, Pclass
+ | Sig_class_type (id, _, _) -> id, Pcltype
+ in
+ let prefix = List.tl (list_of_path path) and name = Ident.name id in
+ let pos =
+ try
+ let chan = open_in file in
+ if Filename.check_suffix file ".ml" then
+ let parsed = Parse.implementation (Lexing.from_channel chan) in
+ close_in chan;
+ Searchid.search_structure parsed ~name ~kind ~prefix
+ else
+ let parsed = Parse.interface (Lexing.from_channel chan) in
+ close_in chan;
+ Searchid.search_signature parsed ~name ~kind ~prefix
+ with _ -> 0
+ in !editor_ref ~file ~pos ()
+ | _ -> !editor_ref ~file ()
+
+(* List of windows to destroy by Close All *)
+let top_widgets = ref []
+
+let dummy_item =
+ Sig_modtype (Ident.create "dummy",
+ {mtd_type=None; mtd_attributes=[]; mtd_loc=Location.none})
+
+let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
+ let env =
+ match path with None -> env
+ | Some path ->
+ match Env.open_signature Fresh path env with None -> env
+ | Some env -> env
+ in
+ let title =
+ match title, path with Some title, _ -> title
+ | None, Some path -> string_of_path path
+ | None, None -> "Signature"
+ in
+ let tl, tw, finish =
+ try match path, !default_frame with
+ None, Some ({mw_title=Some label} as mw) when not detach ->
+ Button.configure mw.mw_detach
+ ~command:(fun () -> view_signature sign ~title ~env ~detach:true);
+ pack [mw.mw_detach] ~side:`Left;
+ Pack.forget [mw.mw_edit; mw.mw_intf];
+ List.iter ~f:destroy (Winfo.children mw.mw_frame);
+ Label.configure label ~text:title;
+ pack [label] ~fill:`X ~side:`Bottom;
+ Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
+ | None, _ -> raise Not_found
+ | Some path, _ ->
+ let mw =
+ try find_shown_module path
+ with Not_found ->
+ view_module path ~env;
+ find_shown_module path
+ in
+ (try !set_path path ~sign with _ -> ());
+ begin match mw.mw_title with None -> ()
+ | Some label ->
+ Label.configure label ~text:title;
+ pack [label] ~fill:`X ~side:`Bottom
+ end;
+ Button.configure mw.mw_detach
+ ~command:(fun () -> view_signature sign ~title ~env ~detach:true);
+ pack [mw.mw_detach] ~side:`Left;
+ let repack = ref false in
+ List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f:
+ begin fun button ext ->
+ try
+ let id = head_id path in
+ let file =
+ Misc.find_in_path_uncap !Config.load_path
+ ((Ident.name id) ^ ext) in
+ Button.configure button
+ ~command:(fun () -> edit_source ~file ~path ~sign);
+ if !repack then Pack.forget [button] else
+ if not (Winfo.viewable button) then repack := true;
+ pack [button] ~side:`Left
+ with Not_found ->
+ Pack.forget [button]
+ end;
+ let top = Winfo.toplevel mw.mw_frame in
+ if not (Winfo.ismapped top) then Wm.deiconify top;
+ List.iter ~f:destroy (Winfo.children mw.mw_frame);
+ Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
+ with Not_found ->
+ let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in
+ top_widgets := tl :: !top_widgets;
+ tl, tw, finish
+ in
+ Format.set_max_boxes 100;
+ Printtyp.wrap_printing_env env
+ (fun () -> Printtyp.signature Format.std_formatter sign);
+ finish ();
+ Lexical.init_tags tw;
+ Lexical.tag tw;
+ Text.configure tw ~state:`Disabled;
+ let text = Jg_text.get_all tw in
+ let pt =
+ try Parse.interface (Lexing.from_string text)
+ with Syntaxerr.Error e ->
+ let l = Syntaxerr.location_of_error e in
+ Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
+ ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; []
+ | Lexer.Error (_, l) ->
+ let s = l.loc_start.Lexing.pos_cnum in
+ let e = l.loc_end.Lexing.pos_cnum in
+ Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; []
+ in
+ Jg_bind.enter_focus tw;
+ bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")]
+ ~action:(fun _ -> Jg_text.search_string tw);
+ bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~fields:[`MouseX;`MouseY] ~breakable:true
+ ~action:(fun ev ->
+ let `Linechar (l, c) =
+ Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in
+ try
+ match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+ with [] -> break ()
+ | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env
+ with Not_found | Env.Error _ -> ());
+ bind tw ~events:[`ButtonPressDetail 3] ~breakable:true
+ ~fields:[`MouseX;`MouseY]
+ ~action:(fun ev ->
+ let x = ev.ev_MouseX and y = ev.ev_MouseY in
+ let `Linechar (l, c) =
+ Text.index tw ~index:(`Atxy(x,y), []) in
+ try
+ match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+ with [] -> break ()
+ | ((kind, lid), env, loc) :: _ ->
+ let menu = view_decl_menu lid ~kind ~env ~parent:tw in
+ let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in
+ Menu.popup menu ~x ~y
+ with Not_found -> ())
+
+and view_signature_item sign ~path ~env =
+ view_signature sign ~title:(string_of_path path)
+ ?path:(parent_path path) ~env
+
+and view_module path ~env =
+ match find_module path env with
+ {md_type=Mty_signature sign} ->
+ !view_defined_ref (Searchid.longident_of_path path) ~env
+ | modtype ->
+ let id = ident_of_path path ~default:"M" in
+ view_signature_item [Sig_module (id, modtype, Trec_not)] ~path ~env
+
+and view_module_id id ~env =
+ let path = lookup_module ~load:true id env in
+ view_module path ~env
+
+and view_type_decl path ~env =
+ let td = find_type path env in
+ try match td.type_manifest with None -> raise Not_found
+ | Some ty -> match Ctype.repr ty with
+ {desc = Tobject _} ->
+ let clt = find_cltype path env in
+ view_signature_item ~path ~env
+ [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first);
+ dummy_item; dummy_item]
+ | _ -> raise Not_found
+ with Not_found ->
+ view_signature_item ~path ~env
+ [Sig_type(ident_of_path path ~default:"t", td, Trec_first)]
+
+and view_type_id li ~env =
+ let path = lookup_type li env in
+ view_type_decl path ~env
+
+and view_class_id li ~env =
+ let path, cl = lookup_class li env in
+ view_signature_item ~path ~env
+ [Sig_class(ident_of_path path ~default:"c", cl, Trec_first);
+ dummy_item; dummy_item; dummy_item]
+
+and view_cltype_id li ~env =
+ let path, clt = lookup_cltype li env in
+ view_signature_item ~path ~env
+ [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first);
+ dummy_item; dummy_item]
+
+and view_modtype_id li ~env =
+ let path, td = lookup_modtype li env in
+ view_signature_item ~path ~env
+ [Sig_modtype(ident_of_path path ~default:"S", td)]
+
+and view_expr_type ?title ?path ?env ?(name="noname") t =
+ let title =
+ match title, path with Some title, _ -> title
+ | None, Some path -> string_of_path path
+ | None, None -> "Expression type"
+ and path, id =
+ match path with None -> None, Ident.create name
+ | Some path -> parent_path path, ident_of_path path ~default:name
+ in
+ view_signature ~title ?path ?env
+ [Sig_value (id, {val_type = t; val_kind = Val_reg; val_attributes=[];
+ val_loc = Location.none})]
+
+and view_decl lid ~kind ~env =
+ match kind with
+ `Type -> view_type_id lid ~env
+ | `Class -> view_class_id lid ~env
+ | `Module -> view_module_id lid ~env
+ | `Modtype -> view_modtype_id lid ~env
+
+and view_decl_menu lid ~kind ~env ~parent =
+ let path, kname =
+ try match kind with
+ `Type -> lookup_type lid env, "Type"
+ | `Class -> fst (lookup_class lid env), "Class"
+ | `Module -> lookup_module ~load:true lid env, "Module"
+ | `Modtype -> fst (lookup_modtype lid env), "Module type"
+ with Env.Error _ -> raise Not_found
+ in
+ let menu = Menu.create parent ~tearoff:false in
+ let label = kname ^ " " ^ string_of_path path in
+ begin match path with
+ Pident _ ->
+ Menu.add_command menu ~label ~state:`Disabled
+ | _ ->
+ Menu.add_command menu ~label
+ ~command:(fun () -> view_decl lid ~kind ~env);
+ end;
+ if kind = `Type || kind = `Modtype then begin
+ let buf = new buffer ~size:60 in
+ let (fo,ff) = Format.get_formatter_output_functions ()
+ and margin = Format.get_margin () in
+ Format.set_formatter_output_functions buf#out (fun () -> ());
+ Format.set_margin 60;
+ Format.open_hbox ();
+ Printtyp.wrap_printing_env env begin fun () ->
+ if kind = `Type then
+ Printtyp.type_declaration
+ (ident_of_path path ~default:"t")
+ Format.std_formatter
+ (find_type path env)
+ else
+ Printtyp.modtype_declaration
+ (ident_of_path path ~default:"S")
+ Format.std_formatter
+ (find_modtype path env)
+ end;
+ Format.close_box (); Format.print_flush ();
+ Format.set_formatter_output_functions fo ff;
+ Format.set_margin margin;
+ let l = Str.split ~!"\n" buf#get in
+ let font =
+ let font =
+ Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
+ if font = "" then "7x14" else font
+ in
+ (* Menu.add_separator menu; *)
+ List.iter l
+ ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled)
+ end;
+ menu
+
+(* search and view in a structure *)
+
+type fkind = [
+ `Exp of
+ [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t]
+ * type_expr
+ | `Class of Path.t * class_type
+ | `Module of Path.t * module_type
+]
+
+let view_type kind ~env =
+ match kind with
+ `Exp (k, ty) ->
+ begin match k with
+ `Expr -> view_expr_type ty ~title:"Expression type" ~env
+ | `Pat -> view_expr_type ty ~title:"Pattern type" ~env
+ | `Const -> view_expr_type ty ~title:"Constant type" ~env
+ | `Val path ->
+ begin try
+ let vd = find_value path env in
+ view_signature_item ~path ~env
+ [Sig_value(ident_of_path path ~default:"v", vd)]
+ with Not_found ->
+ view_expr_type ty ~path ~env
+ end
+ | `Var path ->
+ let vd = find_value path env in
+ view_expr_type vd.val_type ~env ~path ~title:"Variable type"
+ | `New path ->
+ let cl = find_class path env in
+ view_signature_item ~path ~env
+ [Sig_class(ident_of_path path ~default:"c", cl, Trec_first)]
+ end
+ | `Class (path, cty) ->
+ let cld = { cty_params = []; cty_variance = []; cty_type = cty;
+ cty_path = path; cty_new = None; cty_loc = Location.none;
+ cty_attributes = []} in
+ view_signature_item ~path ~env
+ [Sig_class(ident_of_path path ~default:"c", cld, Trec_first)]
+ | `Module (path, mty) ->
+ match mty with
+ Mty_signature sign -> view_signature sign ~path ~env
+ | modtype ->
+ let md =
+ {md_type = mty; md_attributes = []; md_loc = Location.none} in
+ view_signature_item ~path ~env
+ [Sig_module(ident_of_path path ~default:"M", md, Trec_not)]
+
+let view_type_menu kind ~env ~parent =
+ let title =
+ match kind with
+ `Exp (`Expr,_) -> "Expression :"
+ | `Exp (`Pat, _) -> "Pattern :"
+ | `Exp (`Const, _) -> "Constant :"
+ | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :"
+ | `Exp (`Var path, _) ->
+ "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :"
+ | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :"
+ | `Class (path, _) -> "Class " ^ string_of_path path ^ " :"
+ | `Module (path,_) -> "Module " ^ string_of_path path in
+ let menu = Menu.create parent ~tearoff:false in
+ begin match kind with
+ `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) ->
+ Menu.add_command menu ~label:title ~state:`Disabled
+ | `Exp _ | `Class _ | `Module _ ->
+ Menu.add_command menu ~label:title
+ ~command:(fun () -> view_type kind ~env)
+ end;
+ begin match kind with `Module _ | `Class _ -> ()
+ | `Exp(_, ty) ->
+ let buf = new buffer ~size:60 in
+ let (fo,ff) = Format.get_formatter_output_functions ()
+ and margin = Format.get_margin () in
+ Format.set_formatter_output_functions buf#out ignore;
+ Format.set_margin 60;
+ Format.open_hbox ();
+ Printtyp.reset ();
+ Printtyp.mark_loops ty;
+ Printtyp.wrap_printing_env env
+ (fun () -> Printtyp.type_expr Format.std_formatter ty);
+ Format.close_box (); Format.print_flush ();
+ Format.set_formatter_output_functions fo ff;
+ Format.set_margin margin;
+ let l = Str.split ~!"\n" buf#get in
+ let font =
+ let font =
+ Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
+ if font = "" then "7x14" else font
+ in
+ (* Menu.add_separator menu; *)
+ List.iter l ~f:
+ begin fun label -> match (Ctype.repr ty).desc with
+ Tconstr (path,_,_) ->
+ Menu.add_command menu ~label ~font
+ ~command:(fun () -> view_type_decl path ~env)
+ | Tvariant {row_name = Some (path, _)} ->
+ Menu.add_command menu ~label ~font
+ ~command:(fun () -> view_type_decl path ~env)
+ | _ ->
+ Menu.add_command menu ~label ~font ~state:`Disabled
+ end
+ end;
+ menu
+
+let found_str = ref ([] : (fkind * Env.t * Location.t) list)
+let add_found_str = add_found ~found:found_str
+
+let rec search_pos_structure ~pos str =
+ List.iter str ~f:
+ begin function str -> match str.str_desc with
+ Tstr_eval (exp, _) -> search_pos_expr exp ~pos
+ | Tstr_value (rec_flag, l) ->
+ List.iter l ~f:
+ begin fun {vb_pat=pat;vb_expr=exp} ->
+ let env =
+ if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in
+ search_pos_pat pat ~pos ~env;
+ search_pos_expr exp ~pos
+ end
+ | Tstr_module mb -> search_pos_module_expr mb.mb_expr ~pos
+ | Tstr_recmodule bindings ->
+ List.iter bindings ~f:(fun mb -> search_pos_module_expr mb.mb_expr ~pos)
+ | Tstr_class l ->
+ List.iter l ~f:(fun (ci, _) -> search_pos_class_expr ci.ci_expr ~pos)
+ | Tstr_include {incl_mod=m} -> search_pos_module_expr m ~pos
+ | Tstr_primitive _
+ | Tstr_type _
+ | Tstr_typext _
+ | Tstr_exception _
+ | Tstr_modtype _
+ | Tstr_open _
+ | Tstr_class_type _
+ | Tstr_attribute _
+ -> ()
+ end
+
+and search_pos_class_structure ~pos cls =
+ List.iter cls.cstr_fields ~f:
+ begin function cf -> match cf.cf_desc with
+ Tcf_inherit (_, cl, _, _, _) ->
+ search_pos_class_expr cl ~pos
+ | Tcf_val (_, _, _, Tcfk_concrete (_, exp), _) -> search_pos_expr exp ~pos
+ | Tcf_val _ -> ()
+ | Tcf_method (_, _, Tcfk_concrete (_, exp)) -> search_pos_expr exp ~pos
+ | Tcf_initializer exp -> search_pos_expr exp ~pos
+ | Tcf_constraint _
+ | Tcf_attribute _
+ | Tcf_method _
+ -> () (* TODO !!!!!!!!!!!!!!!!! *)
+ end
+
+and search_pos_class_expr ~pos cl =
+ if in_loc cl.cl_loc ~pos then begin
+ begin match cl.cl_desc with
+ Tcl_ident (path, _, _) ->
+ add_found_str (`Class (path, cl.cl_type))
+ ~env:!start_env ~loc:cl.cl_loc
+ | Tcl_structure cls ->
+ search_pos_class_structure ~pos cls
+ | Tcl_fun (_, pat, iel, cl, _) ->
+ search_pos_pat pat ~pos ~env:pat.pat_env;
+ List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos);
+ search_pos_class_expr cl ~pos
+ | Tcl_apply (cl, el) ->
+ search_pos_class_expr cl ~pos;
+ List.iter el ~f:(fun (_, x) -> Misc.may (search_pos_expr ~pos) x)
+ | Tcl_let (_, pel, iel, cl) ->
+ List.iter pel ~f:
+ begin fun {vb_pat=pat; vb_expr=exp} ->
+ search_pos_pat pat ~pos ~env:exp.exp_env;
+ search_pos_expr exp ~pos
+ end;
+ List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos);
+ search_pos_class_expr cl ~pos
+ | Tcl_open (_, _, _, _, cl)
+ | Tcl_constraint (cl, _, _, _, _) ->
+ search_pos_class_expr cl ~pos
+ end;
+ add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type))
+ ~env:!start_env ~loc:cl.cl_loc
+ end
+
+and search_case ~pos {c_lhs; c_guard; c_rhs} =
+ search_pos_pat c_lhs ~pos ~env:c_rhs.exp_env;
+ begin match c_guard with
+ | None -> ()
+ | Some g -> search_pos_expr g ~pos
+ end;
+ search_pos_expr c_rhs ~pos
+
+and search_pos_expr ~pos exp =
+ if in_loc exp.exp_loc ~pos then begin
+ begin match exp.exp_desc with
+ Texp_ident (path, _, _) ->
+ add_found_str (`Exp(`Val path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
+ | Texp_constant v ->
+ add_found_str (`Exp(`Const, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
+ | Texp_let (_, expl, exp) ->
+ List.iter expl ~f:
+ begin fun {vb_pat=pat; vb_expr=exp'} ->
+ search_pos_pat pat ~pos ~env:exp.exp_env;
+ search_pos_expr exp' ~pos
+ end;
+ search_pos_expr exp ~pos
+ | Texp_function {cases=l; _} ->
+ List.iter l ~f:(search_case ~pos)
+ | Texp_apply (exp, l) ->
+ List.iter l ~f:(fun (_, x) -> Misc.may (search_pos_expr ~pos) x);
+ search_pos_expr exp ~pos
+ | Texp_match (exp, l, _, _) ->
+ search_pos_expr exp ~pos;
+ List.iter l ~f:(search_case ~pos)
+ | Texp_try (exp, l) ->
+ search_pos_expr exp ~pos;
+ List.iter l ~f:(search_case ~pos)
+ | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
+ | Texp_construct (_, _, l) -> List.iter l ~f:(search_pos_expr ~pos)
+ | Texp_variant (_, None) -> ()
+ | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
+ | Texp_record {fields=l; extended_expression=opt} ->
+ Array.iter l ~f:
+ (function (_,Overridden(_,exp)) -> search_pos_expr exp ~pos | _ -> ());
+ (match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
+ | Texp_field (exp, _, _) -> search_pos_expr exp ~pos
+ | Texp_setfield (a, _, _, b) ->
+ search_pos_expr a ~pos; search_pos_expr b ~pos
+ | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
+ | Texp_ifthenelse (a, b, c) ->
+ search_pos_expr a ~pos; search_pos_expr b ~pos;
+ begin match c with None -> ()
+ | Some exp -> search_pos_expr exp ~pos
+ end
+ | Texp_sequence (a,b) ->
+ search_pos_expr a ~pos; search_pos_expr b ~pos
+ | Texp_while (a,b) ->
+ search_pos_expr a ~pos; search_pos_expr b ~pos
+ | Texp_for (_, _, a, b, _, c) ->
+ List.iter [a;b;c] ~f:(search_pos_expr ~pos)
+ | Texp_send (exp, _, _) -> search_pos_expr exp ~pos
+ | Texp_new (path, _, _) ->
+ add_found_str (`Exp(`New path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
+ | Texp_instvar (_, path, _) ->
+ add_found_str (`Exp(`Var path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
+ | Texp_setinstvar (_, path, _, exp) ->
+ search_pos_expr exp ~pos;
+ add_found_str (`Exp(`Var path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
+ | Texp_override (_, l) ->
+ List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos)
+ | Texp_letmodule (id, _, modexp, exp) ->
+ search_pos_module_expr modexp ~pos;
+ search_pos_expr exp ~pos
+ | Texp_assert exp ->
+ search_pos_expr exp ~pos
+ | Texp_lazy exp ->
+ search_pos_expr exp ~pos
+ | Texp_object (cls, _) ->
+ search_pos_class_structure ~pos cls
+ | Texp_pack modexp ->
+ search_pos_module_expr modexp ~pos
+ | Texp_unreachable ->
+ ()
+ | Texp_extension_constructor _ ->
+ ()
+ | Texp_letexception (_, exp) ->
+ search_pos_expr exp ~pos
+ end;
+ add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
+ end
+
+and search_pos_pat ~pos ~env pat =
+ if in_loc pat.pat_loc ~pos then begin
+ begin match pat.pat_desc with
+ Tpat_any -> ()
+ | Tpat_var (id, _) ->
+ add_found_str (`Exp(`Val (Pident id), pat.pat_type))
+ ~env ~loc:pat.pat_loc
+ | Tpat_alias (pat, _, _) -> search_pos_pat pat ~pos ~env
+ | Tpat_lazy pat -> search_pos_pat pat ~pos ~env
+ | Tpat_constant _ ->
+ add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
+ | Tpat_tuple l ->
+ List.iter l ~f:(search_pos_pat ~pos ~env)
+ | Tpat_construct (_, _, l) ->
+ List.iter l ~f:(search_pos_pat ~pos ~env)
+ | Tpat_variant (_, None, _) -> ()
+ | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
+ | Tpat_record (l, _) ->
+ List.iter l ~f:(fun (_, _, pat) -> search_pos_pat pat ~pos ~env)
+ | Tpat_array l ->
+ List.iter l ~f:(search_pos_pat ~pos ~env)
+ | Tpat_or (a, b, None) ->
+ search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env
+ | Tpat_or (_, _, Some _) ->
+ ()
+ end;
+ add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc
+ end
+
+and search_pos_module_expr ~pos (m :module_expr) =
+ if in_loc m.mod_loc ~pos then begin
+ begin match m.mod_desc with
+ Tmod_ident (path, _) ->
+ add_found_str (`Module (path, m.mod_type))
+ ~env:m.mod_env ~loc:m.mod_loc
+ | Tmod_structure str -> search_pos_structure str.str_items ~pos
+ | Tmod_functor (_, _, _, m) -> search_pos_module_expr m ~pos
+ | Tmod_apply (a, b, _) ->
+ search_pos_module_expr a ~pos; search_pos_module_expr b ~pos
+ | Tmod_constraint (m, _, _, _) -> search_pos_module_expr m ~pos
+ | Tmod_unpack (e, _) -> search_pos_expr e ~pos
+ end;
+ add_found_str (`Module (Pident (Ident.create "M"), m.mod_type))
+ ~env:m.mod_env ~loc:m.mod_loc
+ end
+
+let search_pos_structure ~pos str =
+ observe ~ref:found_str (search_pos_structure ~pos) str
+
+open Stypes
+
+let search_pos_ti ~pos = function
+ Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p
+ | Ti_expr e -> search_pos_expr ~pos e
+ | Ti_class c -> search_pos_class_expr ~pos c
+ | Ti_mod m -> search_pos_module_expr ~pos m
+ | _ -> ()
+
+let rec search_pos_info ~pos = function
+ [] -> []
+ | ti :: l ->
+ if in_loc ~pos (get_location ti)
+ then observe ~ref:found_str (search_pos_ti ~pos) ti
+ else search_pos_info ~pos l
diff --git a/browser/searchpos.mli b/browser/searchpos.mli
new file mode 100644
index 0000000..a2d5dfd
--- /dev/null
+++ b/browser/searchpos.mli
@@ -0,0 +1,77 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val top_widgets : any widget list ref
+
+type module_widgets =
+ { mw_frame: frame widget;
+ mw_title: label widget option;
+ mw_detach: button widget;
+ mw_edit: button widget;
+ mw_intf: button widget }
+
+val add_shown_module : Path.t -> widgets:module_widgets -> unit
+val find_shown_module : Path.t -> module_widgets
+val is_shown_module : Path.t -> bool
+val default_frame : module_widgets option ref
+val set_path : (Path.t -> sign:Types.signature -> unit) ref
+
+val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref
+val editor_ref :
+ (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref
+
+val view_signature :
+ ?title:string ->
+ ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit
+val view_signature_item :
+ Types.signature -> path:Path.t -> env:Env.t -> unit
+val view_module_id : Longident.t -> env:Env.t -> unit
+val view_type_id : Longident.t -> env:Env.t -> unit
+val view_class_id : Longident.t -> env:Env.t -> unit
+val view_cltype_id : Longident.t -> env:Env.t -> unit
+val view_modtype_id : Longident.t -> env:Env.t -> unit
+val view_type_decl : Path.t -> env:Env.t -> unit
+
+type skind = [`Type|`Class|`Module|`Modtype]
+val search_pos_signature :
+ Parsetree.signature -> pos:int -> env:Env.t ->
+ ((skind * Longident.t) * Env.t * Location.t) list
+val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit
+val view_decl_menu :
+ Longident.t ->
+ kind:skind -> env:Env.t -> parent:text widget -> menu widget
+
+type fkind = [
+ `Exp of
+ [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t]
+ * Types.type_expr
+ | `Class of Path.t * Types.class_type
+ | `Module of Path.t * Types.module_type
+]
+val search_pos_structure :
+ pos:int -> Typedtree.structure_item list ->
+ (fkind * Env.t * Location.t) list
+val search_pos_info :
+ pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list
+val view_type : fkind -> env:Env.t -> unit
+val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget
+
+val parent_path : Path.t -> Path.t option
+val string_of_path : Path.t -> string
+val string_of_longident : Longident.t -> string
+val lines_to_chars : int -> text:string -> int
diff --git a/browser/setpath.ml b/browser/setpath.ml
new file mode 100644
index 0000000..0186576
--- /dev/null
+++ b/browser/setpath.ml
@@ -0,0 +1,162 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+
+(* Listboxes *)
+
+let update_hooks = ref []
+
+let add_update_hook f = update_hooks := f :: !update_hooks
+
+let exec_update_hooks () =
+ update_hooks := List.filter !update_hooks ~f:
+ begin fun f ->
+ try f (); true
+ with Protocol.TkError _ -> false
+ end
+
+let set_load_path l =
+ Config.load_path := l;
+ exec_update_hooks ()
+
+let get_load_path () = !Config.load_path
+
+let renew_dirs box ~var ~dir =
+ Textvariable.set var dir;
+ Listbox.delete box ~first:(`Num 0) ~last:`End;
+ Listbox.insert box ~index:`End
+ ~texts:(Useunix.get_directories_in_files ~path:dir
+ (Useunix.get_files_in_directory dir));
+ Jg_box.recenter box ~index:(`Num 0)
+
+let renew_path box =
+ Listbox.delete box ~first:(`Num 0) ~last:`End;
+ Listbox.insert box ~index:`End ~texts:!Config.load_path;
+ Jg_box.recenter box ~index:(`Num 0)
+
+let add_to_path ~dirs ?(base="") box =
+ let dirs =
+ if base = "" then dirs else
+ if dirs = [] then [base] else
+ List.map dirs ~f:
+ begin function
+ "." -> base
+ | ".." -> Filename.dirname base
+ | x -> Filename.concat base x
+ end
+ in
+ set_load_path
+ (dirs @ List.fold_left dirs ~init:(get_load_path ())
+ ~f:(fun acc x -> List2.exclude x acc))
+
+let remove_path box ~dirs =
+ set_load_path
+ (List.fold_left dirs ~init:(get_load_path ())
+ ~f:(fun acc x -> List2.exclude x acc))
+
+(* main function *)
+
+let f ~dir =
+ let current_dir = ref dir in
+ let tl = Jg_toplevel.titled "Edit Load Path" in
+ Jg_bind.escape_destroy tl;
+ let var_dir = Textvariable.create ~on:tl () in
+ let caplab = Label.create tl ~text:"Path"
+ and dir_name = Entry.create tl ~textvariable:var_dir
+ and browse = Frame.create tl in
+ let dirs = Frame.create browse
+ and path = Frame.create browse in
+ let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs
+ and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path
+ in
+ add_update_hook (fun () -> renew_path pathbox);
+ Listbox.configure pathbox ~width:40 ~selectmode:`Multiple;
+ Listbox.configure dirbox ~selectmode:`Multiple;
+ Jg_box.add_completion dirbox ~action:
+ begin fun index ->
+ begin match Listbox.get dirbox ~index with
+ "." -> ()
+ | ".." -> current_dir := Filename.dirname !current_dir
+ | x -> current_dir := !current_dir ^ "/" ^ x
+ end;
+ renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
+ Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
+ end;
+ Jg_box.add_completion pathbox ~action:
+ begin fun index ->
+ current_dir := Listbox.get pathbox ~index;
+ renew_dirs dirbox ~var:var_dir ~dir:!current_dir
+ end;
+
+ bind dir_name ~events:[`KeyPressDetail"Return"]
+ ~action:(fun _ ->
+ let dir = Textvariable.get var_dir in
+ if Useunix.is_directory dir then begin
+ current_dir := dir;
+ renew_dirs dirbox ~var:var_dir ~dir
+ end);
+
+ (* Avoid space being used by the completion mechanism *)
+ let bind_space_toggle lb =
+ bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in
+ bind_space_toggle dirbox;
+ bind_space_toggle pathbox;
+
+ let add_paths _ =
+ add_to_path pathbox ~base:!current_dir
+ ~dirs:(List.map (Listbox.curselection dirbox)
+ ~f:(fun x -> Listbox.get dirbox ~index:x));
+ Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
+ and remove_paths _ =
+ remove_path pathbox
+ ~dirs:(List.map (Listbox.curselection pathbox)
+ ~f:(fun x -> Listbox.get pathbox ~index:x))
+ in
+ bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths;
+ bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths;
+
+ let dirlab = Label.create dirs ~text:"Directories"
+ and pathlab = Label.create path ~text:"Load path"
+ and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths
+ and pathbuttons = Frame.create path in
+ let removebutton =
+ Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths
+ and ok =
+ Jg_button.create_destroyer tl ~parent:pathbuttons
+ in
+ renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
+ renew_path pathbox;
+ pack [dirsb] ~side:`Right ~fill:`Y;
+ pack [dirbox] ~side:`Left ~fill:`Y ~expand:true;
+ pack [pathsb] ~side:`Right ~fill:`Y;
+ pack [pathbox] ~side:`Left ~fill:`Both ~expand:true;
+ pack [dirlab] ~side:`Top ~anchor:`W ~padx:10;
+ pack [addbutton] ~side:`Bottom ~fill:`X;
+ pack [dirframe] ~fill:`Y ~expand:true;
+ pack [pathlab] ~side:`Top ~anchor:`W ~padx:10;
+ pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true;
+ pack [pathbuttons] ~fill:`X ~side:`Bottom;
+ pack [pathframe] ~fill:`Both ~expand:true;
+ pack [dirs] ~side:`Left ~fill:`Y;
+ pack [path] ~side:`Right ~fill:`Both ~expand:true;
+ pack [caplab] ~side:`Top ~anchor:`W ~padx:10;
+ pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X;
+ pack [browse] ~side:`Bottom ~expand:true ~fill:`Both;
+ tl
+
+let set ~dir = ignore (f ~dir);;
diff --git a/browser/setpath.mli b/browser/setpath.mli
new file mode 100644
index 0000000..6191b70
--- /dev/null
+++ b/browser/setpath.mli
@@ -0,0 +1,25 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+
+val add_update_hook : (unit -> unit) -> unit
+val exec_update_hooks : unit -> unit
+ (* things to do when Config.load_path changes *)
+
+val set : dir:string -> unit
+val f : dir:string -> toplevel widget
+ (* edit the load path *)
diff --git a/browser/shell.ml b/browser/shell.ml
new file mode 100644
index 0000000..7004cfc
--- /dev/null
+++ b/browser/shell.ml
@@ -0,0 +1,366 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+module Unix = UnixLabels
+open Tk
+open Jg_tk
+open Dummy
+
+(* Here again, memoize regexps *)
+
+let (~!) = Jg_memo.fast ~f:Str.regexp
+
+(* Nice history class. May reuse *)
+
+class ['a] history () = object
+ val mutable history = ([] : 'a list)
+ val mutable count = 0
+ method empty = history = []
+ method add s = count <- 0; history <- s :: history
+ method previous =
+ let s = List.nth history count in
+ count <- (count + 1) mod List.length history;
+ s
+ method next =
+ let l = List.length history in
+ count <- (l + count - 1) mod l;
+ List.nth history ((l + count - 1) mod l)
+end
+
+let dump_handle (h : Unix.file_descr) =
+ let obj = Obj.repr h in
+ if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then
+ invalid_arg "Shell.dump_handle";
+ Nativeint.format "%x" (Obj.obj obj)
+
+(* The shell class. Now encapsulated *)
+
+let protect f x = try f x with _ -> ()
+
+let is_win32 = Sys.os_type = "Win32"
+let use_threads = is_win32
+let use_sigpipe = is_win32
+
+class shell ~textw ~prog ~args ~env ~history =
+ let (in2,out1) = Unix.pipe ()
+ and (in1,out2) = Unix.pipe ()
+ and (err1,err2) = Unix.pipe ()
+ and (sig2,sig1) = Unix.pipe () in
+object (self)
+ val pid =
+ let env =
+ if use_sigpipe then
+ let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in
+ Array.append env [|sigdef|]
+ else env
+ in
+ Unix.create_process_env ~prog ~args ~env
+ ~stdin:in2 ~stdout:out2 ~stderr:err2
+ val out = Unix.out_channel_of_descr out1
+ val h : _ history = history
+ val mutable alive = true
+ val mutable reading = false
+ val ibuffer = Buffer.create 1024
+ val imutex = Mutex.create ()
+ val mutable ithreads = []
+ method alive = alive
+ method kill =
+ if Winfo.exists textw then Text.configure textw ~state:`Disabled;
+ if alive then begin
+ alive <- false;
+ protect close_out out;
+ try
+ if use_sigpipe then
+ ignore (Unix.write sig1 ~buf:(Bytes.make 1 'T') ~pos:0 ~len:1);
+ List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2];
+ if not use_threads then begin
+ Fileevent.remove_fileinput ~fd:in1;
+ Fileevent.remove_fileinput ~fd:err1;
+ end;
+ if not use_sigpipe then begin
+ Unix.kill ~pid ~signal:Sys.sigkill;
+ ignore (Unix.waitpid ~mode:[] pid)
+ end
+ with _ -> ()
+ end
+ method interrupt =
+ if alive then try
+ reading <- false;
+ if use_sigpipe then begin
+ ignore (Unix.write sig1 ~buf:(Bytes.make 1 'C') ~pos:0 ~len:1);
+ self#send " "
+ end else
+ Unix.kill ~pid ~signal:Sys.sigint
+ with Unix.Unix_error _ -> ()
+ method send s =
+ if alive then try
+ output_string out s;
+ flush out
+ with Sys_error _ -> ()
+ method private read ~fd ~len =
+ begin try
+ let buf = Bytes.create len in
+ let len = Unix.read fd ~buf ~pos:0 ~len in
+ if len > 0 then begin
+ self#insert (Bytes.sub_string buf ~pos:0 ~len);
+ Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
+ end;
+ len
+ with Unix.Unix_error _ -> 0
+ end;
+ method history (dir : [`Next|`Previous]) =
+ if not h#empty then begin
+ if reading then begin
+ Text.delete textw ~start:(`Mark"input",[`Char 1])
+ ~stop:(`Mark"insert",[])
+ end else begin
+ reading <- true;
+ Text.mark_set textw ~mark:"input"
+ ~index:(`Mark"insert",[`Char(-1)])
+ end;
+ self#insert (if dir = `Previous then h#previous else h#next)
+ end
+ method private lex ?(start = `Mark"insert",[`Linestart])
+ ?(stop = `Mark"insert",[`Lineend]) () =
+ Lexical.tag textw ~start ~stop
+ method insert text =
+ let idx = Text.index textw
+ ~index:(`Mark"insert",[`Char(-1);`Linestart]) in
+ Text.insert textw ~text ~index:(`Mark"insert",[]);
+ self#lex ~start:(idx,[`Linestart]) ();
+ Text.see textw ~index:(`Mark"insert",[])
+ method private keypress c =
+ if not reading && c > " " then begin
+ reading <- true;
+ Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
+ end
+ method private keyrelease c = if c <> "" then self#lex ()
+ method private return =
+ if reading then reading <- false
+ else Text.mark_set textw ~mark:"input"
+ ~index:(`Mark"insert",[`Linestart;`Char 1]);
+ Text.mark_set textw ~mark:"insert" ~index:(`Mark"insert",[`Lineend]);
+ self#lex ~start:(`Mark"input",[`Linestart]) ();
+ let s =
+ (* input is one character before real input *)
+ Text.get textw ~start:(`Mark"input",[`Char 1])
+ ~stop:(`Mark"insert",[]) in
+ h#add s;
+ Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n";
+ Text.yview_index textw ~index:(`Mark"insert",[]);
+ self#send s;
+ self#send "\n"
+ method private paste ev =
+ if not reading then begin
+ reading <- true;
+ Text.mark_set textw ~mark:"input"
+ ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)])
+ end
+ initializer
+ Lexical.init_tags textw;
+ let rec bindings =
+ [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char);
+ ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char);
+ (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *)
+ ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste);
+ ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
+ ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next);
+ ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
+ ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next);
+ ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt);
+ ([], `Destroy, [], fun _ -> self#kill) ]
+ in
+ List.iter bindings ~f:
+ begin fun (modif,event,fields,action) ->
+ bind textw ~events:[`Modified(modif,event)] ~fields ~action
+ end;
+ bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true
+ ~action:(fun _ -> self#return; break());
+ List.iter ~f:Unix.close [in2;out2;err2];
+ if use_threads then begin
+ let fileinput_thread fd =
+ let buf = Bytes.create 1024 in
+ let len = ref 0 in
+ try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do
+ Mutex.lock imutex;
+ Buffer.add_subbytes ibuffer buf 0 !len;
+ Mutex.unlock imutex
+ done with Unix.Unix_error _ -> ()
+ in
+ ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread);
+ let rec read_buffer () =
+ Mutex.lock imutex;
+ if Buffer.length ibuffer > 0 then begin
+ self#insert (Str.global_replace ~!"\r\n" "\n"
+ (Buffer.contents ibuffer));
+ Buffer.reset ibuffer;
+ Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
+ end;
+ Mutex.unlock imutex;
+ Timer.set ~ms:100 ~callback:read_buffer
+ in
+ read_buffer ()
+ end else begin
+ try
+ List.iter [in1;err1] ~f:
+ begin fun fd ->
+ Fileevent.add_fileinput ~fd
+ ~callback:(fun () -> ignore (self#read ~fd ~len:1024))
+ end
+ with _ -> ()
+ end
+end
+
+(* Specific use of shell, for OCamlBrowser *)
+
+let shells : (string * shell) list ref = ref []
+
+(* Called before exiting *)
+let kill_all () =
+ List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill);
+ shells := []
+
+let get_all () =
+ let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in
+ shells := all;
+ all
+
+let may_exec_unix prog =
+ try Unix.access prog ~perm:[Unix.X_OK]; prog
+ with Unix.Unix_error _ -> ""
+
+let may_exec_win prog =
+ let has_ext =
+ List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in
+ if has_ext then may_exec_unix prog else
+ List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:""
+ ~f:(fun res prog -> if res = "" then may_exec_unix prog else res)
+
+let may_exec =
+ if is_win32 then may_exec_win else may_exec_unix
+
+let path_sep = if is_win32 then ";" else ":"
+
+let warnings = ref Warnings.defaults_w
+
+let program_not_found prog =
+ Jg_message.info ~title:"Error"
+ ("Program \"" ^ prog ^ "\"\nwas not found in path")
+
+let protect_arg s =
+ if String.contains s ' ' then "\"" ^ s ^ "\"" else s
+
+let f ~prog ~title =
+ let progargs =
+ List.filter ~f:((<>) "") (Str.split ~!" " prog) in
+ if progargs = [] then () else
+ let prog = List.hd progargs in
+ let path =
+ try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
+ let exec_path = Str.split ~!path_sep path in
+ let exec_path = if is_win32 then "."::exec_path else exec_path in
+ let progpath =
+ if not (Filename.is_implicit prog) then may_exec prog else
+ List.fold_left exec_path ~init:"" ~f:
+ (fun res dir ->
+ if res = "" then may_exec (Filename.concat dir prog) else res) in
+ if progpath = "" then program_not_found prog else
+ let tl = Jg_toplevel.titled title in
+ let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+ Toplevel.configure tl ~menu:menus;
+ let file_menu = new Jg_menu.c "File" ~parent:menus
+ and history_menu = new Jg_menu.c "History" ~parent:menus
+ and signal_menu = new Jg_menu.c "Signal" ~parent:menus in
+ let frame, tw, sb = Jg_text.create_with_scrollbar tl in
+ Text.configure tw ~background:`White;
+ pack [sb] ~fill:`Y ~side:`Right;
+ pack [tw] ~fill:`Both ~expand:true ~side:`Left;
+ pack [frame] ~fill:`Both ~expand:true;
+ let env = Array.map (Unix.environment ()) ~f:
+ begin fun s ->
+ if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s
+ end in
+ let load_path =
+ List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in
+ let load_path =
+ if is_win32 then List.map ~f:protect_arg load_path else load_path in
+ let labels = if !Clflags.classic then ["-nolabels"] else [] in
+ let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in
+ let warnings =
+ if List.mem "-w" progargs || !warnings = "Al" then []
+ else ["-w"; !warnings]
+ in
+ let args =
+ Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in
+ let history = new history () in
+ let start_shell () =
+ let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in
+ shells := (title, sh) :: !shells;
+ sh
+ in
+ let sh = ref (start_shell ()) in
+ let current_dir = ref (Unix.getcwd ()) in
+ file_menu#add_command "Restart" ~command:
+ begin fun () ->
+ (!sh)#kill;
+ Text.configure tw ~state:`Normal;
+ Text.insert tw ~index:(`End,[]) ~text:"\n";
+ Text.see tw ~index:(`End,[]);
+ Text.mark_set tw ~mark:"insert" ~index:(`End,[]);
+ sh := start_shell ();
+ end;
+ file_menu#add_command "Use..." ~command:
+ begin fun () ->
+ Fileselect.f ~title:"Use File" ~filter:"*.ml"
+ ~sync:true ~dir:!current_dir ()
+ ~action:(fun l ->
+ if l = [] then () else
+ let name = Fileselect.caml_dir (List.hd l) in
+ current_dir := Filename.dirname name;
+ if Filename.check_suffix name ".ml"
+ then
+ let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in
+ (!sh)#insert cmd; (!sh)#send cmd)
+ end;
+ file_menu#add_command "Load..." ~command:
+ begin fun () ->
+ Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true ()
+ ~dir:!current_dir
+ ~action:(fun l ->
+ if l = [] then () else
+ let name = Fileselect.caml_dir (List.hd l) in
+ current_dir := Filename.dirname name;
+ if Filename.check_suffix name ".cmo" ||
+ Filename.check_suffix name ".cma"
+ then
+ let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in
+ (!sh)#insert cmd; (!sh)#send cmd)
+ end;
+ file_menu#add_command "Import path" ~command:
+ begin fun () ->
+ List.iter (List.rev !Config.load_path) ~f:
+ (fun dir ->
+ (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n"))
+ end;
+ file_menu#add_command "Close" ~command:(fun () -> destroy tl);
+ history_menu#add_command "Previous " ~accelerator:"M-p"
+ ~command:(fun () -> (!sh)#history `Previous);
+ history_menu#add_command "Next" ~accelerator:"M-n"
+ ~command:(fun () -> (!sh)#history `Next);
+ signal_menu#add_command "Interrupt " ~accelerator:"C-c"
+ ~command:(fun () -> (!sh)#interrupt);
+ signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill)
diff --git a/browser/shell.mli b/browser/shell.mli
new file mode 100644
index 0000000..5bb1ff5
--- /dev/null
+++ b/browser/shell.mli
@@ -0,0 +1,46 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+class ['a] history :
+ unit ->
+ object
+ val mutable count : int
+ val mutable history : 'a list
+ method add : 'a -> unit
+ method empty : bool
+ method next : 'a
+ method previous : 'a
+ end
+
+(* toplevel shell *)
+
+class shell :
+ textw:Widget.text Widget.widget -> prog:string ->
+ args:string array -> env:string array -> history:string history ->
+ object
+ method alive : bool
+ method kill : unit
+ method interrupt : unit
+ method insert : string -> unit
+ method send : string -> unit
+ method history : [`Next|`Previous] -> unit
+ end
+
+val kill_all : unit -> unit
+val get_all : unit -> (string * shell) list
+val warnings : string ref
+
+val f : prog:string -> title:string -> unit
diff --git a/browser/typecheck.ml b/browser/typecheck.ml
new file mode 100644
index 0000000..7509982
--- /dev/null
+++ b/browser/typecheck.ml
@@ -0,0 +1,186 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Parsetree
+open Typedtree
+open Location
+open Jg_tk
+open Mytypes
+
+(* Optionally preprocess a source file *)
+
+let preprocess ~pp ~ext text =
+ let sourcefile = Filename.temp_file "caml" ext in
+ begin try
+ let oc = open_out_bin sourcefile in
+ output_string oc text;
+ flush oc;
+ close_out oc
+ with _ ->
+ failwith "Preprocessing error"
+ end;
+ let tmpfile = Filename.temp_file "camlpp" ext in
+ let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
+ if Ccomp.command comm <> 0 then begin
+ Sys.remove sourcefile;
+ Sys.remove tmpfile;
+ failwith "Preprocessing error"
+ end;
+ Sys.remove sourcefile;
+ tmpfile
+
+exception Outdated_version
+
+let parse_pp ~parse ~wrap ~ext text =
+ Location.input_name := "";
+ match !Clflags.preprocessor with
+ None ->
+ let buffer = Lexing.from_string text in
+ Location.init buffer "";
+ parse buffer
+ | Some pp ->
+ let tmpfile = preprocess ~pp ~ext text in
+ let ast_magic =
+ if ext = ".ml" then Config.ast_impl_magic_number
+ else Config.ast_intf_magic_number in
+ let ic = open_in_bin tmpfile in
+ let ast =
+ try
+ let buffer = really_input_string ic (String.length ast_magic) in
+ if buffer = ast_magic then begin
+ ignore (input_value ic);
+ wrap (input_value ic)
+ end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
+ raise Outdated_version
+ else
+ raise Exit
+ with
+ Outdated_version ->
+ close_in ic;
+ Sys.remove tmpfile;
+ failwith "OCaml and preprocessor have incompatible versions"
+ | _ ->
+ seek_in ic 0;
+ let buffer = Lexing.from_channel ic in
+ Location.init buffer "";
+ parse buffer
+ in
+ close_in ic;
+ Sys.remove tmpfile;
+ ast
+
+let nowarnings = ref false
+
+let f txt =
+ let error_messages = ref [] in
+ let text = Jg_text.get_all txt.tw
+ and env = ref (Compmisc.initial_env ()) in
+ let tl, ew, end_message =
+ Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in
+ Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend;
+ txt.structure <- [];
+ txt.type_info <- [];
+ txt.signature <- [];
+ txt.psignature <- [];
+ ignore (Stypes.get_info ());
+ Clflags.annotations := true;
+
+ begin try
+
+ if Filename.check_suffix txt.name ".mli" then
+ let psign = parse_pp text ~ext:".mli"
+ ~parse:Parse.interface ~wrap:(fun x -> x) in
+ txt.psignature <- psign;
+ txt.signature <- (Typemod.transl_signature !env psign).sig_type;
+
+ else (* others are interpreted as .ml *)
+
+ let psl = parse_pp text ~ext:".ml"
+ ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in
+ List.iter psl ~f:
+ begin function
+ Ptop_def pstr ->
+ let str, sign, env' = Typemod.type_structure !env pstr Location.none in
+ txt.structure <- txt.structure @ str.str_items;
+ txt.signature <- txt.signature @ sign;
+ env := env'
+ | Ptop_dir _ -> ()
+ end;
+ txt.type_info <- Stypes.get_info ();
+
+ with
+ Lexer.Error _ | Syntaxerr.Error _
+ | Typecore.Error _ | Typemod.Error _
+ | Typeclass.Error _ | Typedecl.Error _
+ | Typetexp.Error _ | Includemod.Error _
+ | Env.Error _ | Ctype.Tags _ | Failure _ as exn ->
+ txt.type_info <- Stypes.get_info ();
+ let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in
+ error_messages := et :: !error_messages;
+ let range = match exn with
+ Lexer.Error (err, l) ->
+ Lexer.report_error Format.std_formatter err; l
+ | Syntaxerr.Error err ->
+ Syntaxerr.report_error Format.std_formatter err;
+ Syntaxerr.location_of_error err
+ | Typecore.Error (l, env, err) ->
+ Typecore.report_error env Format.std_formatter err; l
+ | Typeclass.Error (l, env, err) ->
+ Typeclass.report_error env Format.std_formatter err; l
+ | Typedecl.Error (l, err) ->
+ Typedecl.report_error Format.std_formatter err; l
+ | Typemod.Error (l, env, err) ->
+ Typemod.report_error env Format.std_formatter err; l
+ | Typetexp.Error (l, env, err) ->
+ Typetexp.report_error env Format.std_formatter err; l
+ | Includemod.Error errl ->
+ Includemod.report_error Format.std_formatter errl; Location.none
+ | Env.Error err ->
+ Env.report_error Format.std_formatter err; Location.none
+ | Cmi_format.Error err ->
+ Cmi_format.report_error Format.std_formatter err; Location.none
+ | Ctype.Tags(l, l') ->
+ Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l';
+ Location.none
+ | Failure s ->
+ Format.printf "%s.@." s; Location.none
+ | _ -> assert false
+ in
+ end_message ();
+ let s = range.loc_start.Lexing.pos_cnum in
+ let e = range.loc_end.Lexing.pos_cnum in
+ if s < e then
+ Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"
+ end;
+ end_message ();
+ if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0)
+ then destroy tl
+ else begin
+ error_messages := tl :: !error_messages;
+ Text.configure ew ~state:`Disabled;
+ bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)]
+ ~action:(fun _ ->
+ try
+ let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in
+ let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in
+ let n = int_of_string s in
+ Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert";
+ Text.see txt.tw ~index:(`Mark "insert", [])
+ with _ -> ())
+ end;
+ !error_messages
diff --git a/browser/typecheck.mli b/browser/typecheck.mli
new file mode 100644
index 0000000..08a16dd
--- /dev/null
+++ b/browser/typecheck.mli
@@ -0,0 +1,23 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open Widget
+open Mytypes
+
+val nowarnings : bool ref
+
+val f : edit_window -> any widget list
+ (* Typechecks the window as much as possible *)
diff --git a/browser/useunix.ml b/browser/useunix.ml
new file mode 100644
index 0000000..86554d4
--- /dev/null
+++ b/browser/useunix.ml
@@ -0,0 +1,69 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open UnixLabels
+
+let get_files_in_directory dir =
+ let len = String.length dir in
+ let dir =
+ if len > 0 && Sys.os_type = "Win32" &&
+ (dir.[len-1] = '/' || dir.[len-1] = '\\')
+ then String.sub dir ~pos:0 ~len:(len-1)
+ else dir
+ in match
+ try Some(opendir dir) with Unix_error _ -> None
+ with
+ None -> []
+ | Some dirh ->
+ let rec get_them l =
+ match
+ try Some(readdir dirh) with _ -> None
+ with
+ | Some x ->
+ get_them (x::l)
+ | None ->
+ closedir dirh; l
+ in
+ List.sort ~cmp:compare (get_them [])
+
+let is_directory name =
+ try
+ (stat name).st_kind = S_DIR
+ with _ -> false
+
+let concat dir name =
+ let len = String.length dir in
+ if len = 0 then name else
+ if dir.[len-1] = '/' then dir ^ name
+ else dir ^ "/" ^ name
+
+let get_directories_in_files ~path =
+ List.filter ~f:(fun x -> is_directory (concat path x))
+
+(************************************************** Subshell call *)
+let subshell ~cmd =
+ let rc = open_process_in cmd in
+ let rec it l =
+ match
+ try Some(input_line rc) with _ -> None
+ with
+ Some x -> it (x::l)
+ | None -> List.rev l
+ in
+ let answer = it [] in
+ ignore (close_process_in rc);
+ answer
diff --git a/browser/useunix.mli b/browser/useunix.mli
new file mode 100644
index 0000000..47d7a26
--- /dev/null
+++ b/browser/useunix.mli
@@ -0,0 +1,23 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+(* Unix utilities *)
+
+val get_files_in_directory : string -> string list
+val is_directory : string -> bool
+val concat : string -> string -> string
+val get_directories_in_files : path:string -> string list -> string list
+val subshell : cmd:string -> string list
diff --git a/browser/viewer.ml b/browser/viewer.ml
new file mode 100644
index 0000000..7f13db1
--- /dev/null
+++ b/browser/viewer.ml
@@ -0,0 +1,648 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tk
+open Jg_tk
+open Mytypes
+open Longident
+open Types
+open Typedtree
+open Env
+open Searchpos
+open Searchid
+
+(* Managing the module list *)
+
+let list_modules ~path =
+ List.fold_left path ~init:[] ~f:
+ begin fun modules dir ->
+ let l =
+ List.filter (Useunix.get_files_in_directory dir)
+ ~f:(fun x -> Filename.check_suffix x ".cmi") in
+ let l = List.map l ~f:
+ begin fun x ->
+ String.capitalize_ascii (Filename.chop_suffix x ".cmi")
+ end in
+ List.fold_left l ~init:modules
+ ~f:(fun modules item ->
+ if List.mem item modules then modules else item :: modules)
+ end
+
+let reset_modules box =
+ Listbox.delete box ~first:(`Num 0) ~last:`End;
+ module_list := List.sort (Jg_completion.compare_string ~nocase:true)
+ (list_modules ~path:!Config.load_path);
+ Listbox.insert box ~index:`End ~texts:!module_list;
+ Jg_box.recenter box ~index:(`Num 0)
+
+
+(* How to display a symbol *)
+
+let view_symbol ~kind ~env ?path id =
+ let name = match id with
+ Lident x -> x
+ | Ldot (_, x) -> x
+ | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z"
+ in
+ match kind with
+ Pvalue ->
+ let path, vd = lookup_value id env in
+ view_signature_item ~path ~env [Sig_value (Ident.create name, vd)]
+ | Ptype -> view_type_id id ~env
+ | Plabel -> let ld = lookup_label id env in
+ begin match ld.lbl_res.desc with
+ Tconstr (path, _, _) -> view_type_decl path ~env
+ | _ -> ()
+ end
+ | Pconstructor ->
+ let cd = lookup_constructor id env in
+ begin match cd.cstr_tag, cd.cstr_res.desc with
+ Cstr_extension _, Tconstr (cpath, args, _) ->
+ view_signature ~title:(string_of_longident id) ~env ?path
+ [Sig_typext (Ident.create name,
+ {Types.ext_type_path = cpath;
+ ext_type_params = args;
+ ext_args = Cstr_tuple cd.cstr_args;
+ ext_ret_type = (if cd.cstr_generalized
+ then Some cd.cstr_res else None);
+ ext_private = cd.cstr_private;
+ ext_loc = cd.cstr_loc;
+ ext_attributes = cd.cstr_attributes},
+ if Path.same cpath Predef.path_exn then Text_exception
+ else Text_first)]
+ | _, Tconstr (cpath, _, _) ->
+ view_type_decl cpath ~env
+ | _ -> ()
+ end
+ | Pmodule -> view_module_id id ~env
+ | Pmodtype -> view_modtype_id id ~env
+ | Pclass -> view_class_id id ~env
+ | Pcltype -> view_cltype_id id ~env
+
+
+(* Create a list of symbols you can choose from *)
+
+let choose_symbol ~title ~env ?signature ?path l =
+ if match path with
+ None -> false
+ | Some path -> is_shown_module path
+ then () else
+ let tl = Jg_toplevel.titled title in
+ Jg_bind.escape_destroy tl;
+ top_widgets := coe tl :: !top_widgets;
+ let buttons = Frame.create tl in
+ let all = Button.create buttons ~text:"Show all" ~padx:20
+ and ok = Jg_button.create_destroyer tl ~parent:buttons
+ and detach = Button.create buttons ~text:"Detach"
+ and edit = Button.create buttons ~text:"Impl"
+ and intf = Button.create buttons ~text:"Intf" in
+ let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
+ let nl = List.map l ~f:
+ begin fun (li, k) ->
+ string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
+ end in
+ let fb = Frame.create tl in
+ let box =
+ new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in
+ box#init;
+ box#bind_kbd ~events:[`KeyPressDetail"Escape"]
+ ~action:(fun _ ~index -> destroy tl; break ());
+ if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box);
+ Jg_multibox.add_completion box ~action:
+ begin fun pos ->
+ let li, k = List.nth l pos in
+ let path =
+ match path, li with
+ None, Ldot (lip, _) ->
+ begin try
+ Some (lookup_module ~load:true lip env)
+ with Not_found -> None
+ end
+ | _ -> path
+ in view_symbol li ~kind:k ~env ?path
+ end;
+ pack [buttons] ~side:`Bottom ~fill:`X;
+ pack [fb] ~side:`Top ~fill:`Both ~expand:true;
+ begin match signature with
+ None -> pack [ok] ~fill:`X ~expand:true
+ | Some signature ->
+ Button.configure all ~command:
+ begin fun () ->
+ view_signature signature ~title ~env ?path
+ end;
+ pack [ok; all] ~side:`Right ~fill:`X ~expand:true
+ end;
+ begin match path with None -> ()
+ | Some path ->
+ let frame = Frame.create tl in
+ pack [frame] ~side:`Bottom ~fill:`X;
+ add_shown_module path
+ ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach;
+ mw_edit = edit; mw_intf = intf }
+ end
+
+let choose_symbol_ref = ref choose_symbol
+
+
+(* Search, both by type and name *)
+
+let guess_search_mode s : [`Type | `Long | `Pattern] =
+ let is_type = ref false and is_long = ref false in
+ for i = 0 to String.length s - 2 do
+ if s.[i] = '-' && s.[i+1] = '>' then is_type := true;
+ if s.[i] = '.' then is_long := true
+ done;
+ if !is_type then `Type else if !is_long then `Long else `Pattern
+
+
+let search_string ?(mode="symbol") ew =
+ let text = Entry.get ew in
+ try
+ if text = "" then () else
+ let l = match mode with
+ "Name" ->
+ begin match guess_search_mode text with
+ `Long -> search_string_symbol text
+ | `Pattern -> search_pattern_symbol text
+ | `Type -> search_string_type text ~mode:`Included
+ end
+ | "Type" -> search_string_type text ~mode:`Included
+ | "Exact" -> search_string_type text ~mode:`Exact
+ | _ -> assert false
+ in
+ match l with [] -> ()
+ | [lid,kind] -> view_symbol lid ~kind ~env:!start_env
+ | l -> choose_symbol ~title:"Choose symbol" ~env:!start_env l
+ with Searchid.Error (s,e) ->
+ Entry.icursor ew ~index:(`Num s)
+
+let search_which = ref "Name"
+
+let search_symbol () =
+ if !module_list = [] then
+ module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path);
+ let tl = Jg_toplevel.titled "Search symbol" in
+ Jg_bind.escape_destroy tl;
+ let ew = Entry.create tl ~width:30 in
+ let choice = Frame.create tl
+ and which = Textvariable.create ~on:tl () in
+ let itself = Radiobutton.create choice ~text:"Itself"
+ ~variable:which ~value:"Name"
+ and extype = Radiobutton.create choice ~text:"Exact type"
+ ~variable:which ~value:"Exact"
+ and iotype = Radiobutton.create choice ~text:"Included type"
+ ~variable:which ~value:"Type"
+ and buttons = Frame.create tl in
+ let search = Button.create buttons ~text:"Search" ~command:
+ begin fun () ->
+ search_which := Textvariable.get which;
+ search_string ew ~mode:!search_which
+ end
+ and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
+
+ Focus.set ew;
+ Jg_bind.return_invoke ew ~button:search;
+ Textvariable.set which !search_which;
+ pack [itself; extype; iotype] ~side:`Left ~anchor:`W;
+ pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
+ pack [coe ew; coe choice; coe buttons]
+ ~side:`Top ~fill:`X ~expand:true
+
+
+(* Display the contents of a module *)
+
+let ident_of_decl ~modlid = function
+ Sig_value (id, _) -> Lident (Ident.name id), Pvalue
+ | Sig_type (id, _, _) -> Lident (Ident.name id), Ptype
+ | Sig_typext (id, _, _) -> Ldot (modlid, Ident.name id), Pconstructor
+ | Sig_module (id, _, _) -> Lident (Ident.name id), Pmodule
+ | Sig_modtype (id, _) -> Lident (Ident.name id), Pmodtype
+ | Sig_class (id, _, _) -> Lident (Ident.name id), Pclass
+ | Sig_class_type (id, _, _) -> Lident (Ident.name id), Pcltype
+
+let view_defined ~env ?(show_all=false) modlid =
+ try match Typetexp.find_module env Location.none modlid with
+ path, {md_type=Mty_signature sign} ->
+ let rec iter_sign sign idents =
+ match sign with
+ [] -> List.rev idents
+ | decl :: rem ->
+ let rem = match decl, rem with
+ Sig_class _, cty :: ty1 :: ty2 :: rem -> rem
+ | Sig_class_type _, ty1 :: ty2 :: rem -> rem
+ | _, rem -> rem
+ in iter_sign rem (ident_of_decl ~modlid decl :: idents)
+ in
+ let l = iter_sign sign [] in
+ let title = string_of_path path in
+ let env =
+ match open_signature Asttypes.Fresh path env with None -> env
+ | Some env -> env
+ in
+ !choose_symbol_ref l ~title ~signature:sign ~env ~path;
+ if show_all then view_signature sign ~title ~env ~path
+ | _ -> ()
+ with Not_found -> ()
+ | Env.Error err ->
+ let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in
+ Env.report_error Format.std_formatter err;
+ finish ()
+ | Cmi_format.Error err ->
+ let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in
+ Cmi_format.report_error Format.std_formatter err;
+ finish ()
+
+
+(* Manage toplevel windows *)
+
+let close_all_views () =
+ List.iter !top_widgets
+ ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
+ top_widgets := []
+
+
+(* Launch a shell *)
+
+let shell_counter = ref 1
+let default_shell = ref "ocaml"
+
+let start_shell master =
+ let tl = Jg_toplevel.titled "Start New Shell" in
+ Wm.transient_set tl ~master;
+ let input = Frame.create tl
+ and buttons = Frame.create tl in
+ let ok = Button.create buttons ~text:"Ok"
+ and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
+ and labels = Frame.create input
+ and entries = Frame.create input in
+ let l1 = Label.create labels ~text:"Command:"
+ and l2 = Label.create labels ~text:"Title:"
+ and e1 =
+ Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
+ and e2 =
+ Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
+ and names = List.map ~f:fst (Shell.get_all ()) in
+ Entry.insert e1 ~index:`End ~text:!default_shell;
+ let shell_name () = "Shell #" ^ string_of_int !shell_counter in
+ while List.mem (shell_name ()) names do
+ incr shell_counter
+ done;
+ Entry.insert e2 ~index:`End ~text:(shell_name ());
+ Button.configure ok ~command:(fun () ->
+ if not (List.mem (Entry.get e2) names) then begin
+ default_shell := Entry.get e1;
+ Shell.f ~prog:!default_shell ~title:(Entry.get e2);
+ destroy tl
+ end);
+ pack [l1;l2] ~side:`Top ~anchor:`W;
+ pack [e1;e2] ~side:`Top ~fill:`X ~expand:true;
+ pack [labels;entries] ~side:`Left ~fill:`X ~expand:true;
+ pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
+ pack [input;buttons] ~side:`Top ~fill:`X ~expand:true
+
+
+(* Help window *)
+
+let show_help () =
+ let tl = Jg_toplevel.titled "OCamlBrowser Help" in
+ Jg_bind.escape_destroy tl;
+ let fw, tw, sb = Jg_text.create_with_scrollbar tl in
+ let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in
+ Text.insert tw ~index:tend ~text:Help.text;
+ Text.configure tw ~state:`Disabled;
+ Jg_bind.enter_focus tw;
+ pack [tw] ~side:`Left ~fill:`Both ~expand:true;
+ pack [sb] ~side:`Right ~fill:`Y;
+ pack [fw] ~side:`Top ~expand:true ~fill:`Both;
+ pack [ok] ~side:`Bottom ~fill:`X
+
+(* Launch the classical viewer *)
+
+let f ?(dir=Unix.getcwd()) ?on () =
+ let (top, tl) = match on with
+ None ->
+ let tl = Jg_toplevel.titled "Module viewer" in
+ ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
+ | Some top ->
+ Wm.title_set top "OCamlBrowser";
+ Wm.iconname_set top "OCamlBrowser";
+ let tl = Frame.create top in
+ bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
+ pack [tl] ~expand:true ~fill:`Both;
+ (top, coe tl)
+ in
+ let menus = Jg_menu.menubar top in
+ let filemenu = new Jg_menu.c "File" ~parent:menus
+ and modmenu = new Jg_menu.c "Modules" ~parent:menus in
+ let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in
+
+ Jg_box.add_completion mbox ~nocase:true ~action:
+ begin fun index ->
+ view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
+ end;
+ Setpath.add_update_hook (fun () -> reset_modules mbox);
+
+ let ew = Entry.create tl in
+ let buttons = Frame.create tl in
+ let search = Button.create buttons ~text:"Search" ~pady:1
+ ~command:(fun () -> search_string ew)
+ and close =
+ Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views
+ in
+ (* bindings *)
+ Jg_bind.enter_focus ew;
+ Jg_bind.return_invoke ew ~button:search;
+ bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~action:(fun _ -> destroy tl);
+
+ (* File menu *)
+ filemenu#add_command "Open..."
+ ~command:(fun () -> !editor_ref ~opendialog:true ());
+ filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
+ filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
+ filemenu#add_command "Quit" ~command:(fun () -> destroy tl);
+
+ (* modules menu *)
+ modmenu#add_command "Path editor..."
+ ~command:(fun () -> Setpath.set ~dir);
+ modmenu#add_command "Reset cache"
+ ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
+ modmenu#add_command "Search symbol..." ~command:search_symbol;
+
+ pack [close; search] ~fill:`X ~side:`Right ~expand:true;
+ pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom;
+ pack [msb] ~side:`Right ~fill:`Y;
+ pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
+ pack [fmbox] ~fill:`Both ~expand:true ~side:`Top;
+ reset_modules mbox
+
+(* Smalltalk-like version *)
+
+class st_viewer ?(dir=Unix.getcwd()) ?on () =
+ let (top, tl) = match on with
+ None ->
+ let tl = Jg_toplevel.titled "Module viewer" in
+ ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
+ | Some top ->
+ Wm.title_set top "OCamlBrowser";
+ Wm.iconname_set top "OCamlBrowser";
+ let tl = Frame.create top in
+ bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
+ pack [tl] ~side:`Bottom ~expand:true ~fill:`Both;
+ (top, coe tl)
+ in
+ let menus = Menu.create top ~name:"menubar" ~typ:`Menubar in
+ let () = Toplevel.configure top ~menu:menus in
+ let filemenu = new Jg_menu.c "File" ~parent:menus
+ and modmenu = new Jg_menu.c "Modules" ~parent:menus
+ and viewmenu = new Jg_menu.c "View" ~parent:menus
+ and helpmenu = new Jg_menu.c "Help" ~parent:menus in
+ let search_frame = Frame.create tl in
+ let boxes_frame = Frame.create tl ~name:"boxes" in
+ let label = Label.create tl ~anchor:`W ~padx:5 in
+ let view = Frame.create tl in
+ let buttons = Frame.create tl in
+ let _all = Button.create buttons ~text:"Show all" ~padx:20
+ and close = Button.create buttons ~text:"Close all" ~command:close_all_views
+ and detach = Button.create buttons ~text:"Detach"
+ and edit = Button.create buttons ~text:"Impl"
+ and intf = Button.create buttons ~text:"Intf" in
+object (self)
+ val mutable boxes = []
+ val mutable show_all = fun () -> ()
+
+ method create_box =
+ let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in
+ bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~action:(fun _ -> show_all ());
+ bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")]
+ ~action:(fun _ -> show_all ());
+ boxes <- boxes @ [fmbox, mbox];
+ pack [sb] ~side:`Right ~fill:`Y;
+ pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
+ pack [fmbox] ~side:`Left ~fill:`Both ~expand:true;
+ fmbox, mbox
+
+ initializer
+ (* Search *)
+ let ew = Entry.create search_frame
+ and searchtype = Textvariable.create ~on:tl () in
+ bind ew ~events:[`KeyPressDetail "Return"] ~action:
+ (fun _ -> search_string ew ~mode:(Textvariable.get searchtype));
+ Jg_bind.enter_focus ew;
+ let search_button ?value text =
+ Radiobutton.create search_frame
+ ~text ~variable:searchtype ~value:text in
+ let symbol = search_button "Name"
+ and atype = search_button "Type" in
+ Radiobutton.select symbol;
+ pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5;
+ pack [ew] ~fill:`X ~expand:true ~side:`Left;
+ pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5;
+ pack [symbol; atype] ~side:`Left;
+ pack [Label.create search_frame] ~side:`Right
+
+ initializer
+ (* Boxes *)
+ let fmbox, mbox = self#create_box in
+ Jg_box.add_completion mbox ~nocase:true ~double:false ~action:
+ begin fun index ->
+ view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
+ end;
+ Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1);
+ List.iter [1;2] ~f:(fun _ -> ignore self#create_box);
+ Searchpos.default_frame := Some
+ { mw_frame = view; mw_title = Some label;
+ mw_detach = detach; mw_edit = edit; mw_intf = intf };
+ Searchpos.set_path := self#set_path;
+
+ (* Buttons *)
+ pack [close] ~side:`Right ~fill:`X ~expand:true;
+ bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~action:(fun _ -> destroy tl);
+
+ (* File menu *)
+ filemenu#add_command "Open..."
+ ~command:(fun () -> !editor_ref ~opendialog:true ());
+ filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
+ filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
+ filemenu#add_command "Quit" ~command:(fun () -> destroy tl);
+
+ (* View menu *)
+ viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ());
+ let show_search = Textvariable.create ~on:tl () in
+ Textvariable.set show_search "1";
+ Menu.add_checkbutton viewmenu#menu ~label:"Search Entry"
+ ~variable:show_search ~indicatoron:true ~state:`Active
+ ~command:
+ begin fun () ->
+ let v = Textvariable.get show_search in
+ if v = "1" then begin
+ pack [search_frame] ~after:menus ~fill:`X
+ end else Pack.forget [search_frame]
+ end;
+
+ (* modules menu *)
+ modmenu#add_command "Path editor..."
+ ~command:(fun () -> Setpath.set ~dir);
+ modmenu#add_command "Reset cache"
+ ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
+ modmenu#add_command "Search symbol..." ~command:search_symbol;
+
+ (* Help menu *)
+ helpmenu#add_command "Manual..." ~command:show_help;
+
+ pack [search_frame] ~fill:`X;
+ pack [boxes_frame] ~fill:`Both ~expand:true;
+ pack [buttons] ~fill:`X ~side:`Bottom;
+ pack [view] ~fill:`Both ~side:`Bottom ~expand:true;
+ reset_modules mbox
+
+ val mutable shown_paths = []
+
+ method hide_after n =
+ for i = n to List.length boxes - 1 do
+ let fm, box = List.nth boxes i in
+ if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
+ else destroy fm
+ done;
+ let rec firsts n = function [] -> []
+ | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
+ shown_paths <- firsts (n-1) shown_paths;
+ boxes <- firsts (max 3 n) boxes
+
+ method get_box ~path =
+ let rec path_index p = function
+ [] -> raise Not_found
+ | a :: l -> if Path.same p a then 1 else path_index p l + 1 in
+ try
+ let n = path_index path shown_paths in
+ self#hide_after (n+1);
+ n
+ with Not_found ->
+ match path with
+ Path.Pdot (path', _, _) ->
+ let n = self#get_box ~path:path' in
+ shown_paths <- shown_paths @ [path];
+ if n + 1 >= List.length boxes then ignore self#create_box;
+ n+1
+ | _ ->
+ self#hide_after 2;
+ shown_paths <- [path];
+ 1
+
+ method set_path path ~sign =
+ let rec path_elems l path =
+ match path with
+ Path.Pdot (path, _, _) -> path_elems (path::l) path
+ | _ -> []
+ in
+ let path_elems path =
+ match path with
+ | Path.Pident _ -> [path]
+ | _ -> path_elems [] path
+ in
+ let see_path ~box:n ?(sign=[]) path =
+ let (_, box) = List.nth boxes n in
+ let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in
+ let rec index s = function
+ [] -> raise Not_found
+ | a :: l -> if a = s then 0 else 1 + index s l
+ in
+ try
+ let modlid, s =
+ match path with
+ Path.Pdot (p, s, _) -> longident_of_path p, s
+ | Path.Pident i -> Longident.Lident "M", Ident.name i
+ | _ -> assert false
+ in
+ let li, k =
+ if sign = [] then Longident.Lident s, Pmodule else
+ ident_of_decl ~modlid (List.hd sign) in
+ let s =
+ if n = 0 then string_of_longident li else
+ string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in
+ let n = index s texts in
+ Listbox.see box (`Num n);
+ Listbox.activate box (`Num n)
+ with Not_found -> ()
+ in
+ let l = path_elems path in
+ if l <> [] then begin
+ List.iter l ~f:
+ begin fun path ->
+ if not (List.mem path shown_paths) then
+ view_symbol (longident_of_path path) ~kind:Pmodule
+ ~env:!start_env ~path;
+ let n = self#get_box path - 1 in
+ see_path path ~box:n
+ end;
+ see_path path ~box:(self#get_box path) ~sign
+ end
+
+ method choose_symbol ~title ~env ?signature ?path l =
+ let n =
+ match path with None -> 1
+ | Some path -> self#get_box ~path
+ in
+ let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
+ let nl = List.map l ~f:
+ begin fun (li, k) ->
+ string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
+ end in
+ let _, box = List.nth boxes n in
+ Listbox.delete box ~first:(`Num 0) ~last:`End;
+ Listbox.insert box ~index:`End ~texts:nl;
+
+ let current = ref None in
+ let display index =
+ let `Num pos = Listbox.index box ~index in
+ try
+ let li, k = try List.nth l pos with Failure _ -> raise Exit in
+ self#hide_after (n+1);
+ if !current = Some (li,k) then () else
+ let path =
+ match path, li with
+ None, Ldot (lip, _) ->
+ begin try
+ Some (lookup_module ~load:true lip env)
+ with Not_found -> None
+ end
+ | _ -> path
+ in
+ current := Some (li,k);
+ view_symbol li ~kind:k ~env ?path
+ with Exit -> ()
+ in
+ Jg_box.add_completion box ~double:false ~action:display;
+ bind box ~events:[`KeyRelease] ~fields:[`Char]
+ ~action:(fun ev -> display `Active);
+
+ begin match signature with
+ None -> ()
+ | Some signature ->
+ show_all <-
+ begin fun () ->
+ current := None;
+ view_signature signature ~title ~env ?path
+ end
+ end
+end
+
+let st_viewer ?dir ?on () =
+ let viewer = new st_viewer ?dir ?on () in
+ choose_symbol_ref := viewer#choose_symbol
diff --git a/browser/viewer.mli b/browser/viewer.mli
new file mode 100644
index 0000000..c56c5e4
--- /dev/null
+++ b/browser/viewer.mli
@@ -0,0 +1,31 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+(* Module viewer *)
+open Widget
+
+val search_symbol : unit -> unit
+ (* search a symbol in all modules in the path *)
+
+val f : ?dir:string -> ?on:toplevel widget -> unit -> unit
+ (* open then module viewer *)
+val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit
+ (* one-box viewer *)
+
+val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit
+ (* displays a signature, found in environment *)
+
+val close_all_views : unit -> unit
diff --git a/browser/winmain.c b/browser/winmain.c
new file mode 100644
index 0000000..4dd0644
--- /dev/null
+++ b/browser/winmain.c
@@ -0,0 +1,40 @@
+/*************************************************************************/
+/* */
+/* OCaml LablTk library */
+/* */
+/* Jacques Garrigue, Kyoto University RIMS */
+/* */
+/* Copyright 2001 Institut National de Recherche en Informatique et */
+/* en Automatique and Kyoto University. All rights reserved. */
+/* This file is distributed under the terms of the GNU Library */
+/* General Public License, with the special exception on linking */
+/* described in file ../../../LICENSE. */
+/* */
+/*************************************************************************/
+
+/* $Id$ */
+
+#include
+#include
+#include
+#include
+
+/*CAMLextern int __argc; */
+/* CAMLextern char **__argv; */
+/* CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); */
+/* extern void caml_main (char **); */
+
+int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance,
+ LPSTR lpCmdLine, int nCmdShow)
+{
+ char exe_name[1024];
+ char * argv[2];
+
+ GetModuleFileName(NULL, exe_name, sizeof(exe_name) - 1);
+ exe_name[sizeof(exe_name) - 1] = '0';
+ argv[0] = exe_name;
+ argv[1] = NULL;
+ caml_main(argv);
+ sys_exit(Val_int(0));
+ return 0;
+}
diff --git a/builtin/LICENSE b/builtin/LICENSE
new file mode 100644
index 0000000..dbad5f1
--- /dev/null
+++ b/builtin/LICENSE
@@ -0,0 +1,19 @@
+(*************************************************************************)
+(* *)
+(* OCaml LablTk library *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 1999 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../../../LICENSE. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+All the files in this directory are subject to the above copyright notice.
diff --git a/builtin/builtin_FilePattern.ml b/builtin/builtin_FilePattern.ml
new file mode 100644
index 0000000..ea77ff9
--- /dev/null
+++ b/builtin/builtin_FilePattern.ml
@@ -0,0 +1,20 @@
+(* File patterns *)
+(* type *)
+type filePattern = {
+ typename : string;
+ extensions : string list;
+ mactypes : string list
+ }
+(* /type *)
+
+let cCAMLtoTKfilePattern fp =
+ let typename = TkQuote (TkToken fp.typename) in
+ let extensions =
+ TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in
+ let mactypes =
+ match fp.mactypes with
+ | [] -> []
+ | [s] -> [TkToken s]
+ | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))]
+ in
+ TkQuote (TkTokenList (typename :: extensions :: mactypes))
diff --git a/builtin/builtin_GetBitmap.ml b/builtin/builtin_GetBitmap.ml
new file mode 100644
index 0000000..bf02d20
--- /dev/null
+++ b/builtin/builtin_GetBitmap.ml
@@ -0,0 +1,22 @@
+(* Tk_GetBitmap emulation *)
+
+##ifdef CAMLTK
+
+(* type *)
+type bitmap =
+ | BitmapFile of string (* path of file *)
+ | Predefined of string (* bitmap name *)
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type bitmap = [
+ | `File of string (* path of file *)
+ | `Predefined of string (* bitmap name *)
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_GetCursor.ml b/builtin/builtin_GetCursor.ml
new file mode 100644
index 0000000..4f7f663
--- /dev/null
+++ b/builtin/builtin_GetCursor.ml
@@ -0,0 +1,60 @@
+(* Color *)
+
+##ifdef CAMLTK
+
+(* type *)
+type color =
+ | NamedColor of string
+ | Black (* tk keyword: black *)
+ | White (* tk keyword: white *)
+ | Red (* tk keyword: red *)
+ | Green (* tk keyword: green *)
+ | Blue (* tk keyword: blue *)
+ | Yellow (* tk keyword: yellow *)
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type color = [
+ | `Color of string
+ | `Black (* tk keyword: black *)
+ | `White (* tk keyword: white *)
+ | `Red (* tk keyword: red *)
+ | `Green (* tk keyword: green *)
+ | `Blue (* tk keyword: blue *)
+ | `Yellow (* tk keyword: yellow *)
+]
+;;
+(* /type *)
+
+##endif
+
+##ifdef CAMLTK
+
+(* type *)
+type cursor =
+ | XCursor of string
+ | XCursorFg of string * color
+ | XCursortFgBg of string * color * color
+ | CursorFileFg of string * color
+ | CursorMaskFile of string * string * color * color
+;;
+(* /type *)
+
+##else
+
+(* Tk_GetCursor emulation *)
+(* type *)
+type cursor = [
+ | `Xcursor of string
+ | `Xcursorfg of string * color
+ | `Xcursorfgbg of string * color * color
+ | `Cursorfilefg of string * color
+ | `Cursormaskfile of string * string * color * color
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_GetPixel.ml b/builtin/builtin_GetPixel.ml
new file mode 100644
index 0000000..772a2c2
--- /dev/null
+++ b/builtin/builtin_GetPixel.ml
@@ -0,0 +1,28 @@
+(* Tk_GetPixels emulation *)
+
+##ifdef CAMLTK
+
+(* type *)
+type units =
+ | Pixels of int (* specified as floating-point, but inconvenient *)
+ | Centimeters of float
+ | Inches of float
+ | Millimeters of float
+ | PrinterPoint of float
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type units = [
+ | `Pix of int
+ | `Cm of float
+ | `In of float
+ | `Mm of float
+ | `Pt of float
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_ScrollValue.ml b/builtin/builtin_ScrollValue.ml
new file mode 100644
index 0000000..75a509e
--- /dev/null
+++ b/builtin/builtin_ScrollValue.ml
@@ -0,0 +1,22 @@
+##ifdef CAMLTK
+
+(* type *)
+type scrollValue =
+ | ScrollPage of int (* tk option: scroll page *)
+ | ScrollUnit of int (* tk option: scroll unit *)
+ | MoveTo of float (* tk option: moveto *)
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type scrollValue = [
+ | `Page of int (* tk option: scroll page *)
+ | `Unit of int (* tk option: scroll unit *)
+ | `Moveto of float (* tk option: moveto *)
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_bind.ml b/builtin/builtin_bind.ml
new file mode 100644
index 0000000..752a4ba
--- /dev/null
+++ b/builtin/builtin_bind.ml
@@ -0,0 +1,469 @@
+##ifdef CAMLTK
+
+open Widget;;
+
+(* Events and bindings *)
+(* Builtin types *)
+(* type *)
+type xEvent =
+ | Activate
+ | ButtonPress (* also Button, but we omit it *)
+ | ButtonPressDetail of int
+ | ButtonRelease
+ | ButtonReleaseDetail of int
+ | Circulate
+ | ColorMap (* not Colormap, avoiding confusion between the Colormap option *)
+ | Configure
+ | Deactivate
+ | Destroy
+ | Enter
+ | Expose
+ | FocusIn
+ | FocusOut
+ | Gravity
+ | KeyPress (* also Key, but we omit it *)
+ | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *)
+ | KeyRelease
+ | KeyReleaseDetail of string
+ | Leave
+ | Map
+ | Motion
+ | Property
+ | Reparent
+ | Unmap
+ | Visibility
+ | Virtual of string (* Virtual event. Must be without modifiers *)
+;;
+(* /type *)
+
+(* type *)
+type modifier =
+ | Control
+ | Shift
+ | Lock
+ | Button1
+ | Button2
+ | Button3
+ | Button4
+ | Button5
+ | Double
+ | Triple
+ | Mod1
+ | Mod2
+ | Mod3
+ | Mod4
+ | Mod5
+ | Meta
+ | Alt
+;;
+(* /type *)
+
+(* Event structure, passed to bounded functions *)
+
+(* type *)
+type eventInfo =
+ {
+ (* %# : event serial number is unsupported *)
+ mutable ev_Above : int; (* tk: %a *)
+ mutable ev_ButtonNumber : int; (* tk: %b *)
+ mutable ev_Count : int; (* tk: %c *)
+ mutable ev_Detail : string; (* tk: %d *)
+ mutable ev_Focus : bool; (* tk: %f *)
+ mutable ev_Height : int; (* tk: %h *)
+ mutable ev_KeyCode : int; (* tk: %k *)
+ mutable ev_Mode : string; (* tk: %m *)
+ mutable ev_OverrideRedirect : bool; (* tk: %o *)
+ mutable ev_Place : string; (* tk: %p *)
+ mutable ev_State : string; (* tk: %s *)
+ mutable ev_Time : int; (* tk: %t *)
+ mutable ev_Width : int; (* tk: %w *)
+ mutable ev_MouseX : int; (* tk: %x *)
+ mutable ev_MouseY : int; (* tk: %y *)
+ mutable ev_Char : string; (* tk: %A *)
+ mutable ev_BorderWidth : int; (* tk: %B *)
+ mutable ev_SendEvent : bool; (* tk: %E *)
+ mutable ev_KeySymString : string; (* tk: %K *)
+ mutable ev_KeySymInt : int; (* tk: %N *)
+ mutable ev_RootWindow : int; (* tk: %R *)
+ mutable ev_SubWindow : int; (* tk: %S *)
+ mutable ev_Type : int; (* tk: %T *)
+ mutable ev_Widget : widget; (* tk: %W *)
+ mutable ev_RootX : int; (* tk: %X *)
+ mutable ev_RootY : int (* tk: %Y *)
+ }
+;;
+(* /type *)
+
+
+(* To avoid collision with other constructors (Width, State),
+ use Ev_ prefix *)
+(* type *)
+type eventField =
+ | Ev_Above
+ | Ev_ButtonNumber
+ | Ev_Count
+ | Ev_Detail
+ | Ev_Focus
+ | Ev_Height
+ | Ev_KeyCode
+ | Ev_Mode
+ | Ev_OverrideRedirect
+ | Ev_Place
+ | Ev_State
+ | Ev_Time
+ | Ev_Width
+ | Ev_MouseX
+ | Ev_MouseY
+ | Ev_Char
+ | Ev_BorderWidth
+ | Ev_SendEvent
+ | Ev_KeySymString
+ | Ev_KeySymInt
+ | Ev_RootWindow
+ | Ev_SubWindow
+ | Ev_Type
+ | Ev_Widget
+ | Ev_RootX
+ | Ev_RootY
+;;
+(* /type *)
+
+let filleventInfo ev v = function
+ | Ev_Above -> ev.ev_Above <- int_of_string v
+ | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v
+ | Ev_Count -> ev.ev_Count <- int_of_string v
+ | Ev_Detail -> ev.ev_Detail <- v
+ | Ev_Focus -> ev.ev_Focus <- v = "1"
+ | Ev_Height -> ev.ev_Height <- int_of_string v
+ | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v
+ | Ev_Mode -> ev.ev_Mode <- v
+ | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
+ | Ev_Place -> ev.ev_Place <- v
+ | Ev_State -> ev.ev_State <- v
+ | Ev_Time -> ev.ev_Time <- int_of_string v
+ | Ev_Width -> ev.ev_Width <- int_of_string v
+ | Ev_MouseX -> ev.ev_MouseX <- int_of_string v
+ | Ev_MouseY -> ev.ev_MouseY <- int_of_string v
+ | Ev_Char -> ev.ev_Char <- v
+ | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v
+ | Ev_SendEvent -> ev.ev_SendEvent <- v = "1"
+ | Ev_KeySymString -> ev.ev_KeySymString <- v
+ | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v
+ | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v
+ | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v
+ | Ev_Type -> ev.ev_Type <- int_of_string v
+ | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v
+ | Ev_RootX -> ev.ev_RootX <- int_of_string v
+ | Ev_RootY -> ev.ev_RootY <- int_of_string v
+;;
+
+let wrapeventInfo f what =
+ let ev = {
+ ev_Above = 0;
+ ev_ButtonNumber = 0;
+ ev_Count = 0;
+ ev_Detail = "";
+ ev_Focus = false;
+ ev_Height = 0;
+ ev_KeyCode = 0;
+ ev_Mode = "";
+ ev_OverrideRedirect = false;
+ ev_Place = "";
+ ev_State = "";
+ ev_Time = 0;
+ ev_Width = 0;
+ ev_MouseX = 0;
+ ev_MouseY = 0;
+ ev_Char = "";
+ ev_BorderWidth = 0;
+ ev_SendEvent = false;
+ ev_KeySymString = "";
+ ev_KeySymInt = 0;
+ ev_RootWindow = 0;
+ ev_SubWindow = 0;
+ ev_Type = 0;
+ ev_Widget = Widget.default_toplevel;
+ ev_RootX = 0;
+ ev_RootY = 0 } in
+ function args ->
+ let l = ref args in
+ List.iter (function field ->
+ match !l with
+ [] -> ()
+ | v::rest -> filleventInfo ev v field; l:=rest)
+ what;
+ f ev
+;;
+
+let rec writeeventField = function
+ | [] -> ""
+ | field::rest ->
+ begin
+ match field with
+ | Ev_Above -> " %a"
+ | Ev_ButtonNumber ->" %b"
+ | Ev_Count -> " %c"
+ | Ev_Detail -> " %d"
+ | Ev_Focus -> " %f"
+ | Ev_Height -> " %h"
+ | Ev_KeyCode -> " %k"
+ | Ev_Mode -> " %m"
+ | Ev_OverrideRedirect -> " %o"
+ | Ev_Place -> " %p"
+ | Ev_State -> " %s"
+ | Ev_Time -> " %t"
+ | Ev_Width -> " %w"
+ | Ev_MouseX -> " %x"
+ | Ev_MouseY -> " %y"
+ (* Quoting is done by Tk *)
+ | Ev_Char -> " %A"
+ | Ev_BorderWidth -> " %B"
+ | Ev_SendEvent -> " %E"
+ | Ev_KeySymString -> " %K"
+ | Ev_KeySymInt -> " %N"
+ | Ev_RootWindow ->" %R"
+ | Ev_SubWindow -> " %S"
+ | Ev_Type -> " %T"
+ | Ev_Widget ->" %W"
+ | Ev_RootX -> " %X"
+ | Ev_RootY -> " %Y"
+ end
+ ^ writeeventField rest
+;;
+
+##else
+
+open Widget;;
+
+(* Events and bindings *)
+(* Builtin types *)
+
+(* type *)
+type event = [
+ | `Activate
+ | `ButtonPress (* also Button, but we omit it *)
+ | `ButtonPressDetail of int
+ | `ButtonRelease
+ | `ButtonReleaseDetail of int
+ | `Circulate
+ | `Colormap
+ | `Configure
+ | `Deactivate
+ | `Destroy
+ | `Enter
+ | `Expose
+ | `FocusIn
+ | `FocusOut
+ | `Gravity
+ | `KeyPress (* also Key, but we omit it *)
+ | `KeyPressDetail of string (* /usr/include/X11/keysymdef.h *)
+ | `KeyRelease
+ | `KeyReleaseDetail of string
+ | `Leave
+ | `Map
+ | `Motion
+ | `Property
+ | `Reparent
+ | `Unmap
+ | `Visibility
+ | `Virtual of string (* Virtual event. Must be without modifiers *)
+ | `Modified of modifier list * event
+]
+
+and modifier = [
+ | `Control
+ | `Shift
+ | `Lock
+ | `Button1
+ | `Button2
+ | `Button3
+ | `Button4
+ | `Button5
+ | `Double
+ | `Triple
+ | `Mod1
+ | `Mod2
+ | `Mod3
+ | `Mod4
+ | `Mod5
+ | `Meta
+ | `Alt
+]
+;;
+(* /type *)
+
+(* Event structure, passed to bounded functions *)
+
+(* type *)
+type eventInfo = {
+ (* %# : event serial number is unsupported *)
+ mutable ev_Above : int; (* tk: %a *)
+ mutable ev_ButtonNumber : int; (* tk: %b *)
+ mutable ev_Count : int; (* tk: %c *)
+ mutable ev_Detail : string; (* tk: %d *)
+ mutable ev_Focus : bool; (* tk: %f *)
+ mutable ev_Height : int; (* tk: %h *)
+ mutable ev_KeyCode : int; (* tk: %k *)
+ mutable ev_Mode : string; (* tk: %m *)
+ mutable ev_OverrideRedirect : bool; (* tk: %o *)
+ mutable ev_Place : string; (* tk: %p *)
+ mutable ev_State : string; (* tk: %s *)
+ mutable ev_Time : int; (* tk: %t *)
+ mutable ev_Width : int; (* tk: %w *)
+ mutable ev_MouseX : int; (* tk: %x *)
+ mutable ev_MouseY : int; (* tk: %y *)
+ mutable ev_Char : string; (* tk: %A *)
+ mutable ev_BorderWidth : int; (* tk: %B *)
+ mutable ev_SendEvent : bool; (* tk: %E *)
+ mutable ev_KeySymString : string; (* tk: %K *)
+ mutable ev_KeySymInt : int; (* tk: %N *)
+ mutable ev_RootWindow : int; (* tk: %R *)
+ mutable ev_SubWindow : int; (* tk: %S *)
+ mutable ev_Type : int; (* tk: %T *)
+ mutable ev_Widget : any widget; (* tk: %W *)
+ mutable ev_RootX : int; (* tk: %X *)
+ mutable ev_RootY : int (* tk: %Y *)
+ }
+;;
+(* /type *)
+
+
+(* To avoid collision with other constructors (Width, State),
+ use Ev_ prefix *)
+(* type *)
+type eventField = [
+ | `Above
+ | `ButtonNumber
+ | `Count
+ | `Detail
+ | `Focus
+ | `Height
+ | `KeyCode
+ | `Mode
+ | `OverrideRedirect
+ | `Place
+ | `State
+ | `Time
+ | `Width
+ | `MouseX
+ | `MouseY
+ | `Char
+ | `BorderWidth
+ | `SendEvent
+ | `KeySymString
+ | `KeySymInt
+ | `RootWindow
+ | `SubWindow
+ | `Type
+ | `Widget
+ | `RootX
+ | `RootY
+]
+;;
+(* /type *)
+
+let filleventInfo ev v : eventField -> unit = function
+ | `Above -> ev.ev_Above <- int_of_string v
+ | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v
+ | `Count -> ev.ev_Count <- int_of_string v
+ | `Detail -> ev.ev_Detail <- v
+ | `Focus -> ev.ev_Focus <- v = "1"
+ | `Height -> ev.ev_Height <- int_of_string v
+ | `KeyCode -> ev.ev_KeyCode <- int_of_string v
+ | `Mode -> ev.ev_Mode <- v
+ | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
+ | `Place -> ev.ev_Place <- v
+ | `State -> ev.ev_State <- v
+ | `Time -> ev.ev_Time <- int_of_string v
+ | `Width -> ev.ev_Width <- int_of_string v
+ | `MouseX -> ev.ev_MouseX <- int_of_string v
+ | `MouseY -> ev.ev_MouseY <- int_of_string v
+ | `Char -> ev.ev_Char <- v
+ | `BorderWidth -> ev.ev_BorderWidth <- int_of_string v
+ | `SendEvent -> ev.ev_SendEvent <- v = "1"
+ | `KeySymString -> ev.ev_KeySymString <- v
+ | `KeySymInt -> ev.ev_KeySymInt <- int_of_string v
+ | `RootWindow -> ev.ev_RootWindow <- int_of_string v
+ | `SubWindow -> ev.ev_SubWindow <- int_of_string v
+ | `Type -> ev.ev_Type <- int_of_string v
+ | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v
+ | `RootX -> ev.ev_RootX <- int_of_string v
+ | `RootY -> ev.ev_RootY <- int_of_string v
+;;
+
+let wrapeventInfo f (what : eventField list) =
+ let ev = {
+ ev_Above = 0;
+ ev_ButtonNumber = 0;
+ ev_Count = 0;
+ ev_Detail = "";
+ ev_Focus = false;
+ ev_Height = 0;
+ ev_KeyCode = 0;
+ ev_Mode = "";
+ ev_OverrideRedirect = false;
+ ev_Place = "";
+ ev_State = "";
+ ev_Time = 0;
+ ev_Width = 0;
+ ev_MouseX = 0;
+ ev_MouseY = 0;
+ ev_Char = "";
+ ev_BorderWidth = 0;
+ ev_SendEvent = false;
+ ev_KeySymString = "";
+ ev_KeySymInt = 0;
+ ev_RootWindow = 0;
+ ev_SubWindow = 0;
+ ev_Type = 0;
+ ev_Widget = forget_type default_toplevel;
+ ev_RootX = 0;
+ ev_RootY = 0 } in
+ function args ->
+ let l = ref args in
+ List.iter what ~f:
+ begin fun field ->
+ match !l with
+ | [] -> ()
+ | v :: rest -> filleventInfo ev v field; l := rest
+ end;
+ f ev
+;;
+
+let rec writeeventField : eventField list -> string = function
+ | [] -> ""
+ | field :: rest ->
+ begin
+ match field with
+ | `Above -> " %a"
+ | `ButtonNumber ->" %b"
+ | `Count -> " %c"
+ | `Detail -> " %d"
+ | `Focus -> " %f"
+ | `Height -> " %h"
+ | `KeyCode -> " %k"
+ | `Mode -> " %m"
+ | `OverrideRedirect -> " %o"
+ | `Place -> " %p"
+ | `State -> " %s"
+ | `Time -> " %t"
+ | `Width -> " %w"
+ | `MouseX -> " %x"
+ | `MouseY -> " %y"
+ (* Quoting is done by Tk *)
+ | `Char -> " %A"
+ | `BorderWidth -> " %B"
+ | `SendEvent -> " %E"
+ | `KeySymString -> " %K"
+ | `KeySymInt -> " %N"
+ | `RootWindow ->" %R"
+ | `SubWindow -> " %S"
+ | `Type -> " %T"
+ | `Widget -> " %W"
+ | `RootX -> " %X"
+ | `RootY -> " %Y"
+ end
+ ^ writeeventField rest
+;;
+
+##endif
diff --git a/builtin/builtin_bindtags.ml b/builtin/builtin_bindtags.ml
new file mode 100644
index 0000000..35b82b9
--- /dev/null
+++ b/builtin/builtin_bindtags.ml
@@ -0,0 +1,20 @@
+##ifdef CAMLTK
+
+(* type *)
+type bindings =
+ | TagBindings of string (* tk option: *)
+ | WidgetBindings of widget (* tk option: *)
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type bindings = [
+ | `Tag of string (* tk option: *)
+ | `Widget of any widget (* tk option: *)
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_font.ml b/builtin/builtin_font.ml
new file mode 100644
index 0000000..b865cda
--- /dev/null
+++ b/builtin/builtin_font.ml
@@ -0,0 +1,3 @@
+(* type *)
+type font = string
+(* /type *)
diff --git a/builtin/builtin_grab.ml b/builtin/builtin_grab.ml
new file mode 100644
index 0000000..2569268
--- /dev/null
+++ b/builtin/builtin_grab.ml
@@ -0,0 +1,3 @@
+(* type *)
+type grabGlobal = bool
+(* /type *)
diff --git a/builtin/builtin_index.ml b/builtin/builtin_index.ml
new file mode 100644
index 0000000..a42af55
--- /dev/null
+++ b/builtin/builtin_index.ml
@@ -0,0 +1,92 @@
+(* Various indexes
+ canvas
+ entry
+ listbox
+*)
+
+##ifdef CAMLTK
+
+(* A large type for all indices in all widgets *)
+(* a bit overkill though *)
+
+(* type *)
+type index =
+ | Number of int (* no keyword *)
+ | ActiveElement (* tk keyword: active *)
+ | End (* tk keyword: end *)
+ | Last (* tk keyword: last *)
+ | NoIndex (* tk keyword: none *)
+ | Insert (* tk keyword: insert *)
+ | SelFirst (* tk keyword: sel.first *)
+ | SelLast (* tk keyword: sel.last *)
+ | At of int (* tk keyword: @n *)
+ | AtXY of int * int (* tk keyword: @x,y *)
+ | AnchorPoint (* tk keyword: anchor *)
+ | Pattern of string (* no keyword *)
+ | LineChar of int * int (* tk keyword: l.c *)
+ | Mark of string (* no keyword *)
+ | TagFirst of string (* tk keyword: tag.first *)
+ | TagLast of string (* tk keyword: tag.last *)
+ | Embedded of widget (* no keyword *)
+;;
+(* /type *)
+
+##else
+
+type canvas_index = [
+ | `Num of int
+ | `End
+ | `Insert
+ | `Selfirst
+ | `Sellast
+ | `Atxy of int * int
+]
+;;
+
+type entry_index = [
+ | `Num of int
+ | `End
+ | `Insert
+ | `Selfirst
+ | `Sellast
+ | `At of int
+ | `Anchor
+]
+;;
+
+type listbox_index = [
+ | `Num of int
+ | `Active
+ | `Anchor
+ | `End
+ | `Atxy of int * int
+]
+;;
+
+type menu_index = [
+ | `Num of int
+ | `Active
+ | `End
+ | `Last
+ | `None
+ | `At of int
+ | `Pattern of string
+]
+;;
+
+type text_index = [
+ | `Linechar of int * int
+ | `Atxy of int * int
+ | `End
+ | `Mark of string
+ | `Tagfirst of string
+ | `Taglast of string
+ | `Window of any widget
+ | `Image of string
+]
+;;
+
+type linechar_index = int * int;;
+type num_index = int;;
+
+##endif
diff --git a/builtin/builtin_palette.ml b/builtin/builtin_palette.ml
new file mode 100644
index 0000000..4eab69a
--- /dev/null
+++ b/builtin/builtin_palette.ml
@@ -0,0 +1,20 @@
+##ifdef CAMLTK
+
+(* type *)
+type paletteType =
+ | GrayShades of int
+ | RGBShades of int * int * int
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type paletteType = [
+ | `Gray of int
+ | `Rgb of int * int * int
+]
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtin_text.ml b/builtin/builtin_text.ml
new file mode 100644
index 0000000..b2d6958
--- /dev/null
+++ b/builtin/builtin_text.ml
@@ -0,0 +1,50 @@
+(* Not a string as such, more like a symbol *)
+
+(* type *)
+type textMark = string;;
+(* /type *)
+
+(* type *)
+type textTag = string;;
+(* /type *)
+
+##ifdef CAMLTK
+
+(* type *)
+type textModifier =
+ | CharOffset of int (* tk keyword: +/- Xchars *)
+ | LineOffset of int (* tk keyword: +/- Xlines *)
+ | LineStart (* tk keyword: linestart *)
+ | LineEnd (* tk keyword: lineend *)
+ | WordStart (* tk keyword: wordstart *)
+ | WordEnd (* tk keyword: wordend *)
+;;
+(* /type *)
+
+(* type *)
+type textIndex =
+ | TextIndex of index * textModifier list
+ | TextIndexNone
+;;
+(* /type *)
+
+##else
+
+(* type *)
+type textModifier = [
+ | `Char of int (* tk keyword: +/- Xchars *)
+ | `Line of int (* tk keyword: +/- Xlines *)
+ | `Linestart (* tk keyword: linestart *)
+ | `Lineend (* tk keyword: lineend *)
+ | `Wordstart (* tk keyword: wordstart *)
+ | `Wordend (* tk keyword: wordend *)
+]
+;;
+(* /type *)
+
+(* type *)
+type textIndex = text_index * textModifier list
+;;
+(* /type *)
+
+##endif
diff --git a/builtin/builtina_empty.ml b/builtin/builtina_empty.ml
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/builtin/builtina_empty.ml
diff --git a/builtin/builtinf_GetPixel.ml b/builtin/builtinf_GetPixel.ml
new file mode 100644
index 0000000..45294d5
--- /dev/null
+++ b/builtin/builtinf_GetPixel.ml
@@ -0,0 +1,23 @@
+##ifdef CAMLTK
+
+let pixels units =
+ let res =
+ tkEval
+ [|TkToken"winfo";
+ TkToken"pixels";
+ cCAMLtoTKwidget widget_any_table default_toplevel;
+ cCAMLtoTKunits units|] in
+ int_of_string res
+
+##else
+
+let pixels units =
+ let res =
+ tkEval
+ [|TkToken"winfo";
+ TkToken"pixels";
+ cCAMLtoTKwidget default_toplevel;
+ cCAMLtoTKunits units|] in
+ int_of_string res
+
+##endif
diff --git a/builtin/builtinf_bind.ml b/builtin/builtinf_bind.ml
new file mode 100644
index 0000000..500fd6d
--- /dev/null
+++ b/builtin/builtinf_bind.ml
@@ -0,0 +1,133 @@
+##ifdef CAMLTK
+
+(* type *)
+type bindAction =
+ | BindSet of eventField list * (eventInfo -> unit)
+ | BindSetBreakable of eventField list * (eventInfo -> unit)
+ | BindRemove
+ | BindExtend of eventField list * (eventInfo -> unit)
+(* /type *)
+
+(*
+FUNCTION
+ val bind:
+ widget -> (modifier list * xEvent) list -> bindAction -> unit
+/FUNCTION
+*)
+let bind widget eventsequence action =
+ tkCommand [| TkToken "bind";
+ TkToken (Widget.name widget);
+ cCAMLtoTKeventSequence eventsequence;
+ begin match action with
+ BindRemove -> TkToken ""
+ | BindSet (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what)
+ in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+ | BindSetBreakable (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what)
+ in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
+ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0")
+ | BindExtend (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what)
+ in
+ TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+ end |]
+;;
+
+(* FUNCTION
+(* unsafe *)
+ val bind_class :
+ string -> (modifier list * xEvent) list -> bindAction -> unit
+(* /unsafe *)
+/FUNCTION class arg is not constrained *)
+
+let bind_class clas eventsequence action =
+ tkCommand [| TkToken "bind";
+ TkToken clas;
+ cCAMLtoTKeventSequence eventsequence;
+ begin match action with
+ BindRemove -> TkToken ""
+ | BindSet (what, f) ->
+ let cbId = register_callback Widget.dummy
+ (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+ | BindSetBreakable (what, f) ->
+ let cbId = register_callback Widget.dummy
+ (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" )
+ | BindExtend (what, f) ->
+ let cbId = register_callback Widget.dummy
+ (wrapeventInfo f what) in
+ TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+ end |]
+;;
+
+(* FUNCTION
+(* unsafe *)
+ val bind_tag :
+ string -> (modifier list * xEvent) list -> bindAction -> unit
+(* /unsafe *)
+/FUNCTION *)
+
+let bind_tag = bind_class
+;;
+
+(*
+FUNCTION
+ val break : unit -> unit
+/FUNCTION
+*)
+let break = function () ->
+ Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1"
+;;
+
+(* Legacy functions *)
+let tag_bind = bind_tag;;
+let class_bind = bind_class;;
+
+##else
+
+let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
+ ?action ?on:widget name =
+ let widget = match widget with None -> Widget.dummy | Some w -> coe w in
+ tkCommand
+ [| TkToken "bind";
+ TkToken name;
+ cCAMLtoTKeventSequence events;
+ begin match action with None -> TkToken ""
+ | Some f ->
+ let cbId =
+ register_callback widget ~callback: (wrapeventInfo f fields) in
+ let cb = if extend then "+camlcb " else "camlcb " in
+ let cb = cb ^ cbId ^ writeeventField fields in
+ let cb =
+ if breakable then
+ cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+ ^ " ; set BreakBindingsSequence 0"
+ else cb in
+ TkToken cb
+ end
+ |]
+;;
+
+let bind ~events ?extend ?breakable ?fields ?action widget =
+ bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
+ (Widget.name widget)
+;;
+
+let bind_tag = bind_class
+;;
+
+(*
+FUNCTION
+ val break : unit -> unit
+/FUNCTION
+*)
+let break = function () ->
+ tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
+;;
+
+##endif
diff --git a/builtin/builtini_GetBitmap.ml b/builtin/builtini_GetBitmap.ml
new file mode 100644
index 0000000..0c82a92
--- /dev/null
+++ b/builtin/builtini_GetBitmap.ml
@@ -0,0 +1,28 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKbitmap = function
+ BitmapFile s -> TkToken ("@" ^ s)
+| Predefined s -> TkToken s
+;;
+
+let cTKtoCAMLbitmap s =
+ if s = "" then Predefined ""
+ else if String.get s 0 = '@'
+ then BitmapFile (String.sub s 1 (String.length s - 1))
+ else Predefined s
+;;
+
+##else
+
+let cCAMLtoTKbitmap : bitmap -> tkArgs = function
+ | `File s -> TkToken ("@" ^ s)
+ | `Predefined s -> TkToken s
+;;
+
+let cTKtoCAMLbitmap s =
+ if String.get s 0 = '@'
+ then `File (String.sub s ~pos:1 ~len:(String.length s - 1))
+ else `Predefined s
+;;
+
+##endif
diff --git a/builtin/builtini_GetCursor.ml b/builtin/builtini_GetCursor.ml
new file mode 100644
index 0000000..4bbab73
--- /dev/null
+++ b/builtin/builtini_GetCursor.ml
@@ -0,0 +1,55 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKcolor = function
+ NamedColor x -> TkToken x
+ | Black -> TkToken "black"
+ | White -> TkToken "white"
+ | Red -> TkToken "red"
+ | Green -> TkToken "green"
+ | Blue -> TkToken "blue"
+ | Yellow -> TkToken "yellow"
+;;
+
+let cTKtoCAMLcolor = function s -> NamedColor s
+;;
+
+let cCAMLtoTKcursor = function
+ XCursor s -> TkToken s
+ | XCursorFg (s,fg) ->
+ TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg])
+ | XCursortFgBg (s,fg,bg) ->
+ TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+ | CursorFileFg (s,fg) ->
+ TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg])
+ | CursorMaskFile (s,m,fg,bg) ->
+ TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+;;
+
+##else
+
+let cCAMLtoTKcolor : color -> tkArgs = function
+ | `Color x -> TkToken x
+ | `Black -> TkToken "black"
+ | `White -> TkToken "white"
+ | `Red -> TkToken "red"
+ | `Green -> TkToken "green"
+ | `Blue -> TkToken "blue"
+ | `Yellow -> TkToken "yellow"
+;;
+
+let cTKtoCAMLcolor = function s -> `Color s
+;;
+
+let cCAMLtoTKcursor : cursor -> tkArgs = function
+ | `Xcursor s -> TkToken s
+ | `Xcursorfg (s,fg) ->
+ TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg])
+ | `Xcursorfgbg (s,fg,bg) ->
+ TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+ | `Cursorfilefg (s,fg) ->
+ TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg])
+ | `Cursormaskfile (s,m,fg,bg) ->
+ TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+;;
+
+##endif
diff --git a/builtin/builtini_GetPixel.ml b/builtin/builtini_GetPixel.ml
new file mode 100644
index 0000000..a470974
--- /dev/null
+++ b/builtin/builtini_GetPixel.ml
@@ -0,0 +1,43 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKunits = function
+ Pixels (foo) -> TkToken (string_of_int foo)
+ | Millimeters (foo) -> TkToken(Printf.sprintf "%gm" foo)
+ | Inches (foo) -> TkToken(Printf.sprintf "%gi" foo)
+ | PrinterPoint (foo) -> TkToken(Printf.sprintf "%gp" foo)
+ | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo)
+;;
+
+let cTKtoCAMLunits str =
+ let len = String.length str in
+ let num_part str = String.sub str 0 (len - 1) in
+ match String.get str (pred len) with
+ 'c' -> Centimeters (float_of_string (num_part str))
+ | 'i' -> Inches (float_of_string (num_part str))
+ | 'm' -> Millimeters (float_of_string (num_part str))
+ | 'p' -> PrinterPoint (float_of_string (num_part str))
+ | _ -> Pixels(int_of_string str)
+;;
+
+##else
+
+let cCAMLtoTKunits : units -> tkArgs = function
+ | `Pix (foo) -> TkToken (string_of_int foo)
+ | `Mm (foo) -> TkToken(Printf.sprintf "%gm" foo)
+ | `In (foo) -> TkToken(Printf.sprintf "%gi" foo)
+ | `Pt (foo) -> TkToken(Printf.sprintf "%gp" foo)
+ | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo)
+;;
+
+let cTKtoCAMLunits str =
+ let len = String.length str in
+ let num_part str = String.sub str ~pos:0 ~len:(len - 1) in
+ match String.get str (pred len) with
+ | 'c' -> `Cm (float_of_string (num_part str))
+ | 'i' -> `In (float_of_string (num_part str))
+ | 'm' -> `Mm (float_of_string (num_part str))
+ | 'p' -> `Pt (float_of_string (num_part str))
+ | _ -> `Pix(int_of_string str)
+;;
+
+##endif
diff --git a/builtin/builtini_ScrollValue.ml b/builtin/builtini_ScrollValue.ml
new file mode 100644
index 0000000..7cdce1e
--- /dev/null
+++ b/builtin/builtini_ScrollValue.ml
@@ -0,0 +1,45 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKscrollValue = function
+ ScrollPage v1 ->
+ TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"]
+ | ScrollUnit v1 ->
+ TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"]
+ | MoveTo v1 ->
+ TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)]
+;;
+
+(* str l -> scrllv -> str l *)
+let cTKtoCAMLscrollValue = function
+ "scroll"::n::("pages"|"page")::l ->
+ ScrollPage (int_of_string n), l
+ | "scroll"::n::"units"::l ->
+ ScrollUnit (int_of_string n), l
+ | "moveto"::f::l ->
+ MoveTo (float_of_string f), l
+ | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l)))
+;;
+
+##else
+
+let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function
+ | `Page v1 ->
+ TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"]
+ | `Unit v1 ->
+ TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"]
+ | `Moveto v1 ->
+ TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)]
+;;
+
+(* str l -> scrllv -> str l *)
+let cTKtoCAMLscrollValue = function
+ | "scroll" :: n :: ("pages"|"page") :: l ->
+ `Page (int_of_string n), l
+ | "scroll" :: n :: "units" :: l ->
+ `Unit (int_of_string n), l
+ | "moveto" :: f :: l ->
+ `Moveto (float_of_string f), l
+ | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l)))
+;;
+
+##endif
diff --git a/builtin/builtini_bind.ml b/builtin/builtini_bind.ml
new file mode 100644
index 0000000..e7f9a0b
--- /dev/null
+++ b/builtin/builtini_bind.ml
@@ -0,0 +1,136 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKxEvent = function
+ | Activate -> "Activate"
+ | ButtonPress -> "ButtonPress"
+ | ButtonPressDetail n -> "ButtonPress-"^string_of_int n
+ | ButtonRelease -> "ButtonRelease"
+ | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
+ | Circulate -> "Circulate"
+ | ColorMap -> "Colormap"
+ | Configure -> "Configure"
+ | Deactivate -> "Deactivate"
+ | Destroy -> "Destroy"
+ | Enter -> "Enter"
+ | Expose -> "Expose"
+ | FocusIn -> "FocusIn"
+ | FocusOut -> "FocusOut"
+ | Gravity -> "Gravity"
+ | KeyPress -> "KeyPress"
+ | KeyPressDetail s -> "KeyPress-"^s
+ | KeyRelease -> "KeyRelease"
+ | KeyReleaseDetail s -> "KeyRelease-"^s
+ | Leave -> "Leave"
+ | Map -> "Map"
+ | Motion -> "Motion"
+ | Property -> "Property"
+ | Reparent -> "Reparent"
+ | Unmap -> "Unmap"
+ | Visibility -> "Visibility"
+ | Virtual s -> "<"^s^">"
+;;
+
+let cCAMLtoTKmodifier = function
+ | Control -> "Control-"
+ | Shift -> "Shift-"
+ | Lock -> "Lock-"
+ | Button1 -> "Button1-"
+ | Button2 -> "Button2-"
+ | Button3 -> "Button3-"
+ | Button4 -> "Button4-"
+ | Button5 -> "Button5-"
+ | Double -> "Double-"
+ | Triple -> "Triple-"
+ | Mod1 -> "Mod1-"
+ | Mod2 -> "Mod2-"
+ | Mod3 -> "Mod3-"
+ | Mod4 -> "Mod4-"
+ | Mod5 -> "Mod5-"
+ | Meta -> "Meta-"
+ | Alt -> "Alt-"
+;;
+
+exception IllegalVirtualEvent
+
+(* type event = modifier list * xEvent *)
+let cCAMLtoTKevent (ml, xe) =
+ match xe with
+ | Virtual s ->
+ if ml = [] then "<<"^s^">>"
+ else raise IllegalVirtualEvent
+ | _ ->
+ "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml))
+ ^ (cCAMLtoTKxEvent xe) ^ ">"
+;;
+
+(* type eventSequence == (modifier list * xEvent) list *)
+let cCAMLtoTKeventSequence l =
+ TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l))
+
+##else
+
+let cCAMLtoTKmodifier : modifier -> string = function
+ | `Control -> "Control-"
+ | `Shift -> "Shift-"
+ | `Lock -> "Lock-"
+ | `Button1 -> "Button1-"
+ | `Button2 -> "Button2-"
+ | `Button3 -> "Button3-"
+ | `Button4 -> "Button4-"
+ | `Button5 -> "Button5-"
+ | `Double -> "Double-"
+ | `Triple -> "Triple-"
+ | `Mod1 -> "Mod1-"
+ | `Mod2 -> "Mod2-"
+ | `Mod3 -> "Mod3-"
+ | `Mod4 -> "Mod4-"
+ | `Mod5 -> "Mod5-"
+ | `Meta -> "Meta-"
+ | `Alt -> "Alt-"
+;;
+
+exception IllegalVirtualEvent
+
+let cCAMLtoTKevent (ev : event) =
+ let modified = ref false in
+ let rec convert = function
+ | `Activate -> "Activate"
+ | `ButtonPress -> "ButtonPress"
+ | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n
+ | `ButtonRelease -> "ButtonRelease"
+ | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
+ | `Circulate -> "Circulate"
+ | `Colormap -> "Colormap"
+ | `Configure -> "Configure"
+ | `Deactivate -> "Deactivate"
+ | `Destroy -> "Destroy"
+ | `Enter -> "Enter"
+ | `Expose -> "Expose"
+ | `FocusIn -> "FocusIn"
+ | `FocusOut -> "FocusOut"
+ | `Gravity -> "Gravity"
+ | `KeyPress -> "KeyPress"
+ | `KeyPressDetail s -> "KeyPress-"^s
+ | `KeyRelease -> "KeyRelease"
+ | `KeyReleaseDetail s -> "KeyRelease-"^s
+ | `Leave -> "Leave"
+ | `Map -> "Map"
+ | `Motion -> "Motion"
+ | `Property -> "Property"
+ | `Reparent -> "Reparent"
+ | `Unmap -> "Unmap"
+ | `Visibility -> "Visibility"
+ | `Virtual s ->
+ if !modified then raise IllegalVirtualEvent else "<"^s^">"
+ | `Modified(ml, ev) ->
+ modified := true;
+ String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml)
+ ^ convert ev
+ in "<" ^ convert ev ^ ">"
+;;
+
+let cCAMLtoTKeventSequence (l : event list) =
+ TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l))
+;;
+
+##endif
diff --git a/builtin/builtini_bindtags.ml b/builtin/builtini_bindtags.ml
new file mode 100644
index 0000000..e097348
--- /dev/null
+++ b/builtin/builtini_bindtags.ml
@@ -0,0 +1,29 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKbindings = function
+ | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1
+ | TagBindings v1 -> TkToken v1
+;;
+
+(* this doesn't really belong here *)
+let cTKtoCAMLbindings s =
+ if String.length s > 0 && s.[0] = '.' then
+ WidgetBindings (cTKtoCAMLwidget s)
+ else TagBindings s
+;;
+
+##else
+
+let cCAMLtoTKbindings = function
+| `Widget v1 -> cCAMLtoTKwidget v1
+| `Tag v1 -> TkToken v1
+;;
+
+(* this doesn't really belong here *)
+let cTKtoCAMLbindings s =
+ if String.length s > 0 && s.[0] = '.' then
+ `Widget (cTKtoCAMLwidget s)
+ else `Tag s
+;;
+
+##endif
diff --git a/builtin/builtini_font.ml b/builtin/builtini_font.ml
new file mode 100644
index 0000000..27a1750
--- /dev/null
+++ b/builtin/builtini_font.ml
@@ -0,0 +1,2 @@
+let cCAMLtoTKfont (s : font) = TkToken s
+let cTKtoCAMLfont (s : font) = s
diff --git a/builtin/builtini_grab.ml b/builtin/builtini_grab.ml
new file mode 100644
index 0000000..9007d04
--- /dev/null
+++ b/builtin/builtini_grab.ml
@@ -0,0 +1,2 @@
+let cCAMLtoTKgrabGlobal x =
+ if x then TkToken "-global" else TkTokenList []
diff --git a/builtin/builtini_index.ml b/builtin/builtini_index.ml
new file mode 100644
index 0000000..3baa448
--- /dev/null
+++ b/builtin/builtini_index.ml
@@ -0,0 +1,140 @@
+##ifdef CAMLTK
+
+(* sp to avoid being picked up by doc scripts *)
+ type index_constrs =
+ CNumber
+ | CActiveElement
+ | CEnd
+ | CLast
+ | CNoIndex
+ | CInsert
+ | CSelFirst
+ | CSelLast
+ | CAt
+ | CAtXY
+ | CAnchorPoint
+ | CPattern
+ | CLineChar
+ | CMark
+ | CTagFirst
+ | CTagLast
+ | CEmbedded
+;;
+
+let index_any_table =
+ [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst;
+ CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar;
+ CMark; CTagFirst; CTagLast; CEmbedded]
+;;
+
+let index_canvas_table =
+ [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY]
+;;
+let index_entry_table =
+ [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt]
+;;
+let index_listbox_table =
+ [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY]
+;;
+let index_menu_table =
+ [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern]
+;;
+let index_text_table =
+ [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded]
+;;
+
+let cCAMLtoTKindex table = function
+ Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x)
+ | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active"
+ | End -> chk_sub "End" table CEnd; TkToken "end"
+ | Last -> chk_sub "Last" table CLast; TkToken "last"
+ | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none"
+ | Insert -> chk_sub "Insert" table CInsert; TkToken "insert"
+ | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first"
+ | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last"
+ | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n)
+ | AtXY (x,y) -> chk_sub "AtXY" table CAtXY;
+ TkToken ("@"^string_of_int x^","^string_of_int y)
+ | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor"
+ | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s
+ | LineChar (l,c) -> chk_sub "LineChar" table CLineChar;
+ TkToken (string_of_int l^"."^string_of_int c)
+ | Mark s -> chk_sub "Mark" table CMark; TkToken s
+ | TagFirst t -> chk_sub "TagFirst" table CTagFirst;
+ TkToken (t^".first")
+ | TagLast t -> chk_sub "TagLast" table CTagLast;
+ TkToken (t^".last")
+ | Embedded w -> chk_sub "Embedded" table CEmbedded;
+ cCAMLtoTKwidget widget_any_table w
+;;
+
+let char_index c s =
+ let rec find i =
+ if i >= String.length s
+ then raise Not_found
+ else if String.get s i = c then i
+ else find (i+1) in
+ find 0
+;;
+
+(* Assume returned values are only numerical and l.c *)
+(* .menu index returns none if arg is none, but blast it *)
+let cTKtoCAMLindex s =
+ try
+ let p = char_index '.' s in
+ LineChar(int_of_string (String.sub s 0 p),
+ int_of_string (String.sub s (p+1) (String.length s - p - 1)))
+ with
+ Not_found ->
+ try Number (int_of_string s)
+ with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s))
+;;
+
+##else
+
+let cCAMLtoTKindex (* Don't put explicit typing *) = function
+ | `Num x -> TkToken (string_of_int x)
+ | `Active -> TkToken "active"
+ | `End -> TkToken "end"
+ | `Last -> TkToken "last"
+ | `None -> TkToken "none"
+ | `Insert -> TkToken "insert"
+ | `Selfirst -> TkToken "sel.first"
+ | `Sellast -> TkToken "sel.last"
+ | `At n -> TkToken ("@" ^ string_of_int n)
+ | `Atxy (x,y) -> TkToken ("@" ^ string_of_int x ^ "," ^ string_of_int y)
+ | `Anchor -> TkToken "anchor"
+ | `Pattern s -> TkToken s
+ | `Linechar (l,c) -> TkToken (string_of_int l ^ "." ^ string_of_int c)
+ | `Mark s -> TkToken s
+ | `Tagfirst t -> TkToken (t ^ ".first")
+ | `Taglast t -> TkToken (t ^ ".last")
+ | `Window (w : any widget) -> cCAMLtoTKwidget w
+ | `Image s -> TkToken s
+;;
+
+let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);;
+let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);;
+let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);;
+let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);;
+let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);;
+
+(* Assume returned values are only numerical and l.c *)
+
+let cTKtoCAMLtext_index s =
+ try
+ let p = String.index s '.' in
+ `Linechar (int_of_string (String.sub s ~pos:0 ~len:p),
+ int_of_string (String.sub s ~pos:(p + 1)
+ ~len:(String.length s - p - 1)))
+ with
+ Not_found ->
+ raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s))
+;;
+
+let cTKtoCAMLlistbox_index s =
+ try `Num (int_of_string s)
+ with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s))
+;;
+
+##endif
diff --git a/builtin/builtini_palette.ml b/builtin/builtini_palette.ml
new file mode 100644
index 0000000..e1fe37d
--- /dev/null
+++ b/builtin/builtini_palette.ml
@@ -0,0 +1,19 @@
+##ifdef CAMLTK
+
+let cCAMLtoTKpaletteType = function
+ GrayShades (foo) -> TkToken (string_of_int foo)
+ | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^
+ string_of_int v^"/"^
+ string_of_int b)
+;;
+
+##else
+
+let cCAMLtoTKpaletteType : paletteType -> tkArgs = function
+ | `Gray (foo) -> TkToken (string_of_int foo)
+ | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^
+ string_of_int v ^ "/" ^
+ string_of_int b)
+;;
+
+##endif
diff --git a/builtin/builtini_text.ml b/builtin/builtini_text.ml
new file mode 100644
index 0000000..4db49c0
--- /dev/null
+++ b/builtin/builtini_text.ml
@@ -0,0 +1,64 @@
+let cCAMLtoTKtextMark x = TkToken x;;
+let cTKtoCAMLtextMark x = x;;
+
+let cCAMLtoTKtextTag x = TkToken x;;
+let cTKtoCAMLtextTag x = x;;
+
+##ifdef CAMLTK
+
+(* TextModifiers are never returned by Tk *)
+let ppTextModifier = function
+ CharOffset n ->
+ if n > 0 then "+" ^ (string_of_int n) ^ "chars"
+ else if n = 0 then ""
+ else (string_of_int n) ^ "chars"
+ | LineOffset n ->
+ if n > 0 then "+" ^ (string_of_int n) ^ "lines"
+ else if n = 0 then ""
+ else (string_of_int n) ^ "lines"
+ | LineStart -> " linestart"
+ | LineEnd -> " lineend"
+ | WordStart -> " wordstart"
+ | WordEnd -> " wordend"
+;;
+
+let ppTextIndex = function
+ | TextIndexNone -> ""
+ | TextIndex (base, ml) ->
+ match cCAMLtoTKindex index_text_table base with
+ | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml)
+ | _ -> assert false
+;;
+
+let cCAMLtoTKtextIndex i =
+ TkToken (ppTextIndex i)
+;;
+
+##else
+
+(* TextModifiers are never returned by Tk *)
+let cCAMLtoTKtextIndex (i : textIndex) =
+ let ppTextModifier = function
+ | `Char n ->
+ if n > 0 then "+" ^ (string_of_int n) ^ "chars"
+ else if n = 0 then ""
+ else (string_of_int n) ^ "chars"
+ | `Line n ->
+ if n > 0 then "+" ^ (string_of_int n) ^ "lines"
+ else if n = 0 then ""
+ else (string_of_int n) ^ "lines"
+ | `Linestart -> " linestart"
+ | `Lineend -> " lineend"
+ | `Wordstart -> " wordstart"
+ | `Wordend -> " wordend"
+ in
+ let ppTextIndex (base, ml : textIndex) =
+ match cCAMLtoTKtext_index base with
+ TkToken ppbase ->
+ String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml)
+ | _ -> assert false
+ in
+ TkToken (ppTextIndex i)
+;;
+
+##endif
diff --git a/builtin/canvas_bind.ml b/builtin/canvas_bind.ml
new file mode 100644
index 0000000..9256a74
--- /dev/null
+++ b/builtin/canvas_bind.ml
@@ -0,0 +1,52 @@
+##ifdef CAMLTK
+
+let bind widget tag eventsequence action =
+ tkCommand [|
+ cCAMLtoTKwidget widget_canvas_table widget;
+ TkToken "bind";
+ cCAMLtoTKtagOrId tag;
+ cCAMLtoTKeventSequence eventsequence;
+ begin match action with
+ | BindRemove -> TkToken ""
+ | BindSet (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+ | BindSetBreakable (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \
+ set BreakBindingsSequence 0")
+ | BindExtend (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+ end
+ |]
+;;
+
+##else
+
+let bind ~events
+ ?(extend = false) ?(breakable = false) ?(fields = [])
+ ?action widget tag =
+ tkCommand
+ [| cCAMLtoTKwidget widget;
+ TkToken "bind";
+ cCAMLtoTKtagOrId tag;
+ cCAMLtoTKeventSequence events;
+ begin match action with None -> TkToken ""
+ | Some f ->
+ let cbId =
+ register_callback widget ~callback: (wrapeventInfo f fields) in
+ let cb = if extend then "+camlcb " else "camlcb " in
+ let cb = cb ^ cbId ^ writeeventField fields in
+ let cb =
+ if breakable then
+ cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+ ^ " ; set BreakBindingsSequence 0"
+ else cb in
+ TkToken cb
+ end
+ |]
+;;
+
+##endif
diff --git a/builtin/canvas_bind.mli b/builtin/canvas_bind.mli
new file mode 100644
index 0000000..0c6c583
--- /dev/null
+++ b/builtin/canvas_bind.mli
@@ -0,0 +1,16 @@
+##ifdef CAMLTK
+
+val bind : widget -> tagOrId ->
+ (modifier list * xEvent) list -> bindAction -> unit
+
+##else
+
+val bind :
+ events: event list ->
+ ?extend: bool ->
+ ?breakable: bool ->
+ ?fields: eventField list ->
+ ?action: (eventInfo -> unit) ->
+ canvas widget -> tagOrId -> unit
+
+##endif
diff --git a/builtin/dialog.ml b/builtin/dialog.ml
new file mode 100644
index 0000000..e6654d8
--- /dev/null
+++ b/builtin/dialog.ml
@@ -0,0 +1,45 @@
+##ifdef CAMLTK
+
+let create ?name parent title mesg bitmap def buttons =
+ let w = Widget.new_atom "toplevel" ~parent ?name in
+ let res = tkEval [|TkToken"tk_dialog";
+ cCAMLtoTKwidget widget_any_table w;
+ TkToken title;
+ TkToken mesg;
+ cCAMLtoTKbitmap bitmap;
+ TkToken (string_of_int def);
+ TkTokenList (List.map (function x -> TkToken x) buttons)|]
+ in
+ int_of_string res
+;;
+
+let create_named parent name title mesg bitmap def buttons =
+ let w = Widget.new_atom "toplevel" ~parent ~name in
+ let res = tkEval [|TkToken"tk_dialog";
+ cCAMLtoTKwidget widget_any_table w;
+ TkToken title;
+ TkToken mesg;
+ cCAMLtoTKbitmap bitmap;
+ TkToken (string_of_int def);
+ TkTokenList (List.map (function x -> TkToken x) buttons)|]
+ in
+ int_of_string res
+;;
+
+##else
+
+let create ~parent ~title ~message ~buttons ?name
+ ?(bitmap = `Predefined "") ?(default = -1) () =
+ let w = Widget.new_atom "toplevel" ?name ~parent in
+ let res = tkEval [|TkToken"tk_dialog";
+ cCAMLtoTKwidget w;
+ TkToken title;
+ TkToken message;
+ cCAMLtoTKbitmap bitmap;
+ TkToken (string_of_int default);
+ TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|]
+ in
+ int_of_string res
+;;
+
+##endif
diff --git a/builtin/dialog.mli b/builtin/dialog.mli
new file mode 100644
index 0000000..532045c
--- /dev/null
+++ b/builtin/dialog.mli
@@ -0,0 +1,24 @@
+##ifdef CAMLTK
+
+val create : ?name: string ->
+ widget -> string -> string -> bitmap -> int -> string list -> int
+ (* [create ~name parent title message bitmap default button_names]
+ cf. tk_dialog *)
+
+val create_named :
+ widget -> string -> string -> string -> bitmap -> int -> string list -> int
+ (* [create_named parent name title message bitmap default button_names]
+ cf. tk_dialog *)
+
+##else
+
+val create :
+ parent: 'a widget ->
+ title: string ->
+ message: string ->
+ buttons: string list ->
+ ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int
+ (* [create title message bitmap default button_names parent]
+ cf. tk_dialog *)
+
+##endif
diff --git a/builtin/image.ml b/builtin/image.ml
new file mode 100644
index 0000000..a1fd2ea
--- /dev/null
+++ b/builtin/image.ml
@@ -0,0 +1,33 @@
+##ifdef CAMLTK
+
+let cTKtoCAMLimage s =
+ let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in
+ match res with
+ | "bitmap" -> ImageBitmap (BitmapImage s)
+ | "photo" -> ImagePhoto (PhotoImage s)
+ | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\""))
+;;
+
+let names () =
+ let res = tkEval [|TkToken "image"; TkToken "names"|] in
+ let names = splitlist res in
+ List.map cTKtoCAMLimage names
+;;
+
+##else
+
+let cTKtoCAMLimage s =
+ let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in
+ match res with
+ | "bitmap" -> `Bitmap s
+ | "photo" -> `Photo s
+ | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\""))
+;;
+
+let names () =
+ let res = tkEval [|TkToken "image"; TkToken "names"|] in
+ let names = splitlist res in
+ List.map cTKtoCAMLimage names
+;;
+
+##endif
diff --git a/builtin/image.mli b/builtin/image.mli
new file mode 100644
index 0000000..a92a9f8
--- /dev/null
+++ b/builtin/image.mli
@@ -0,0 +1,9 @@
+##ifdef CAMLTK
+
+val names : unit -> options list
+
+##else
+
+val names : unit -> image list
+
+##endif
diff --git a/builtin/optionmenu.ml b/builtin/optionmenu.ml
new file mode 100644
index 0000000..5a17e3f
--- /dev/null
+++ b/builtin/optionmenu.ml
@@ -0,0 +1,54 @@
+##ifdef CAMLTK
+
+open Protocol;;
+(* Implementation of the tk_optionMenu *)
+
+let create ?name parent variable values =
+ let w = Widget.new_atom "menubutton" ~parent ?name in
+ let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in
+ let res =
+ tkEval [|TkToken "tk_optionMenu";
+ TkToken (Widget.name w);
+ cCAMLtoTKtextVariable variable;
+ TkTokenList (List.map (function x -> TkToken x) values)|] in
+ if res <> Widget.name mw then
+ raise (TkError "internal error in Optionmenu.create")
+ else
+ w,mw
+;;
+
+let create_named parent name variable values =
+ let w = Widget.new_atom "menubutton" ~parent ~name in
+ let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in
+ let res =
+ tkEval [|TkToken "tk_optionMenu";
+ TkToken (Widget.name w);
+ cCAMLtoTKtextVariable variable;
+ TkTokenList (List.map (function x -> TkToken x) values)|] in
+ if res <> Widget.name mw then
+ raise (TkError "internal error in Optionmenu.create")
+ else
+ w,mw
+;;
+
+##else
+
+open Protocol;;
+(* Implementation of the tk_optionMenu *)
+
+let create ~parent ~variable ?name values =
+ let w = Widget.new_atom "menubutton" ~parent ?name in
+ let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in
+ (* assumes .menu naming *)
+ let res =
+ tkEval [|TkToken "tk_optionMenu";
+ TkToken (Widget.name w);
+ cCAMLtoTKtextVariable variable;
+ TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in
+ if res <> Widget.name mw then
+ raise (TkError "internal error in Optionmenu.create")
+ else
+ w, mw
+;;
+
+##endif
diff --git a/builtin/optionmenu.mli b/builtin/optionmenu.mli
new file mode 100644
index 0000000..c587957
--- /dev/null
+++ b/builtin/optionmenu.mli
@@ -0,0 +1,21 @@
+##ifdef CAMLTK
+
+(* Support for tk_optionMenu *)
+val create: ?name: string ->
+ widget -> textVariable -> string list -> widget * widget
+(** [create ?name parent var options] creates a multi-option menubutton and
+ its associated menu. The option is also stored in the variable.
+ Both widgets (menubutton and menu) are returned. *)
+
+##else
+
+(* Support for tk_optionMenu *)
+val create:
+ parent:'a widget ->
+ variable:textVariable ->
+ ?name: string -> string list -> menubutton widget * menu widget
+(** [create ~parent ~var ~name options] creates a multi-option menubutton
+ and its associated menu. The option is also stored in the variable.
+ Both widgets (menubutton and menu) are returned *)
+
+##endif
diff --git a/builtin/rawimg.ml b/builtin/rawimg.ml
new file mode 100644
index 0000000..062187f
--- /dev/null
+++ b/builtin/rawimg.ml
@@ -0,0 +1,142 @@
+external rawget : string -> bytes
+ = "camltk_getimgdata"
+external rawset : string -> bytes -> int -> int -> int -> int -> unit
+ = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *)
+ "camltk_setimgdata_native"
+
+type t = {
+ pixmap_width : int;
+ pixmap_height: int;
+ pixmap_data: bytes
+}
+
+let (.![]<-) = Bytes.set
+
+type pixel = string (* 3 chars *)
+
+(* pixmap will be an abstract type *)
+let width pix = pix.pixmap_width
+let height pix = pix.pixmap_height
+
+
+(* note: invalid size would have been caught by Bytes.create, but we put
+ * it here for documentation purpose *)
+let create w h =
+ if w < 0 || h < 0 then invalid_arg "invalid size"
+ else {
+ pixmap_width = w;
+ pixmap_height = h;
+ pixmap_data = Bytes.create (w * h * 3);
+ }
+
+(*
+ * operations on pixmaps
+ *)
+let unsafe_copy pix_from pix_to =
+ Bytes.unsafe_blit pix_from.pixmap_data 0
+ pix_to.pixmap_data 0
+ (Bytes.length pix_from.pixmap_data)
+
+(* We check only the length. w,h might be different... *)
+let copy pix_from pix_to =
+ let l = Bytes.length pix_from.pixmap_data in
+ if l <> Bytes.length pix_to.pixmap_data then
+ raise (Invalid_argument "copy: incompatible length")
+ else unsafe_copy pix_from pix_to
+
+
+(* Pixel operations *)
+let unsafe_get_pixel pixmap x y =
+ let pos = (y * pixmap.pixmap_width + x) * 3 in
+ Bytes.sub_string pixmap.pixmap_data pos 3
+
+let unsafe_set_pixel pixmap x y pixel =
+ let pos = (y * pixmap.pixmap_width + x) * 3 in
+ Bytes.unsafe_blit (Bytes.unsafe_of_string pixel) 0 pixmap.pixmap_data pos 3
+
+(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[
+ or rely on blit checking. We choose the first for clarity.
+ *)
+let get_pixel pix x y =
+ if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height
+ then invalid_arg "invalid pixel"
+ else unsafe_get_pixel pix x y
+
+(* same check (pixel being abstract, it must be of good size *)
+let set_pixel pix x y pixel =
+ if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height
+ then invalid_arg "invalid pixel"
+ else unsafe_set_pixel pix x y pixel
+
+(* black as default_color, if at all needed *)
+let default_color = "\000\000\000"
+
+(* Char.chr does range checking *)
+let pixel r g b =
+ let s = Bytes.create 3 in
+ s.![0] <- Char.chr r;
+ s.![1] <- Char.chr g;
+ s.![2] <- Char.chr b;
+ Bytes.unsafe_to_string s
+
+##ifdef CAMLTK
+
+(* create pixmap from an existing image *)
+let get photo =
+ match photo with
+ | PhotoImage s -> {
+ pixmap_width = CImagephoto.width photo;
+ pixmap_height = CImagephoto.height photo;
+ pixmap_data = rawget s;
+ }
+
+(* copy a full pixmap into an image *)
+let set photo pix =
+ match photo with
+ | PhotoImage s ->
+ rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height
+
+(* general blit of pixmap into image *)
+let blit photo pix x y w h =
+ if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"
+ else match photo with
+ | PhotoImage s ->
+ rawset s pix.pixmap_data x y w h
+
+(* get from a file *)
+let from_file filename =
+ let img = CImagephoto.create [File filename] in
+ let pix = get img in
+ CImagephoto.delete img;
+ pix
+
+##else
+
+(* create pixmap from an existing image *)
+let get photo =
+ match photo with
+ | `Photo s -> {
+ pixmap_width = Imagephoto.width photo;
+ pixmap_height = Imagephoto.height photo;
+ pixmap_data = rawget s;
+ }
+
+(* copy a full pixmap into an image *)
+let set photo pix =
+ match photo with
+ | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height
+
+(* general blit of pixmap into image *)
+let blit photo pix x y w h =
+ if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"
+ else match photo with
+ | `Photo s -> rawset s pix.pixmap_data x y w h
+
+(* get from a file *)
+let from_file filename =
+ let img = Imagephoto.create ~file: filename () in
+ let pix = get img in
+ Imagephoto.delete img;
+ pix
+
+##endif
diff --git a/builtin/rawimg.mli b/builtin/rawimg.mli
new file mode 100644
index 0000000..1bb120f
--- /dev/null
+++ b/builtin/rawimg.mli
@@ -0,0 +1,44 @@
+(*
+ * Minimal pixmap support
+ *)
+
+type t
+type pixel
+
+val width : t -> int
+ (* [width pixmap] *)
+val height : t -> int
+ (* [height pixmap] *)
+
+val create : int -> int -> t
+ (* [create width height] *)
+val get : imagePhoto -> t
+ (* [get img] *)
+val set : imagePhoto -> t -> unit
+ (* [set img pixmap] *)
+val blit : imagePhoto -> t -> int -> int -> int -> int -> unit
+ (* [blit img pixmap x y w h] (all ints must be non-negative) *)
+val from_file : string -> t
+ (* [from_file filename] *)
+
+val copy : t -> t -> unit
+ (* [copy src dst] *)
+
+(*
+ * Pixel operations
+ *)
+val get_pixel : t -> int -> int -> pixel
+ (* [get_pixel pixmap x y] *)
+val set_pixel : t -> int -> int -> pixel -> unit
+ (* [set_pixel pixmap x y pixel] *)
+val default_color : pixel
+
+val pixel : int -> int -> int -> pixel
+ (* [pixel r g b] (r,g,b must be in [0..255]) *)
+
+(*-*)
+(* unsafe *)
+val unsafe_copy : t -> t -> unit
+val unsafe_get_pixel : t -> int -> int -> pixel
+val unsafe_set_pixel : t -> int -> int -> pixel -> unit
+(* /unsafe *)
diff --git a/builtin/report.ml b/builtin/report.ml
new file mode 100644
index 0000000..852b4c1
--- /dev/null
+++ b/builtin/report.ml
@@ -0,0 +1,17 @@
+(* Report globals from protocol *)
+let opentk = Protocol.opentk
+let keywords = Protocol.keywords
+let opentk_with_args = Protocol.opentk_with_args
+let openTk = Protocol.openTk
+let openTkClass = Protocol.openTkClass
+let openTkDisplayClass = Protocol.openTkDisplayClass
+let closeTk = Protocol.closeTk
+let mainLoop = Protocol.mainLoop
+let register = Protocol.register
+
+(* From support *)
+let may = Support.may
+let maycons = Support.maycons
+
+(* From widget *)
+let coe = Widget.coe
diff --git a/builtin/selection_handle_set.ml b/builtin/selection_handle_set.ml
new file mode 100644
index 0000000..2dfc576
--- /dev/null
+++ b/builtin/selection_handle_set.ml
@@ -0,0 +1,41 @@
+##ifdef CAMLTK
+
+(* The function *must* use tkreturn *)
+let handle_set opts w cmd =
+ tkCommand [|
+ TkToken"selection";
+ TkToken"handle";
+ TkTokenList
+ (List.map
+ (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x)
+ opts);
+ cCAMLtoTKwidget widget_any_table w;
+ let id = register_callback w (function args ->
+ let (a1,args) = int_of_string (List.hd args), List.tl args in
+ let (a2,args) = int_of_string (List.hd args), List.tl args in
+ cmd a1 a2) in
+ TkToken ("camlcb "^id)
+ |]
+;;
+
+##else
+
+(* The function *must* use tkreturn *)
+let handle_set ~command =
+selection_handle_icccm_optionals (fun opts w ->
+ tkCommand [|
+ TkToken"selection";
+ TkToken"handle";
+ TkTokenList opts;
+ cCAMLtoTKwidget w;
+ let id = register_callback w ~callback:
+ begin fun args ->
+ let pos = int_of_string (List.hd args) in
+ let len = int_of_string (List.nth args 1) in
+ tkreturn (command ~pos ~len)
+ end
+ in TkToken ("camlcb " ^ id)
+ |])
+;;
+
+##endif
diff --git a/builtin/selection_handle_set.mli b/builtin/selection_handle_set.mli
new file mode 100644
index 0000000..3778e27
--- /dev/null
+++ b/builtin/selection_handle_set.mli
@@ -0,0 +1,13 @@
+##ifdef CAMLTK
+
+val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit
+(** tk invocation: selection handle *)
+
+##else
+
+val handle_set :
+ command: (pos:int -> len:int -> string) ->
+ ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit
+(** tk invocation: selection handle *)
+
+##endif
diff --git a/builtin/selection_own_set.ml b/builtin/selection_own_set.ml
new file mode 100644
index 0000000..9a4b1f1
--- /dev/null
+++ b/builtin/selection_own_set.ml
@@ -0,0 +1,29 @@
+##ifdef CAMLTK
+
+(* builtin to handle callback association to widget *)
+let own_set v1 v2 =
+ tkCommand [|
+ TkToken"selection";
+ TkToken"own";
+ TkTokenList
+ (List.map
+ (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x)
+ v1);
+ cCAMLtoTKwidget widget_any_table v2
+ |]
+;;
+
+##else
+
+(* builtin to handle callback association to widget *)
+let own_set ?command =
+ selection_ownset_icccm_optionals ?command (fun opts w ->
+ tkCommand [|
+ TkToken"selection";
+ TkToken"own";
+ TkTokenList opts;
+ cCAMLtoTKwidget w
+ |])
+;;
+
+##endif
diff --git a/builtin/selection_own_set.mli b/builtin/selection_own_set.mli
new file mode 100644
index 0000000..868a824
--- /dev/null
+++ b/builtin/selection_own_set.mli
@@ -0,0 +1,12 @@
+##ifdef CAMLTK
+
+val own_set : icccm list -> widget -> unit
+(** tk invocation: selection own *)
+
+##else
+
+val own_set :
+ ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit
+(** tk invocation: selection own *)
+
+##endif
diff --git a/builtin/text_tag_bind.ml b/builtin/text_tag_bind.ml
new file mode 100644
index 0000000..72e9f04
--- /dev/null
+++ b/builtin/text_tag_bind.ml
@@ -0,0 +1,55 @@
+##ifdef CAMLTK
+
+let tag_bind widget tag eventsequence action =
+ check_class widget widget_text_table;
+ tkCommand [|
+ cCAMLtoTKwidget widget_text_table widget;
+ TkToken "tag";
+ TkToken "bind";
+ cCAMLtoTKtextTag tag;
+ cCAMLtoTKeventSequence eventsequence;
+ begin match action with
+ | BindRemove -> TkToken ""
+ | BindSet (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+ | BindSetBreakable (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
+ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \
+ set BreakBindingsSequence 0")
+ | BindExtend (what, f) ->
+ let cbId = register_callback widget (wrapeventInfo f what) in
+ TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+ end
+ |]
+;;
+
+##else
+
+let tag_bind ~tag ~events ?(extend = false) ?(breakable = false)
+ ?(fields = []) ?action widget =
+ tkCommand [|
+ cCAMLtoTKwidget widget;
+ TkToken "tag";
+ TkToken "bind";
+ cCAMLtoTKtextTag tag;
+ cCAMLtoTKeventSequence events;
+ begin match action with
+ | None -> TkToken ""
+ | Some f ->
+ let cbId =
+ register_callback widget ~callback: (wrapeventInfo f fields) in
+ let cb = if extend then "+camlcb " else "camlcb " in
+ let cb = cb ^ cbId ^ writeeventField fields in
+ let cb =
+ if breakable then
+ cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+ ^ " ; set BreakBindingsSequence 0"
+ else cb in
+ TkToken cb
+ end
+ |]
+;;
+
+##endif
diff --git a/builtin/text_tag_bind.mli b/builtin/text_tag_bind.mli
new file mode 100644
index 0000000..6778e4f
--- /dev/null
+++ b/builtin/text_tag_bind.mli
@@ -0,0 +1,13 @@
+##ifdef CAMLTK
+
+val tag_bind:
+ widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit
+
+##else
+
+val tag_bind :
+ tag: string -> events: event list ->
+ ?extend: bool -> ?breakable: bool -> ?fields: eventField list ->
+ ?action: (eventInfo -> unit) -> text widget -> unit
+
+##endif
diff --git a/builtin/winfo_contained.ml b/builtin/winfo_contained.ml
new file mode 100644
index 0000000..f1fb373
--- /dev/null
+++ b/builtin/winfo_contained.ml
@@ -0,0 +1,13 @@
+##ifdef CAMLTK
+
+let contained x y w =
+ w = containing x y
+;;
+
+##else
+
+let contained ~x ~y w =
+ forget_type w = containing ~x ~y ()
+;;
+
+##endif
diff --git a/builtin/winfo_contained.mli b/builtin/winfo_contained.mli
new file mode 100644
index 0000000..41cc57c
--- /dev/null
+++ b/builtin/winfo_contained.mli
@@ -0,0 +1,11 @@
+##ifdef CAMLTK
+
+val contained : int -> int -> widget -> bool
+(** [contained x y w] returns true if (x,y) is in w *)
+
+##else
+
+val contained : x:int -> y:int -> 'a widget -> bool
+(** [contained x y w] returns true if (x,y) is in w *)
+
+##endif
diff --git a/camltk/.gitignore b/camltk/.gitignore
new file mode 100644
index 0000000..81bd183
--- /dev/null
+++ b/camltk/.gitignore
@@ -0,0 +1,4 @@
+*.ml
+*.mli
+labltktop
+labltk
diff --git a/camltk/Makefile b/camltk/Makefile
new file mode 100644
index 0000000..ed4b3a0
--- /dev/null
+++ b/camltk/Makefile
@@ -0,0 +1,68 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include ../support/Makefile.common
+
+COMPFLAGS= -I ../support -no-alias-deps
+
+all: camltkobjs
+
+opt: camltkobjsx
+
+include ./modules
+
+CAMLTKOBJS = $(CWIDGETOBJS) cTk.cmo camltk.cmo
+CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx)
+
+camltkobjs: $(CAMLTKOBJS)
+
+camltkobjsx: $(CAMLTKOBJSX)
+
+ifeq ($(USE_FINDLIB),yes)
+install:
+ ocamlfind install labltk -add \
+ $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli)
+installopt:
+ ocamlfind install labltk -add $(CAMLTKOBJSX)
+else
+install:
+ if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
+ cp $(CAMLTKOBJS:.cmo=.cmi) $(INSTALLDIR)
+ cp $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
+ chmod 644 $(INSTALLDIR)/*.cmi
+
+installopt:
+ @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
+ cp $(CAMLTKOBJSX) $(INSTALLDIR)
+ chmod 644 $(INSTALLDIR)/*.cmx
+endif
+
+clean:
+ $(MAKE) -f Makefile.gen clean
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
+
+.mli.cmi:
+ $(CAMLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+ $(CAMLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+ $(CAMLOPT) -c $(COMPFLAGS) $<
+
+include .depend
diff --git a/camltk/Makefile.gen b/camltk/Makefile.gen
new file mode 100644
index 0000000..c58ba30
--- /dev/null
+++ b/camltk/Makefile.gen
@@ -0,0 +1,72 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include ../support/Makefile.common
+
+all: cTk.ml # camltk.ml .depend
+
+ # all 3 dependencies are generated by the same rule. When the
+ # target 'all' depends on the 3 files, a 'make -jN' will spawn 3
+ # shell processes, and generate all files 3 times in parallel...
+
+_tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE)
+ cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -camltk -outdir camltk
+
+#cTk.ml camltk.ml .depend: generate
+
+cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml
+ (echo '##define CAMLTK'; \
+ echo 'include Camltkwrap'; \
+ echo 'open Widget'; \
+ echo 'open Protocol'; \
+ echo 'open Textvariable'; \
+ echo ; \
+ cat ../builtin/report.ml; \
+ echo ; \
+ cat ../builtin/builtin_*.ml; \
+ echo ; \
+ cat _tkgen.ml; \
+ echo ; \
+ echo ; \
+ echo 'module Tkintf = struct'; \
+ cat ../builtin/builtini_*.ml; \
+ cat _tkigen.ml; \
+ echo 'end (* module Tkintf *)'; \
+ echo ; \
+ echo ; \
+ echo 'open Tkintf' ;\
+ echo ; \
+ echo ; \
+ cat ../builtin/builtinf_*.ml; \
+ cat _tkfgen.ml; \
+ echo ; \
+ ) > _cTk.ml
+ $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml
+ rm -f _cTk.ml
+ $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
+
+../compiler/pp$(EXE):
+ cd ../compiler; $(MAKE) pp($EXE)
+
+../compiler/tkcompiler$(EXE):
+ cd ../compiler; $(MAKE) tkcompiler($EXE)
+
+# All .{ml,mli} files are generated in this directory
+clean:
+ rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend
+# rm -f modules
+
+.PHONY: all generate clean
diff --git a/camltk/Makefile.gen.nt b/camltk/Makefile.gen.nt
new file mode 100644
index 0000000..4feb527
--- /dev/null
+++ b/camltk/Makefile.gen.nt
@@ -0,0 +1,17 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include Makefile.gen
diff --git a/camltk/Makefile.nt b/camltk/Makefile.nt
new file mode 100644
index 0000000..74203f0
--- /dev/null
+++ b/camltk/Makefile.nt
@@ -0,0 +1,17 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include Makefile
diff --git a/camltk/byte.itarget b/camltk/byte.itarget
new file mode 100644
index 0000000..1b841be
--- /dev/null
+++ b/camltk/byte.itarget
@@ -0,0 +1,9 @@
+cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo
+cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo
+cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo
+cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo
+cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo
+cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo
+cCheckbutton.cmo cBell.cmo cTkvars.cmo
+
+cTk.cmo camltk.cmo
diff --git a/camltk/modules b/camltk/modules
new file mode 100644
index 0000000..f9fabde
--- /dev/null
+++ b/camltk/modules
@@ -0,0 +1,80 @@
+CWIDGETOBJS= cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
+cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
+
+cBell.cmo : cBell.ml
+cBell.cmi : cBell.mli
+cScale.cmo : cScale.ml
+cScale.cmi : cScale.mli
+cWinfo.cmo : cWinfo.ml
+cWinfo.cmi : cWinfo.mli
+cScrollbar.cmo : cScrollbar.ml
+cScrollbar.cmi : cScrollbar.mli
+cEntry.cmo : cEntry.ml
+cEntry.cmi : cEntry.mli
+cListbox.cmo : cListbox.ml
+cListbox.cmi : cListbox.mli
+cWm.cmo : cWm.ml
+cWm.cmi : cWm.mli
+cTkwait.cmo : cTkwait.ml
+cTkwait.cmi : cTkwait.mli
+cGrab.cmo : cGrab.ml
+cGrab.cmi : cGrab.mli
+cFont.cmo : cFont.ml
+cFont.cmi : cFont.mli
+cCanvas.cmo : cCanvas.ml
+cCanvas.cmi : cCanvas.mli
+cImage.cmo : cImage.ml
+cImage.cmi : cImage.mli
+cClipboard.cmo : cClipboard.ml
+cClipboard.cmi : cClipboard.mli
+cLabel.cmo : cLabel.ml
+cLabel.cmi : cLabel.mli
+cResource.cmo : cResource.ml
+cResource.cmi : cResource.mli
+cMessage.cmo : cMessage.ml
+cMessage.cmi : cMessage.mli
+cText.cmo : cText.ml
+cText.cmi : cText.mli
+cImagephoto.cmo : cImagephoto.ml
+cImagephoto.cmi : cImagephoto.mli
+cOption.cmo : cOption.ml
+cOption.cmi : cOption.mli
+cFrame.cmo : cFrame.ml
+cFrame.cmi : cFrame.mli
+cSelection.cmo : cSelection.ml
+cSelection.cmi : cSelection.mli
+cDialog.cmo : cDialog.ml
+cDialog.cmi : cDialog.mli
+cPlace.cmo : cPlace.ml
+cPlace.cmi : cPlace.mli
+cPixmap.cmo : cPixmap.ml
+cPixmap.cmi : cPixmap.mli
+cMenubutton.cmo : cMenubutton.ml
+cMenubutton.cmi : cMenubutton.mli
+cRadiobutton.cmo : cRadiobutton.ml
+cRadiobutton.cmi : cRadiobutton.mli
+cFocus.cmo : cFocus.ml
+cFocus.cmi : cFocus.mli
+cPack.cmo : cPack.ml
+cPack.cmi : cPack.mli
+cImagebitmap.cmo : cImagebitmap.ml
+cImagebitmap.cmi : cImagebitmap.mli
+cEncoding.cmo : cEncoding.ml
+cEncoding.cmi : cEncoding.mli
+cOptionmenu.cmo : cOptionmenu.ml
+cOptionmenu.cmi : cOptionmenu.mli
+cCheckbutton.cmo : cCheckbutton.ml
+cCheckbutton.cmi : cCheckbutton.mli
+cTkvars.cmo : cTkvars.ml
+cTkvars.cmi : cTkvars.mli
+cPalette.cmo : cPalette.ml
+cPalette.cmi : cPalette.mli
+cMenu.cmo : cMenu.ml
+cMenu.cmi : cMenu.mli
+cButton.cmo : cButton.ml
+cButton.cmi : cButton.mli
+cToplevel.cmo : cToplevel.ml
+cToplevel.cmi : cToplevel.mli
+cGrid.cmo : cGrid.ml
+cGrid.cmi : cGrid.mli
+camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
diff --git a/camltk/native.itarget b/camltk/native.itarget
new file mode 100644
index 0000000..9c589f1
--- /dev/null
+++ b/camltk/native.itarget
@@ -0,0 +1,7 @@
+cPlace.cmx cResource.cmx cWm.cmx cImagephoto.cmx cCanvas.cmx cButton.cmx
+cText.cmx cLabel.cmx cScrollbar.cmx cImage.cmx cEncoding.cmx cPixmap.cmx
+cPalette.cmx cFont.cmx cMessage.cmx cMenu.cmx cEntry.cmx cListbox.cmx
+cFocus.cmx cMenubutton.cmx cPack.cmx cOption.cmx cToplevel.cmx cFrame.cmx
+cDialog.cmx cImagebitmap.cmx cClipboard.cmx cRadiobutton.cmx cTkwait.cmx
+cGrab.cmx cSelection.cmx cScale.cmx cOptionmenu.cmx cWinfo.cmx cGrid.cmx
+cCheckbutton.cmx cBell.cmx cTkvars.cmx
diff --git a/compiler/.depend b/compiler/.depend
new file mode 100644
index 0000000..91ee430
--- /dev/null
+++ b/compiler/.depend
@@ -0,0 +1,28 @@
+pplex.cmi: ppyac.cmi
+ppyac.cmi: code.cmi
+compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo
+compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx
+intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo
+intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx
+lexer.cmo: parser.cmi
+lexer.cmx: parser.cmx
+maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \
+ ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo
+maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \
+ ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx
+parser.cmo: flags.cmo tables.cmo parser.cmi
+parser.cmx: flags.cmx tables.cmx parser.cmi
+pp.cmo: ppexec.cmo ppparse.cmo
+pp.cmx: ppexec.cmx ppparse.cmx
+ppexec.cmo: code.cmi
+ppexec.cmx: code.cmi
+pplex.cmo: ppyac.cmi pplex.cmi
+pplex.cmx: ppyac.cmx pplex.cmi
+ppparse.cmo: pplex.cmi ppyac.cmi
+ppparse.cmx: pplex.cmx ppyac.cmx
+ppyac.cmo: code.cmi ppyac.cmi
+ppyac.cmx: code.cmi ppyac.cmi
+printer.cmo: tables.cmo
+printer.cmx: tables.cmx
+tables.cmo: tsort.cmo
+tables.cmx: tsort.cmx
diff --git a/compiler/.gitignore b/compiler/.gitignore
new file mode 100644
index 0000000..060114e
--- /dev/null
+++ b/compiler/.gitignore
@@ -0,0 +1,11 @@
+lexer.ml
+parser.output
+parser.ml
+parser.mli
+tkcompiler
+pp
+copyright.ml
+pplex.ml
+ppyac.ml
+ppyac.output
+ppyac.mli
diff --git a/compiler/Makefile b/compiler/Makefile
new file mode 100644
index 0000000..f6e5845
--- /dev/null
+++ b/compiler/Makefile
@@ -0,0 +1,79 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include ../support/Makefile.common
+
+OBJS= ../support/support.cmo flags.cmo copyright.cmo \
+ tsort.cmo tables.cmo printer.cmo lexer.cmo \
+ pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \
+ parser.cmo compile.cmo intf.cmo maincompile.cmo
+
+PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo
+
+all: tkcompiler$(EXE) pp$(EXE)
+
+tkcompiler$(EXE) : $(OBJS)
+ $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS)
+
+pp$(EXE): $(PPOBJS)
+ $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS)
+
+lexer.ml: lexer.mll
+ $(CAMLLEX) lexer.mll
+
+parser.ml parser.mli: parser.mly
+ $(CAMLYACC) -v parser.mly
+
+pplex.ml: pplex.mll
+ $(CAMLLEX) pplex.mll
+
+pplex.mli: ppyac.cmi
+
+ppyac.ml ppyac.mli: ppyac.mly
+ $(CAMLYACC) -v ppyac.mly
+
+copyright.ml: copyright
+ (echo "let copyright=\"\\"; \
+ sed -e 's/$$/\\n\\/' copyright; \
+ echo "\""; \
+ echo "let write ~w = w copyright;;") > copyright.ml
+
+clean :
+ rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml
+ rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output
+ rm -f tkcompiler$(EXE) pp$(EXE) parser.output
+
+scratch :
+ rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE)
+ rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE)
+
+install:
+ cp tkcompiler$(EXE) $(INSTALLDIR)
+ cp pp$(EXE) $(INSTALLDIR)
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmo .mlp
+
+.mli.cmi:
+ $(CAMLCOMP) $(COMPFLAGS) -I ../support $<
+
+.ml.cmo:
+ $(CAMLCOMP) $(COMPFLAGS) -I ../support $<
+
+depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli
+ $(CAMLDEP) *.mli *.ml > .depend
+
+include .depend
diff --git a/compiler/Makefile.nt b/compiler/Makefile.nt
new file mode 100644
index 0000000..74203f0
--- /dev/null
+++ b/compiler/Makefile.nt
@@ -0,0 +1,17 @@
+#######################################################################
+# #
+# MLTk, Tcl/Tk interface of OCaml #
+# #
+# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis #
+# projet Cristal, INRIA Rocquencourt #
+# Jacques Garrigue, Kyoto University RIMS #
+# #
+# Copyright 2002 Institut National de Recherche en Informatique et #
+# en Automatique and Kyoto University. All rights reserved. #
+# This file is distributed under the terms of the GNU Library #
+# General Public License, with the special exception on linking #
+# described in file LICENSE found in the OCaml source tree. #
+# #
+#######################################################################
+
+include Makefile
diff --git a/compiler/code.mli b/compiler/code.mli
new file mode 100644
index 0000000..bde9c44
--- /dev/null
+++ b/compiler/code.mli
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
+
+type code =
+ | Line of string
+ | Ifdef of bool * string * code list * code list option
+ | Define of string
+ | Undef of string
+;;
diff --git a/compiler/compile.ml b/compiler/compile.ml
new file mode 100644
index 0000000..c946300
--- /dev/null
+++ b/compiler/compile.ml
@@ -0,0 +1,1088 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tables
+
+(* CONFIGURE *)
+(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
+let safetype = true
+
+let labeloff ~at l = match l with
+ "", t -> t
+| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at))
+
+let labltk_labelstring l =
+ if l = "" then l else
+ if l.[0] = '?' then l ^ ":" else
+ "~" ^ l ^ ":"
+
+let camltk_labelstring l =
+ if l = "" then l else
+ if l.[0] = '?' then l ^ ":" else ""
+
+let labelstring l =
+ if !Flags.camltk then camltk_labelstring l
+ else labltk_labelstring l
+
+let labltk_typelabel l =
+ if l = "" then l else l ^ ":"
+
+let camltk_typelabel l =
+ if l = "" then l
+ else if l.[0] = '?' then l ^ ":" else ""
+
+let typelabel l =
+ if !Flags.camltk then camltk_typelabel l
+ else labltk_typelabel l
+
+let forbidden = [ "class"; "type"; "in"; "from"; "to" ]
+let nicknames =
+ [ "class", "clas";
+ "type", "typ" ]
+
+let small = String.lowercase_ascii
+
+let gettklabel fc =
+ match fc.template with
+ ListArg( StringArg s :: _ ) ->
+ let s = small s in
+ if s = "" then s else
+ let s =
+ if s.[0] = '-'
+ then String.sub s ~pos:1 ~len:(String.length s - 1)
+ else s
+ in begin
+ if List.mem s forbidden then
+ try List.assoc s nicknames
+ with Not_found -> small fc.var_name
+ else s
+ end
+ | _ -> raise (Failure "gettklabel")
+
+let count ~item:x l =
+ let count = ref 0 in
+ List.iter ~f:(fun y -> if x = y then incr count) l;
+ !count
+
+let caml_name s =
+ let b = Buffer.create (String.length s) in
+ for i = 0 to String.length s - 1 do
+ let c = s.[i] in
+ if c <> ':' then Buffer.add_char b c
+ else if i > 0 && s.[i-1] = ':' then Buffer.add_char b '_'
+ done;
+ Buffer.contents b
+
+(* Extract all types from a template *)
+let rec types_of_template = function
+ StringArg _ -> []
+ | TypeArg (l, t) -> [l, t]
+ | ListArg l -> List.flatten (List.map ~f:types_of_template l)
+ | OptionalArgs (l, tl, _) ->
+ begin
+ match List.flatten (List.map ~f:types_of_template tl) with
+ ["", t] -> ["?" ^ l, t]
+ | [_, _] -> raise (Failure "0 label required")
+ | _ -> raise (Failure "0 or more than 1 args in for optionals")
+ end
+
+(*
+ * Pretty print a type
+ * used to write ML type definitions
+ *)
+let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
+ let rec ppMLtype =
+ function
+ Unit -> "unit"
+ | Int -> "int"
+ | Float -> "float"
+ | Bool -> "bool"
+ | Char -> "char"
+ | String -> "string"
+(* new *)
+ | List (Subtype (sup, sub)) ->
+ if !Flags.camltk then "(* " ^ sub ^ " *) " ^ caml_name sup ^ " list"
+ else begin
+ if return then
+ caml_name sub ^ "_" ^ caml_name sup ^ " list"
+ else begin
+ try
+ let typdef = Hashtbl.find types_table sup in
+ let fcl = List.assoc sub typdef.subtypes in
+ let tklabels = List.map ~f:gettklabel fcl in
+ let l = List.map fcl ~f:
+ begin fun fc ->
+ "?" ^ begin let p = gettklabel fc in
+ if count ~item:p tklabels > 1 then small fc.var_name else p
+ end
+ ^ ":" ^
+ let l = types_of_template fc.template in
+ match l with
+ [] -> "unit"
+ | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype")
+ | l ->
+ "(" ^ String.concat ~sep:"*"
+ (List.map l
+ ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype")))
+ ^ ")"
+ end in
+ String.concat ~sep:" ->\n" l
+ with
+ Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
+ end
+ end
+ | List ty -> (ppMLtype ty) ^ " list"
+ | Product tyl ->
+ "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")"
+ | Record tyl ->
+ String.concat ~sep:" * "
+ (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
+ | Subtype ("widget", sub) ->
+ if !Flags.camltk then "(* " ^ sub ^" *) widget" else
+ caml_name sub ^ " widget"
+ | UserDefined "widget" ->
+ if !Flags.camltk then "widget"
+ else begin
+ if any then "any widget" else
+ let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
+ incr counter;
+ "'" ^ c ^ " widget"
+ end
+ | UserDefined s ->
+ if !Flags.camltk then s
+ else begin
+ (* a bit dirty hack for ImageBitmap and ImagePhoto *)
+ try
+ let typdef = Hashtbl.find types_table s in
+ if typdef.variant then
+ if return then try
+ "[>" ^
+ String.concat ~sep:"|"
+ (List.map typdef.constructors ~f:
+ begin
+ fun c ->
+ "`" ^ c.var_name ^
+ (match types_of_template c.template with
+ [] -> ""
+ | l -> " of " ^ ppMLtype (Product (List.map l
+ ~f:(labeloff ~at:"ppMLtype UserDefined"))))
+ end) ^ "]"
+ with
+ Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
+ else if not def && List.length typdef.constructors > 1 then
+ "[< " ^ s ^ "]"
+ else s
+ else s
+ with Not_found -> s
+ end
+ | Subtype (s, s') ->
+ if !Flags.camltk then "(* " ^ s' ^ " *) " ^ caml_name s else
+ caml_name s' ^ "_" ^ caml_name s
+ | Function (Product tyl) ->
+ raise (Failure "Function (Product tyl) ? ppMLtype")
+ | Function (Record tyl) ->
+ "(" ^ String.concat ~sep:" -> "
+ (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
+ ^ " -> unit)"
+ | Function ty ->
+ "(" ^ (ppMLtype ty) ^ " -> unit)"
+ | As (t, s) ->
+ if !Flags.camltk then ppMLtype t
+ else s
+ in
+ ppMLtype
+
+(* Produce a documentation version of a template *)
+let rec ppTemplate = function
+ StringArg s -> s
+ | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">"
+ | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}"
+ | OptionalArgs (l, tl, d) ->
+ "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl)
+ ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]"
+
+let doc_of_template = function
+ ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l)
+ | t -> ppTemplate t
+
+(*
+ * Type definitions
+ *)
+
+(* Write an ML constructor *)
+let write_constructor ~w {ml_name = mlconstr; template = t} =
+ w mlconstr;
+ begin match types_of_template t with
+ [] -> ()
+ | l -> w " of ";
+ w (ppMLtype ~any:true (Product (List.map l
+ ~f:(labeloff ~at:"write_constructor"))))
+ end;
+ w " (* tk option: "; w (doc_of_template t); w " *)"
+
+(* Write a rhs type decl *)
+let write_constructors ~w = function
+ [] -> fatal_error "empty type"
+ | x :: l ->
+ write_constructor ~w x;
+ List.iter l ~f:
+ begin fun x ->
+ w "\n | ";
+ write_constructor ~w x
+ end
+
+(* Write an ML variant *)
+let write_variant ~w {var_name = varname; template = t} =
+ w "`";
+ w varname;
+ begin match types_of_template t with
+ [] -> ()
+ | l ->
+ w " of ";
+ w (ppMLtype ~any:true ~def:true
+ (Product (List.map l ~f:(labeloff ~at:"write_variant"))))
+ end;
+ w " (* tk option: "; w (doc_of_template t); w " *)"
+
+let write_variants ~w = function
+ [] -> fatal_error "empty variants"
+ | l ->
+ List.iter l ~f:
+ begin fun x ->
+ w "\n | ";
+ write_variant ~w x
+ end
+
+(* Definition of a type *)
+let labltk_write_type ~intf:w ~impl:w' name ~def:typdef =
+ (* Only needed if no subtypes, otherwise use optionals *)
+ if typdef.subtypes = [] then begin
+ w "(* Variant type *)\n";
+ w ("type " ^ name ^ " = [");
+ write_variants ~w (sort_components typdef.constructors);
+ w "\n]\n\n"
+ end
+
+(* CamlTk: List of constructors, for runtime subtyping *)
+let write_constructor_set ~w ~sep = function
+ | [] -> fatal_error "empty type"
+ | x::l ->
+ w ("C" ^ x.ml_name);
+ List.iter l ~f: (function x ->
+ w sep;
+ w ("C" ^ x.ml_name))
+
+(* CamlTk: Definition of a type *)
+let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
+ (* Put markers for extraction *)
+ w "(* type *)\n";
+ w ("type " ^ name ^ " =\n");
+ w " | ";
+ write_constructors ~w (sort_components typdef.constructors);
+ w "\n(* /type *)\n\n";
+ (* Dynamic Subtyping *)
+ if typdef.subtypes <> [] then begin
+ (* The set of its constructors *)
+ if name = "options" then begin
+ w "(* type *)\n";
+ w ("type "^name^"_constrs =\n\t")
+ end else begin
+ (* added some prefix to avoid being picked up in documentation *)
+ w ("(* no doc *) type "^name^"_constrs =\n")
+ end;
+ w " | ";
+ write_constructor_set ~w:w ~sep: "\n | "
+ (sort_components typdef.constructors);
+ w "\n\n";
+ (* The set of all constructors *)
+ w' ("let "^caml_name name^"_any_table = [");
+ write_constructor_set ~w:w' ~sep:"; "
+ (sort_components typdef.constructors);
+ w' ("]\n\n");
+ (* The subset of constructors for each subtype *)
+ List.iter ~f:(function (s,l) ->
+ w' ("let "^caml_name name^"_"^caml_name s^"_table = [");
+ write_constructor_set ~w:w' ~sep:"; " (sort_components l);
+ w' ("]\n\n"))
+ typdef.subtypes
+ end
+
+let write_type ~intf:w ~impl:w' name ~def:typdef =
+ (if !Flags.camltk then camltk_write_type else labltk_write_type)
+ ~intf:w ~impl:w' name ~def:typdef
+
+(************************************************************)
+(* Converters *)
+(************************************************************)
+
+let rec converterTKtoCAML ~arg = function
+ | Int -> "int_of_string " ^ arg
+ | Float -> "float_of_string " ^ arg
+ | Bool -> "(match " ^ arg ^ " with\n\
+ | \"1\" -> true\n\
+ | \"0\" -> false\n\
+ | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
+ | Char -> "String.get " ^ arg ^ " 0"
+ | String -> arg
+ | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg
+ | Subtype ("widget", s') when not !Flags.camltk ->
+ String.concat ~sep:" "
+ ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
+ | Subtype (s, s') ->
+ if !Flags.camltk then
+ "cTKtoCAML" ^ s ^ " " ^ arg
+ else
+ "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
+ | List ty ->
+ begin match type_parser_arity ty with
+ OneToken ->
+ String.concat ~sep:" "
+ ["(List.map (function x ->";
+ converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
+ | MultipleToken ->
+ String.concat ~sep:" "
+ ["iterate_converter (function x ->";
+ converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
+ end
+ | As (ty, _) -> converterTKtoCAML ~arg ty
+ | t ->
+ prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t);
+ fatal_error "converterTKtoCAML"
+
+
+(*******************************)
+(* Wrappers *)
+(*******************************)
+let varnames ~prefix n =
+ let rec var i =
+ if i > n then []
+ else (prefix ^ string_of_int i) :: var (succ i)
+ in var 1
+
+(*
+ * generate wrapper source for callbacks
+ * transform a function ... -> unit in a function : unit -> unit
+ * using primitives arg_ ... from the protocol
+ * Warning: sequentiality is important in generated code
+ * TODO: remove arg_ stuff and process lists directly ?
+ *)
+
+let rec wrapper_code ~name ty =
+ match ty with
+ Unit -> "(fun _ -> " ^ name ^ " ())"
+ | As (ty, _) -> wrapper_code ~name ty
+ | ty ->
+ "(fun args ->\n " ^
+ begin match ty with
+ Product tyl -> raise (Failure "Product -> record was done. ???")
+ | Record tyl ->
+ (* variables for each component of the product *)
+ let vnames = varnames ~prefix:"a" (List.length tyl) in
+ (* getting the arguments *)
+ let readarg =
+ List.map2 vnames tyl ~f:
+ begin fun v (l, ty) ->
+ match type_parser_arity ty with
+ OneToken ->
+ "let (" ^ v ^ ", args) = " ^
+ converterTKtoCAML ~arg:"(List.hd args)" ty ^
+ ", List.tl args in\n "
+ | MultipleToken ->
+ "let (" ^ v ^ ", args) = " ^
+ converterTKtoCAML ~arg:"args" ty ^
+ " in\n "
+ end in
+ String.concat ~sep:"" readarg ^ name ^ " " ^
+ String.concat ~sep:" "
+ (List.map2 ~f:(fun v (l, _) ->
+ if !Flags.camltk then v
+ else labelstring l ^ v) vnames tyl)
+
+ (* all other types are read in one operation *)
+ | List ty ->
+ name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")"
+ | String ->
+ name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
+ | ty ->
+ begin match type_parser_arity ty with
+ OneToken ->
+ name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
+ | MultipleToken ->
+ "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^
+ " in\n " ^ name ^ " v"
+ end
+ end ^ ")"
+
+(*************************************************************)
+(* Parsers *)
+(* are required only for values returned by commands and *)
+(* functions (table is computed by the parser) *)
+
+(* Tuples/Lists are Ok if they don't contain strings *)
+(* they will be returned as list of strings *)
+
+(* Can we generate a "parser" ?
+ -> all constructors are unit and at most one int and one string, with null constr
+*)
+type parser_pieces =
+ { mutable zeroary : (string * string) list ; (* kw string, ml name *)
+ mutable intpar : string list; (* one at most, mlname *)
+ mutable stringpar : string list (* idem *)
+ }
+
+type mini_parser =
+ NoParser
+ | ParserPieces of parser_pieces
+
+let can_generate_parser constructors =
+ let pp = {zeroary = []; intpar = []; stringpar = []} in
+ if List.for_all constructors ~f:
+ begin fun c ->
+ let vname = if !Flags.camltk then c.ml_name else c.var_name in
+ match c.template with
+ ListArg [StringArg s] ->
+ pp.zeroary <- (s, vname) ::
+ pp.zeroary; true
+ | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] ->
+ if pp.intpar <> [] then false
+ else (pp.intpar <- [vname]; true)
+ | ListArg [TypeArg(_, String)] ->
+ if pp.stringpar <> [] then false
+ else (pp.stringpar <- [vname]; true)
+ | _ -> false
+ end
+ then ParserPieces pp
+ else NoParser
+
+
+(* We can generate parsers only for simple types *)
+(* we should avoid multiple walks *)
+let labltk_write_TKtoCAML ~w name ~def:typdef =
+ if typdef.parser_arity = MultipleToken then
+ prerr_string ("You must write cTKtoCAML" ^ name ^
+ " : string list ->" ^ name ^ " * string list\n")
+ else
+ let write ~consts ~name =
+ match can_generate_parser consts with
+ NoParser ->
+ prerr_string
+ ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
+ | ParserPieces pp ->
+ w ("let cTKtoCAML" ^ name ^ " n =\n");
+ (* First check integer *)
+ if pp.intpar <> [] then
+ begin
+ w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n");
+ w (" with _ ->\n")
+ end;
+ w (" match n with\n");
+ List.iter pp.zeroary ~f:
+ begin fun (tk, ml) ->
+ w " | \""; w tk; w "\" -> `"; w ml; w "\n"
+ end;
+ let final = if pp.stringpar <> [] then
+ "n -> `" ^ List.hd pp.stringpar ^ " n"
+ else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
+ ^ name ^ ": \" ^ s))"
+ in
+ w " | ";
+ w final;
+ w "\n\n"
+ in
+ begin
+ write ~name ~consts:typdef.constructors;
+ List.iter typdef.subtypes ~f: begin
+ fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
+ end
+ end
+
+let camltk_write_TKtoCAML ~w name ~def:typdef =
+ if typdef.parser_arity = MultipleToken then
+ prerr_string ("You must write cTKtoCAML" ^ name ^
+ " : string list ->" ^ name ^ " * string list\n")
+ else
+ let write ~consts ~name =
+ match can_generate_parser consts with
+ NoParser ->
+ prerr_string
+ ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
+ | ParserPieces pp ->
+ w ("let cTKtoCAML" ^ name ^ " n =\n");
+ (* First check integer *)
+ if pp.intpar <> [] then
+ begin
+ w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n");
+ w (" with _ ->\n")
+ end;
+ w (" match n with\n");
+ List.iter pp.zeroary ~f:
+ begin fun (tk, ml) ->
+ w " | \""; w tk; w "\" -> "; w ml; w "\n"
+ end;
+ let final = if pp.stringpar <> [] then
+ "n -> " ^ List.hd pp.stringpar ^ " n"
+ else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
+ ^ name ^ ": \" ^ s))"
+ in
+ w " | ";
+ w final;
+ w "\n\n"
+ in
+ begin
+ write ~name ~consts:typdef.constructors;
+ List.iter typdef.subtypes ~f: begin
+ fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
+ end
+ end
+
+let write_TKtoCAML ~w name ~def:typdef =
+ (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML)
+ ~w name ~def: typdef
+
+(******************************)
+(* Converters *)
+(******************************)
+
+(* Produce an in-lined converter OCaml -> Tk for simple types *)
+(* the converter is a function of type: -> string *)
+let rec converterCAMLtoTK ~context_widget argname ty =
+ match ty with
+ Int -> "TkToken (string_of_int " ^ argname ^ ")"
+ | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")"
+ | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\""
+ | Char -> "TkToken (Char.escaped " ^ argname ^ ")"
+ | String -> "TkToken " ^ argname
+ | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty
+ | UserDefined s ->
+ let name = "cCAMLtoTK" ^ s ^ " " in
+ let args = argname in
+ let args =
+ if !Flags.camltk then begin
+ if is_subtyped s then (* unconstraint subtype *)
+ s ^ "_any_table " ^ args
+ else args
+ end else args
+ in
+ let args =
+ if requires_widget_context s then
+ context_widget ^ " " ^ args
+ else args in
+ name ^ args
+ | Subtype ("widget", s') ->
+ if !Flags.camltk then
+ let name = "cCAMLtoTKwidget " in
+ let args = "widget_"^caml_name s'^"_table "^argname in
+ let args =
+ if requires_widget_context "widget" then
+ context_widget^" "^args
+ else args in
+ name^args
+ else begin
+ let name = "cCAMLtoTKwidget " in
+ let args = "(" ^ argname ^ " : " ^ caml_name s' ^ " widget)" in
+ name ^ args
+ end
+ | Subtype (s, s') ->
+ let name =
+ if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
+ else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
+ in
+ let args =
+ if !Flags.camltk then begin
+ caml_name s^"_"^caml_name s'^"_table "^argname
+ end else begin
+ if safetype then
+ "(" ^ argname ^ " : [< " ^ caml_name s' ^ "_" ^ caml_name s ^ "])"
+ else argname
+ end
+ in
+ let args =
+ if requires_widget_context s then context_widget ^ " " ^ args
+ else args in
+ name ^ args
+ | Product tyl ->
+ let vars = varnames ~prefix:"z" (List.length tyl) in
+ String.concat ~sep:" "
+ ("let" :: String.concat ~sep:"," vars :: "=" :: argname ::
+ "in TkTokenList [" ::
+ String.concat ~sep:"; "
+ (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) ::
+ ["]"])
+ | List ty -> (* Just added for Imagephoto.put *)
+ String.concat ~sep:" "
+ [(if !Flags.camltk then
+ "TkQuote (TkTokenList (List.map (fun y -> "
+ else
+ "TkQuote (TkTokenList (List.map ~f:(fun y -> ");
+ converterCAMLtoTK ~context_widget "y" ty;
+ ")";
+ argname;
+ "))"]
+ | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
+ | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK"
+ | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK"
+
+(*
+ * Produce a list of arguments from a template
+ * The idea here is to avoid allocation as much as possible
+ *
+ *)
+
+let code_of_template ~context_widget ?func:(funtemplate=false) template =
+ let catch_opts = ref ("", "") in (* class name and first option *)
+ let variables = ref [] in
+ let variables2 = ref [] in
+ let varcnter = ref 0 in
+ let optionvar = ref None in
+ let newvar1 l =
+ match !optionvar with
+ Some v -> optionvar := None; v
+ | None ->
+ incr varcnter;
+ let v = "v" ^ (string_of_int !varcnter) in
+ variables := (l, v) :: !variables; v in
+ let newvar2 l =
+ match !optionvar with
+ Some v -> optionvar := None; v
+ | None ->
+ incr varcnter;
+ let v = "v" ^ (string_of_int !varcnter) in
+ variables2 := (l, v) :: !variables2; v in
+ let newvar = ref newvar1 in
+ let rec coderec = function
+ StringArg s -> "TkToken \"" ^ s ^ "\""
+ | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk ->
+ begin try
+ let typdef = Hashtbl.find types_table sup in
+ let classdef = List.assoc sub typdef.subtypes in
+ let lbl = gettklabel (List.hd classdef) in
+ catch_opts := (sub ^ "_" ^ sup, lbl);
+ newvar := newvar2;
+ "TkTokenList opts"
+ with Not_found ->
+ raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
+ end
+ | TypeArg (l, List ty) ->
+ (if !Flags.camltk then
+ "TkTokenList (List.map (function x -> "
+ else
+ "TkTokenList (List.map ~f:(function x -> ")
+ ^ converterCAMLtoTK ~context_widget "x" ty
+ ^ ") " ^ !newvar l ^ ")"
+ | TypeArg (l, Function tyarg) ->
+ "let id = register_callback " ^ context_widget
+ ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg
+ ^ " in TkToken (\"camlcb \" ^ id)"
+ | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty
+ | ListArg l ->
+ "TkQuote (TkTokenList ["
+ ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
+ | OptionalArgs (l, tl, d) ->
+ let nv = !newvar ("?" ^ l) in
+ optionvar := Some nv; (* Store *)
+ let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
+ let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in
+ "TkTokenList (match " ^ nv ^ " with\n"
+ ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
+ ^ " | None -> [" ^ defstr ^ "])"
+ in
+ let code =
+ if funtemplate then
+ match template with
+ ListArg l ->
+ "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]"
+ | _ -> "[|" ^ coderec template ^ "|]"
+ else
+ match template with
+ ListArg [x] -> coderec x
+ | ListArg l ->
+ "TkTokenList [" ^
+ String.concat ~sep:";\n " (List.map ~f:coderec l) ^
+ "]"
+ | _ -> coderec template
+ in
+ code, List.rev !variables, List.rev !variables2, !catch_opts
+
+(*
+ * Converters for user defined types
+ *)
+
+(* For each case of a concrete type *)
+let labltk_write_clause ~w ~context_widget comp =
+ let warrow () = w " -> " in
+ w "`";
+ w comp.var_name;
+
+ let code, variables, variables2, (co, _) =
+ code_of_template ~context_widget comp.template in
+
+ (* no subtype I think ... *)
+ if co <> "" then raise (Failure "write_clause subtype ?");
+ begin match variables with
+ | [] -> warrow()
+ | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
+ | l ->
+ w " ( ";
+ w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
+ w ")";
+ warrow()
+ end;
+ w code
+
+let camltk_write_clause ~w ~context_widget ~subtype comp =
+ let warrow () =
+ w " -> ";
+ if subtype then
+ w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ")
+ in
+
+ w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *)
+
+ let code, variables, variables2, (co, _) =
+ code_of_template ~context_widget comp.template in
+
+ (* no subtype I think ... *)
+ if co <> "" then raise (Failure "write_clause subtype ?");
+ begin match variables with
+ | [] -> warrow()
+ | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
+ | l ->
+ w " ( ";
+ w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
+ w ")";
+ warrow()
+ end;
+ w code
+
+let write_clause ~w ~context_widget ~subtype comp =
+ if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp
+ else labltk_write_clause ~w ~context_widget comp
+
+(* The full converter *)
+let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
+ let write_one name constrs =
+ let subtype = typdef.subtypes <> [] in
+ w ("let cCAMLtoTK" ^ name);
+ let context_widget =
+ if typdef.requires_widget_context then begin
+ w " w"; "w"
+ end
+ else
+ "dummy" in
+ if !Flags.camltk && subtype then w " table";
+ if st then begin
+ w " : ";
+ if typdef.variant then w ("[< " ^ name ^ "]") else w name;
+ w " -> tkArgs "
+ end;
+ w (" = function");
+ List.iter constrs
+ ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c);
+ w "\n\n\n"
+ in
+
+ let constrs = typdef.constructors in
+ if !Flags.camltk then write_one name constrs
+ else begin
+ (* Only needed if no subtypes, otherwise use optionals *)
+ if typdef.subtypes == [] then
+ write_one name constrs
+ else
+ List.iter constrs ~f:
+ begin fun fc ->
+ let code, vars, _, (co, _) =
+ code_of_template ~context_widget:"dummy" fc.template in
+ if co <> "" then fatal_error "optionals in optionals";
+ let vars = List.map ~f:snd vars in
+ w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name);
+ w " ("; w (String.concat ~sep:", " vars); w ") =\n ";
+ w code; w "\n\n"
+ end
+ end
+
+(* Tcl does not really return "lists". It returns sp separated tokens *)
+let rec write_result_parsing ~w = function
+ List String ->
+ w "(splitlist res)"
+ | List ty ->
+ if !Flags.camltk then
+ w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
+ else
+ w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
+ | Product tyl -> raise (Failure "Product -> record was done. ???")
+ | Record tyl -> (* of course all the labels are "" *)
+ let rnames = varnames ~prefix:"r" (List.length tyl) in
+ w " let l = splitlist res in";
+ w ("\n if List.length l <> " ^ string_of_int (List.length tyl));
+ w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
+ w ("\n else ");
+ List.iter2 rnames tyl ~f:
+ begin fun r (l, ty) ->
+ if l <> "" then raise (Failure "lables in return type!!!");
+ w (" let " ^ r ^ ", l = ");
+ begin match type_parser_arity ty with
+ OneToken ->
+ w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l")
+ | MultipleToken ->
+ w (converterTKtoCAML ~arg:"l" ty)
+ end;
+ w (" in\n")
+ end;
+ w (String.concat ~sep:", " rnames)
+ | String ->
+ w (converterTKtoCAML ~arg:"res" String)
+ | As (ty, _) -> write_result_parsing ~w ty
+ | ty ->
+ match type_parser_arity ty with
+ OneToken -> w (converterTKtoCAML ~arg:"res" ty)
+ | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty)
+
+let labltk_write_function ~w def =
+ w ("let " ^ caml_name def.ml_name);
+ (* a bit approximative *)
+ let context_widget = match def.template with
+ ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
+ | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
+ | _ -> "dummy" in
+
+ let code, variables, variables2, (co, lbl) =
+ code_of_template ~func:true ~context_widget def.template in
+ (* Arguments *)
+ let uv, lv, ov =
+ let rec replace_args ~u ~l ~o = function
+ [] -> u, l, o
+ | ("", x) :: ls ->
+ replace_args ~u:(x :: u) ~l ~o ls
+ | (p, _ as x) :: ls when p.[0] = '?' ->
+ replace_args ~u ~l ~o:(x :: o) ls
+ | x :: ls ->
+ replace_args ~u ~l:(x :: l) ~o ls
+ in
+ replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2))
+ in
+ let has_opts = (ov <> [] || co <> "") in
+ if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
+ List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
+ if co <> "" then begin
+ if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
+ w " =\n";
+ w (co ^ "_optionals");
+ if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
+ w " (fun opts";
+ if uv = [] then w " ()" else
+ if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
+ w " ->\n"
+ end else begin
+ if (ov <> [] || lv = []) && uv = [] then w " ()" else
+ if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
+ w " =\n"
+ end;
+ begin match def.result with
+ | Unit | As (Unit, _) -> w "tkCommand "; w code
+ | ty ->
+ w "let res = tkEval "; w code ; w " in \n";
+ write_result_parsing ~w ty
+ end;
+ if co <> "" then w ")";
+ w "\n\n"
+
+let camltk_write_function ~w def =
+ w ("let " ^ caml_name def.ml_name);
+ (* a bit approximative *)
+ let context_widget = match def.template with
+ ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
+ | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
+ | _ -> "dummy" in
+
+ let code, variables, variables2, (co, lbl) =
+ code_of_template ~func:true ~context_widget def.template in
+ (* Arguments *)
+ let uv, ov =
+ let rec replace_args ~u ~o = function
+ [] -> u, o
+ | ("", x) :: ls ->
+ replace_args ~u:(x :: u) ~o ls
+ | (p, _ as x) :: ls when p.[0] = '?' ->
+ replace_args ~u ~o:(x :: o) ls
+ | (_,x) :: ls ->
+ replace_args ~u:(x::u) ~o ls
+ in
+ replace_args ~u:[] ~o:[] (List.rev (variables @ variables2))
+ in
+ let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in
+ if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
+ List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
+ begin
+ if uv = [] then w " ()" else
+ if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
+ w " =\n"
+ end;
+ begin match def.result with
+ | Unit | As (Unit, _) -> w "tkCommand "; w code
+ | ty ->
+ w "let res = tkEval "; w code ; w " in \n";
+ write_result_parsing ~w ty
+ end;
+ w "\n\n"
+
+(*
+ w ("let " ^ def.ml_name);
+ (* a bit approximative *)
+ let context_widget = match def.template with
+ ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
+ | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
+ | _ -> "dummy" in
+
+ let code, variables, variables2, (co, lbl) =
+ code_of_template ~func:true ~context_widget def.template in
+ let variables = variables @ variables2 in
+ (* Arguments *)
+ begin match variables with
+ [] -> w " () =\n"
+ | l ->
+ let has_normal_argument = ref false in
+ List.iter (fun (l,x) ->
+ w " ";
+ if l <> "" then
+ if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
+ else has_normal_argument := true;
+ w x) l;
+ if not !has_normal_argument then w " ()";
+ w " =\n"
+ end;
+ begin match def.result with
+ | Unit | As (Unit, _) -> w "tkCommand "; w code
+ | ty ->
+ w "let res = tkEval "; w code ; w " in \n";
+ write_result_parsing ~w ty
+ end;
+ w "\n\n"
+*)
+
+let write_function ~w def =
+ if !Flags.camltk then camltk_write_function ~w def
+ else labltk_write_function ~w def
+;;
+
+let labltk_write_create ~w clas =
+ let oclas = caml_name clas in
+ w ("let create ?name =\n");
+ w (" " ^ oclas ^ "_options_optionals (fun opts parent ->\n");
+ w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
+ w " tkCommand [|";
+ w ("TkToken \"" ^ clas ^ "\";\n");
+ w (" TkToken (Widget.name w);\n");
+ w (" TkTokenList opts |];\n");
+ w (" w)\n\n\n")
+
+let camltk_write_create ~w clas =
+ w ("let create ?name parent options =\n");
+ w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
+ w " tkCommand [|";
+ w ("TkToken \"" ^ clas ^ "\";\n");
+ w (" TkToken (Widget.name w);\n");
+ w (" TkTokenList (List.map (function x -> "^
+ converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
+ w (" |];\n");
+ w (" w\n\n")
+
+let camltk_write_named_create ~w clas =
+ w ("let create_named parent name options =\n");
+ w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n");
+ w " tkCommand [|";
+ w ("TkToken \"" ^ clas ^ "\";\n");
+ w (" TkToken (Widget.name w);\n");
+ w (" TkTokenList (List.map (function x -> "^
+ converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
+ w (" |];\n");
+ w (" w\n\n")
+
+(* Search Path. *)
+let search_path = ref ["."]
+
+(* taken from utils/misc.ml *)
+let find_in_path path name =
+ if not (Filename.is_implicit name) then
+ if Sys.file_exists name then name else raise Not_found
+ else begin
+ let rec try_dir = function
+ [] -> raise Not_found
+ | dir :: rem ->
+ let fullname = Filename.concat dir name in
+ if Sys.file_exists fullname then fullname else try_dir rem
+ in try_dir path
+ end
+
+(* builtin-code: the file (without suffix) is in .template... *)
+(* not efficient, but hell *)
+let write_external ~w def =
+ match def.template with
+ | StringArg fname ->
+ begin try
+ let realname = find_in_path !search_path (fname ^ ".ml") in
+ let ic = open_in_bin realname in
+ try
+ let code_list = Ppparse.parse_channel ic in
+ close_in ic;
+ List.iter (Ppexec.exec (fun _ -> ()) w)
+ (if !Flags.camltk then
+ Code.Define "CAMLTK" :: code_list else code_list );
+ with
+ | Ppparse.Error s ->
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ with
+ | Not_found ->
+ raise (Compiler_Error ("can't find external file: " ^ fname))
+ end
+ | _ -> raise (Compiler_Error "invalid external definition")
+
+let write_catch_optionals ~w clas ~def:typdef =
+ if typdef.subtypes = [] then () else
+ List.iter typdef.subtypes ~f:
+ begin fun (subclass, classdefs) ->
+ w ("let " ^ caml_name subclass ^ "_" ^ caml_name clas ^
+ "_optionals f = fun\n");
+ let tklabels = List.map ~f:gettklabel classdefs in
+ let l =
+ List.map classdefs ~f:
+ begin fun fc ->
+ (*
+ let code, vars, _, (co, _) =
+ code_of_template ~context_widget:"dummy" fc.template in
+ if co <> "" then fatal_error "optionals in optionals";
+ *)
+ let p = gettklabel fc in
+ (if count ~item:p tklabels > 1 then small fc.var_name else p),
+ small fc.ml_name
+ end in
+ let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in
+ let v =
+ List.map l ~f:
+ begin fun (si, s) ->
+ "(maycons ccCAMLtoTK" ^ caml_name clas ^ "_" ^ caml_name s ^ " " ^ si
+ end in
+ w (String.concat ~sep:"\n" p);
+ w " ->\n";
+ w " f ";
+ w (String.concat ~sep:"\n " v);
+ w "\n []";
+ w (String.make (List.length v) ')');
+ w "\n\n"
+ end
diff --git a/compiler/copyright b/compiler/copyright
new file mode 100644
index 0000000..87ab0d3
--- /dev/null
+++ b/compiler/copyright
@@ -0,0 +1,15 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
diff --git a/compiler/flags.ml b/compiler/flags.ml
new file mode 100644
index 0000000..d832b49
--- /dev/null
+++ b/compiler/flags.ml
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
+
+let camltk = ref false;;
diff --git a/compiler/intf.ml b/compiler/intf.ml
new file mode 100644
index 0000000..7f92259
--- /dev/null
+++ b/compiler/intf.ml
@@ -0,0 +1,191 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+
+(* Write .mli for widgets *)
+
+open Tables
+open Compile
+
+let labltk_write_create_p ~w wname =
+ w "val create :\n ?name:string ->\n";
+ begin
+ try
+ let option = Hashtbl.find types_table "options" in
+ let classdefs = List.assoc wname option.subtypes in
+ let tklabels = List.map ~f:gettklabel classdefs in
+ let l = List.map classdefs ~f:
+ begin fun fc ->
+ begin let p = gettklabel fc in
+ if count ~item:p tklabels > 1 then small fc.var_name else p
+ end,
+ fc.template
+ end in
+ w (String.concat ~sep:" ->\n"
+ (List.map l ~f:
+ begin fun (s, t) ->
+ " ?" ^ s ^ ":"
+ ^(ppMLtype
+ (match types_of_template t with
+ | [t] -> labeloff t ~at:"write_create_p"
+ | [] -> fatal_error "multiple"
+ | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l)))
+ end))
+ with Not_found -> fatal_error "in write_create_p"
+ end;
+ w (" ->\n 'a widget -> " ^ caml_name wname ^ " widget\n");
+ w "(** [create ?name parent options...] creates a new widget with\n";
+ w " parent [parent] and new patch component [name], if specified. *)\n\n"
+;;
+
+let camltk_write_create_p ~w wname =
+ w "val create : ?name: string -> widget -> options list -> widget \n";
+ w "(** [create ?name parent options] creates a new widget with\n";
+ w " parent [parent] and new patch component [name] if specified.\n";
+ w " Options are restricted to the widget class subset, and checked\n";
+ w " dynamically. *)\n\n"
+;;
+
+let camltk_write_named_create_p ~w wname =
+ w "val create_named : widget -> string -> options list -> widget \n";
+ w "(** [create_named parent name options] creates a new widget with\n";
+ w " parent [parent] and new patch component [name].\n";
+ w " This function is now obsolete and unified with [create]. *)\n\n";
+;;
+
+(* Unsafe: write special comment *)
+let labltk_write_function_type ~w def =
+ if not def.safe then w "(* unsafe *)\n";
+ w "val "; w def.ml_name; w " : ";
+ let us, ls, os =
+ let tys = types_of_template def.template in
+ let rec replace_args ~u ~l ~o = function
+ [] -> u, l, o
+ | (_, List(Subtype _) as x)::ls ->
+ replace_args ~u ~l ~o:(x::o) ls
+ | ("", _ as x)::ls ->
+ replace_args ~u:(x::u) ~l ~o ls
+ | (p, _ as x)::ls when p.[0] = '?' ->
+ replace_args ~u ~l ~o:(x::o) ls
+ | x::ls ->
+ replace_args ~u ~l:(x::l) ~o ls
+ in
+ replace_args ~u:[] ~l:[] ~o:[] (List.rev tys)
+ in
+ let counter = ref 0 in
+ let params =
+ if os = [] then us @ ls else ls @ os @ us in
+ List.iter params ~f:
+ begin fun (l, t) ->
+ if l <> "" then w (l ^ ":");
+ w (ppMLtype t ~counter);
+ w " -> "
+ end;
+ if (os <> [] || ls = []) && us = [] then w "unit -> ";
+ w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
+ w " \n";
+(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
+ if def.safe then w "\n"
+ else w "\n(* /unsafe *)\n"
+
+let camltk_write_function_type ~w def =
+ if not def.safe then w "(* unsafe *)\n";
+ w "val "; w def.ml_name; w " : ";
+ let us, os =
+ let tys = types_of_template def.template in
+ let rec replace_args ~u ~o = function
+ [] -> u, o
+ | ("", _ as x)::ls ->
+ replace_args ~u:(x::u) ~o ls
+ | (p, _ as x)::ls when p.[0] = '?' ->
+ replace_args ~u ~o:(x::o) ls
+ | x::ls ->
+ replace_args ~u:(x::u) ~o ls
+ in
+ replace_args ~u:[] ~o:[] (List.rev tys)
+ in
+ let counter = ref 0 in
+ let params =
+ if os = [] then us else os @ us in
+ List.iter params ~f:
+ begin fun (l, t) ->
+ if l <> "" then if l.[0] = '?' then w (l ^ ":");
+ w (ppMLtype t ~counter);
+ w " -> "
+ end;
+ if us = [] then w "unit -> ";
+ w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
+ w " \n";
+(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
+ if def.safe then w "\n"
+ else w "\n(* /unsafe *)\n"
+
+(*
+ if not def.safe then w "(* unsafe *)\n";
+ w "val "; w def.ml_name; w " : ";
+ let tys = types_of_template def.template in
+ let counter = ref 0 in
+ let have_normal_arg = ref false in
+ List.iter tys ~f:
+ begin fun (l, t) ->
+ if l <> "" then
+ if l.[0] = '?' then w (l^":")
+ else begin
+ have_normal_arg := true;
+ w (" (* " ^ l ^ ":*)")
+ end
+ else have_normal_arg := true;
+ w (ppMLtype t ~counter);
+ w " -> "
+ end;
+ if not !have_normal_arg then w "unit -> ";
+ w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
+ w " \n";
+ if def.safe then w "\n"
+ else w "\n(* /unsafe *)\n"
+*)
+
+let write_function_type ~w def =
+ if !Flags.camltk then camltk_write_function_type ~w def
+ else labltk_write_function_type ~w def
+
+let write_external_type ~w def =
+ match def.template with
+ | StringArg fname ->
+ begin try
+ let realname = find_in_path !search_path (fname ^ ".mli") in
+ let ic = open_in_bin realname in
+ try
+ let code_list = Ppparse.parse_channel ic in
+ close_in ic;
+ if not def.safe then w "(* unsafe *)\n";
+ List.iter (Ppexec.exec (fun _ -> ()) w)
+ (if !Flags.camltk then
+ Code.Define "CAMLTK" :: code_list else code_list );
+ if def.safe then w "\n\n"
+ else w "\n(* /unsafe *)\n\n"
+ with
+ | Ppparse.Error s ->
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ with
+ | Not_found ->
+ raise (Compiler_Error ("can't find external file: " ^ fname))
+ end
+ | _ -> raise (Compiler_Error "invalid external definition")
diff --git a/compiler/lexer.mll b/compiler/lexer.mll
new file mode 100644
index 0000000..8202dd6
--- /dev/null
+++ b/compiler/lexer.mll
@@ -0,0 +1,169 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+{
+open StdLabels
+open Lexing
+open Parser
+
+exception Lexical_error of string
+let current_line = ref 1
+
+
+(* The table of keywords *)
+
+let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
+
+let _ = List.iter
+ ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok)
+ [
+ "int", TYINT;
+ "float", TYFLOAT;
+ "bool", TYBOOL;
+ "char", TYCHAR;
+ "string", TYSTRING;
+ "list", LIST;
+ "as", AS;
+ "variant", VARIANT;
+ "widget", WIDGET;
+ "option", OPTION;
+ "type", TYPE;
+ "subtype", SUBTYPE;
+ "function", FUNCTION;
+ "module", MODULE;
+ "external", EXTERNAL;
+ "sequence", SEQUENCE;
+ "unsafe", UNSAFE
+]
+
+
+(* To buffer string literals *)
+
+let initial_string_buffer = Bytes.create 256
+let string_buff = ref initial_string_buffer
+let string_index = ref 0
+
+let reset_string_buffer () =
+ string_buff := initial_string_buffer;
+ string_index := 0;
+ ()
+
+let store_string_char c =
+ if !string_index >= Bytes.length (!string_buff) then begin
+ let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
+ Bytes.blit ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0
+ ~len:(Bytes.length (!string_buff));
+ string_buff := new_buff
+ end;
+ Bytes.set (!string_buff) (!string_index) c;
+ incr string_index
+
+let get_stored_string () =
+ let s = Bytes.sub_string (!string_buff) 0 (!string_index) in
+ string_buff := initial_string_buffer;
+ s
+(* To translate escape sequences *)
+
+let char_for_backslash = function
+ 'n' -> '\010'
+ | 'r' -> '\013'
+ | 'b' -> '\008'
+ | 't' -> '\009'
+ | c -> c
+
+let char_for_decimal_code lexbuf i =
+ Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+ 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+ (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
+
+let saved_string_start = ref 0
+
+}
+
+rule main = parse
+ '\010' { incr current_line; main lexbuf }
+ | [' ' '\013' '\009' '\026' '\012'] +
+ { main lexbuf }
+ | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ]
+ ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) *
+ { let s = Lexing.lexeme lexbuf in
+ try
+ Hashtbl.find keyword_table s
+ with Not_found ->
+ IDENT s }
+
+ | "\""
+ { reset_string_buffer();
+ (* Start of token is start of string. *)
+ saved_string_start := lexbuf.lex_start_pos;
+ string lexbuf;
+ lexbuf.lex_start_pos <- !saved_string_start;
+ STRING (get_stored_string()) }
+ | "(" { LPAREN }
+ | ")" { RPAREN }
+ | "[" { LBRACKET }
+ | "]" { RBRACKET }
+ | "{" { LBRACE }
+ | "}" { RBRACE }
+ | "," { COMMA }
+ | ";" { SEMICOLON }
+ | ":" {COLON}
+ | "?" {QUESTION}
+ | "/" {SLASH}
+ | "%" { comment lexbuf; main lexbuf }
+ | "##line" { line lexbuf; main lexbuf }
+ | eof { EOF }
+ | _
+ { raise (Lexical_error("illegal character")) }
+
+
+and string = parse
+ '"'
+ { () }
+ | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
+ { string lexbuf }
+ | '\\' ['\\' '"' 'n' 't' 'b' 'r']
+ { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+ string lexbuf }
+ | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+ { store_string_char(char_for_decimal_code lexbuf 1);
+ string lexbuf }
+ | eof
+ { raise (Lexical_error("string not terminated")) }
+ | '\010'
+ { incr current_line;
+ store_string_char(Lexing.lexeme_char lexbuf 0);
+ string lexbuf }
+ | _
+ { store_string_char(Lexing.lexeme_char lexbuf 0);
+ string lexbuf }
+
+and comment = parse
+ '\010' { incr current_line }
+ | eof { () }
+ | _ { comment lexbuf }
+
+and linenum = parse
+ | ['0'-'9']+ {
+ let next_line = int_of_string (Lexing.lexeme lexbuf) in
+ current_line := next_line - 1
+ }
+ | _ { raise (Lexical_error("illegal ##line directive: no line number"))}
+
+and line = parse
+ | [' ' '\t']* { linenum lexbuf }
diff --git a/compiler/maincompile.ml b/compiler/maincompile.ml
new file mode 100644
index 0000000..e259fa5
--- /dev/null
+++ b/compiler/maincompile.ml
@@ -0,0 +1,420 @@
+(***********************************************************************)
+(* *)
+(* MLTk, Tcl/Tk interface of OCaml *)
+(* *)
+(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
+(* projet Cristal, INRIA Rocquencourt *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the OCaml source tree. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Tables
+open Printer
+open Compile
+open Intf
+
+let flag_verbose = ref false
+let verbose_string s =
+ if !flag_verbose then prerr_string s
+let verbose_endline s =
+ if !flag_verbose then prerr_endline s
+
+let input_name = ref "Widgets.src"
+let output_dir = ref ""
+let destfile f = Filename.concat !output_dir f
+
+let usage () =
+ prerr_string "Usage: tkcompiler input.src\n";
+ flush stderr;
+ exit 1
+
+
+let prerr_error_header () =
+ prerr_string "File \""; prerr_string !input_name;
+ prerr_string "\", line ";
+ prerr_string (string_of_int !Lexer.current_line);
+ prerr_string ": "
+
+(* parse Widget.src config file *)
+let parse_file filename =
+ let ic = open_in_bin filename in
+ let lexbuf =
+ try
+ let code_list = Ppparse.parse_channel ic in
+ close_in ic;
+ let buf = Buffer.create 50000 in
+ List.iter (Ppexec.exec
+ (fun l -> Buffer.add_string buf
+ (Printf.sprintf "##line %d\n" l))
+ (Buffer.add_string buf))
+ (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
+ else code_list);
+ Lexing.from_string (Buffer.contents buf)
+ with
+ | Ppparse.Error s ->
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ in
+ try
+ while true do
+ Parser.entry Lexer.main lexbuf
+ done
+ with
+ | Parsing.Parse_error ->
+ prerr_error_header();
+ prerr_string "Syntax error \n";
+ exit 1
+ | Lexer.Lexical_error s ->
+ prerr_error_header();
+ prerr_string "Lexical error (";
+ prerr_string s;
+ prerr_string ")\n";
+ exit 1
+ | Duplicate_Definition (s,s') ->
+ prerr_error_header();
+ prerr_string s; prerr_string " "; prerr_string s';
+ prerr_string " is defined twice.\n";
+ exit 1
+ | Compiler_Error s ->
+ prerr_error_header();
+ prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
+ prerr_string "Please report bug\n";
+ exit 1
+ | End_of_file ->
+ ()
+
+(* The hack to provoke the production of cCAMLtoTKoptions_constrs *)
+
+(* Auxiliary function: the list of all the elements associated to keys
+ in an hash table. *)
+let elements t =
+ let elems = ref [] in
+ Hashtbl.iter (fun _ d -> elems := d :: !elems) t;
+ !elems;;
+
+(* Verifies that duplicated clauses are semantically equivalent and
+ returns a unique set of clauses. *)
+let uniq_clauses = function
+ | [] -> []
+ | l ->
+ let check_constr constr1 constr2 =
+ if constr1.template <> constr2.template then
+ begin
+ let code1, vars11, vars12, opts1 =
+ code_of_template ~context_widget:"dummy" constr1.template in
+ let code2, vars12, vars22, opts2 =
+ code_of_template ~context_widget:"dummy" constr2.template in
+ let err =
+ Printf.sprintf
+ "uncompatible redondant clauses for variant %s:\n %s\n and\n %s"
+ constr1.var_name code1 code2 in
+ Format.print_newline();
+ print_fullcomponent constr1;
+ Format.print_newline();
+ print_fullcomponent constr2;
+ Format.print_newline();
+ prerr_endline err;
+ fatal_error err
+ end in
+ let t = Hashtbl.create 11 in
+ List.iter l
+ ~f:(fun constr ->
+ let c = constr.var_name in
+ if Hashtbl.mem t c
+ then (check_constr constr (Hashtbl.find t c))
+ else Hashtbl.add t c constr);
+ elements t;;
+
+let option_hack oc =
+ if Hashtbl.mem types_table "options" then
+ let typdef = Hashtbl.find types_table "options" in
+ let hack =
+ { parser_arity = OneToken;
+ constructors = begin
+ let constrs =
+ List.map typdef.constructors ~f:
+ begin fun c ->
+ { component = Constructor;
+ ml_name = (if !Flags.camltk then "C" ^ c.ml_name
+ else c.ml_name);
+ var_name = c.var_name; (* as variants *)
+ template =
+ begin match c.template with
+ ListArg (x :: _) -> x
+ | _ -> fatal_error "bogus hack"
+ end;
+ result = UserDefined "options_constrs";
+ safe = true }
+ end in
+ if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
+ end;
+ subtypes = [];
+ requires_widget_context = false;
+ variant = false }
+ in
+ write_CAMLtoTK
+ ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs"
+
+let realname name =
+ (* module name fix for camltk *)
+ let name = caml_name name in
+ if !Flags.camltk then "c" ^ String.capitalize_ascii name
+ else name
+;;
+
+(* analize the parsed Widget.src and output source files *)
+let compile () =
+ verbose_endline "Creating _tkgen.ml ...";
+ let oc = open_out_bin (destfile "_tkgen.ml") in
+ let oc' = open_out_bin (destfile "_tkigen.ml") in
+ let oc'' = open_out_bin (destfile "_tkfgen.ml") in
+ let sorted_types = Tsort.sort types_order in
+ verbose_endline " writing types ...";
+ List.iter sorted_types ~f:
+ begin fun typname ->
+ verbose_string (" " ^ typname ^ " ");
+ try
+ let typdef = Hashtbl.find types_table typname in
+ verbose_string "type ";
+ write_type ~intf:(output_string oc)
+ ~impl:(output_string oc')
+ typname ~def:typdef;
+ verbose_string "C2T ";
+ write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef;
+ verbose_string "T2C ";
+ if List.mem typname !types_returned then
+ write_TKtoCAML ~w:(output_string oc') typname ~def:typdef;
+ verbose_string "CO ";
+ if not !Flags.camltk then (* only for LablTk *)
+ write_catch_optionals ~w:(output_string oc') typname ~def:typdef;
+ verbose_endline "."
+ with Not_found ->
+ if not (List.mem_assoc typname !types_external) then
+ begin
+ verbose_string "Type ";
+ verbose_string typname;
+ verbose_string " is undeclared external or undefined\n"
+ end
+ else verbose_endline "."
+ end;
+ verbose_endline " option hacking ...";
+ option_hack oc';
+ verbose_endline " writing functions ...";
+ List.iter ~f:(write_function ~w:(output_string oc'')) !function_table;
+ close_out oc;
+ close_out oc';
+ close_out oc'';
+ (* Write the interface for public functions *)
+ (* this interface is used only for documentation *)
+ verbose_endline "Creating _tkgen.mli ...";
+ let oc = open_out_bin (destfile "_tkgen.mli") in
+ List.iter (sort_components !function_table)
+ ~f:(write_function_type ~w:(output_string oc));
+ close_out oc;
+ verbose_endline "Creating other ml, mli ...";
+ let write_module wname wdef =
+ verbose_endline (" "^wname);
+ let modname = realname wname in
+ let oc = open_out_bin (destfile (modname ^ ".ml"))
+ and oc' = open_out_bin (destfile (modname ^ ".mli")) in
+ Copyright.write ~w:(output_string oc);
+ Copyright.write ~w:(output_string oc');
+ begin match wdef.module_type with
+ Widget -> output_string oc' ("(** The "^wname^" widget *)\n")
+ | Family -> output_string oc' ("(** The "^wname^" commands *)\n")
+ end;
+ List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
+ begin
+ if !Flags.camltk then
+ [ "open CTk\n";
+ "open Tkintf\n";
+ "open Widget\n";
+ "open Textvariable\n\n" ]
+ else
+ [ "open StdLabels\n";
+ "open Tk\n";
+ "open Tkintf\n";
+ "open Widget\n";
+ "open Textvariable\n\n" ]
+ end;
+ output_string oc "open Protocol\n";
+ begin match wdef.module_type with
+ Widget ->
+ if !Flags.camltk then begin
+ camltk_write_create ~w:(output_string oc) wname;
+ camltk_write_named_create ~w:(output_string oc) wname;
+ camltk_write_create_p ~w:(output_string oc') wname;
+ camltk_write_named_create_p ~w:(output_string oc') wname;
+ end else begin
+ labltk_write_create ~w:(output_string oc) wname;
+ labltk_write_create_p ~w:(output_string oc') wname
+ end
+ | Family -> ()
+ end;
+ List.iter ~f:(write_function ~w:(output_string oc))
+ (sort_components wdef.commands);
+ List.iter ~f:(write_function_type ~w:(output_string oc'))
+ (sort_components wdef.commands);
+ List.iter ~f:(write_external ~w:(output_string oc))
+ (sort_components wdef.externals);
+ List.iter ~f:(write_external_type ~w:(output_string oc'))
+ (sort_components wdef.externals);
+ close_out oc;
+ close_out oc'
+ in Hashtbl.iter write_module module_table;
+
+ (* wrapper code camltk.ml and labltk.ml *)
+ if !Flags.camltk then begin
+ let oc = open_out_bin (destfile "camltk.ml") in
+ Copyright.write ~w:(output_string oc);
+ output_string oc
+"(** This module Camltk provides the module name spaces of the CamlTk API.\n\
+\n\
+ The users of the CamlTk API should open this module first to access\n\
+ the types, functions and modules of the CamlTk API easier.\n\
+ For the documentation of each sub modules such as [Button] and [Toplevel],\n\
+ refer to its defintion file, [cButton.mli], [cToplevel.mli], etc.\n\
+ *)\n\
+\n\
+";
+ output_string oc "include CTk\n";
+ output_string oc "module Tk = CTk\n";
+ Hashtbl.iter (fun name _ ->
+ let cname = realname name in
+ output_string oc (Printf.sprintf "module %s = %s;;\n"
+ (String.capitalize_ascii (caml_name name))
+ (String.capitalize_ascii cname))) module_table;
+ close_out oc
+ end else begin
+ let oc = open_out_bin (destfile "labltk.ml") in
+ Copyright.write ~w:(output_string oc);
+ output_string oc
+"(** This module Labltk provides the module name spaces of the LablTk API,\n\
+ useful to call LablTk functions inside CamlTk programs. 100% LablTk users\n\
+ do not need to use this. *)\n\
+\n\
+";
+ output_string oc "module Widget = Widget;;\n\
+module Protocol = Protocol;;\n\
+module Textvariable = Textvariable;;\n\
+module Fileevent = Fileevent;;\n\
+module Timer = Timer;;\n\
+";
+ Hashtbl.iter (fun name _ ->
+ let cname = realname name in
+ output_string oc (Printf.sprintf "module %s = %s;;\n"
+ (String.capitalize_ascii (caml_name name))
+ (String.capitalize_ascii cname))) module_table;
+ (* widget typer *)
+ output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
+ Hashtbl.iter (fun name def ->
+ match def.module_type with
+ | Widget ->
+ let name = caml_name name in
+ output_string oc (Printf.sprintf
+ "let %s (w : any widget) =\n" name);
+ output_string oc (Printf.sprintf
+ " Rawwidget.check_class w widget_%s_table;\n" name);
+ output_string oc (Printf.sprintf
+ " (Obj.magic w : %s widget);;\n\n" name);
+ | _ -> () ) module_table;
+ close_out oc
+ end;
+
+ (* write the module list for the Makefile *)
+ (* and hack to death until it works *)
+ let oc = open_out_bin (destfile "modules") in
+ if !Flags.camltk then output_string oc "CWIDGETOBJS="
+ else output_string oc "WIDGETOBJS=";
+ Hashtbl.iter
+ (fun name _ ->
+ let name = realname name in
+ output_string oc " ";
+ output_string oc name;
+ output_string oc ".cmo")
+ module_table;
+ output_string oc "\n";
+ Hashtbl.iter
+ (fun name _ ->
+ let name = realname name in
+ output_string oc name;
+ output_string oc ".ml ")
+ module_table;
+ output_string oc ": _tkgen.ml\n\n";
+ Hashtbl.iter
+ (fun name _ ->
+ let name = realname name in
+ output_string oc name;
+ output_string oc ".cmo : ";
+ output_string oc name;
+ output_string oc ".ml\n";
+ output_string oc name;
+ output_string oc ".cmi : ";
+ output_string oc name;
+ output_string oc ".mli\n")
+ module_table;
+
+ (* for camltk.ml wrapper *)
+ if !Flags.camltk then begin
+ output_string oc "camltk.cmo : cTk.cmo ";
+ Hashtbl.iter
+ (fun name _ ->
+ let name = realname name in
+ output_string oc name;
+ output_string oc ".cmo ") module_table;
+ output_string oc "\n"
+ end;
+ close_out oc
+
+let main () =
+ Arg.parse
+ [ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
+ "Make output verbose";
+ "-camltk", Arg.Unit (fun () -> Flags.camltk := true),
+ "Make CamlTk interface";
+ "-outdir", Arg.String (fun s -> output_dir := s),
+ "output directory";
+ "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true),
+ "debug preprocessor"
+ ]
+ (fun filename -> input_name := filename)
+ "Usage: tkcompiler