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 " ; + if !output_dir = "" then begin + prerr_endline "specify -outdir option"; + exit 1 + end; + try + verbose_endline "Parsing..."; + parse_file !input_name; + verbose_endline "Compiling..."; + compile (); + verbose_endline "Finished"; + exit 0 + with + | Lexer.Lexical_error s -> + prerr_string "Invalid lexical character: "; + prerr_endline s; + exit 1 + | Duplicate_Definition (s, s') -> + prerr_string s; prerr_string " "; prerr_string s'; + prerr_endline " is redefined illegally"; + exit 1 + | Invalid_implicit_constructor c -> + prerr_string "Constructor "; + prerr_string c; + prerr_endline " is used implicitly before defined"; + exit 1 + | Tsort.Cyclic -> + prerr_endline "Cyclic dependency of types"; + exit 1 + +let () = Printexc.catch main () diff --git a/compiler/parser.mly b/compiler/parser.mly new file mode 100644 index 0000000..46023c6 --- /dev/null +++ b/compiler/parser.mly @@ -0,0 +1,335 @@ +/***********************************************************************/ +/* */ +/* 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 Tables + +%} + +/* Tokens */ +%token IDENT +%token STRING +%token EOF + +%token LPAREN /* "(" */ +%token RPAREN /* ")" */ +%token COMMA /* "," */ +%token SEMICOLON /* ";" */ +%token COLON /* ":" */ +%token QUESTION /* "?" */ +%token LBRACKET /* "[" */ +%token RBRACKET /* "]" */ +%token LBRACE /* "{" */ +%token RBRACE /* "}" */ +%token SLASH /* "/" */ + +%token TYINT /* "int" */ +%token TYFLOAT /* "float" */ +%token TYBOOL /* "bool" */ +%token TYCHAR /* "char" */ +%token TYSTRING /* "string" */ +%token LIST /* "list" */ + +%token AS /* "as" */ +%token VARIANT /* "variant" */ +%token WIDGET /* "widget" */ +%token OPTION /* "option" */ +%token TYPE /* "type" */ +%token SEQUENCE /* "sequence" */ +%token SUBTYPE /* "subtype" */ +%token FUNCTION /* "function" */ +%token MODULE /* "module" */ +%token EXTERNAL /* "external" */ +%token UNSAFE /* "unsafe" */ +/* Entry points */ +%start entry +%type entry + +%% +TypeName: + IDENT { String.uncapitalize_ascii $1 } + | WIDGET { "widget" } +; + +/* Atomic types */ +Type0 : + TYINT + { Int } + | TYFLOAT + { Float } + | TYBOOL + { Bool } + | TYCHAR + { Char } + | TYSTRING + { String } + | TypeName + { UserDefined $1 } +; + +/* Camltk/Labltk types */ +Type0_5: + | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } + | Type0 { $1 } +; + +/* with subtypes */ +Type1 : + Type0_5 + { $1 } + | TypeName LPAREN IDENT RPAREN + { Subtype ($1, $3) } + | WIDGET LPAREN IDENT RPAREN + { Subtype ("widget", $3) } + | OPTION LPAREN IDENT RPAREN + { Subtype ("options", $3) } + | Type1 AS STRING + { As ($1, $3) } + | LBRACE Type_list RBRACE + { Product $2 } +; + +/* with list constructors */ +Type2 : + Type1 + { $1 } + | Type2 LIST + { List $1 } +; + +Labeled_type2 : + Type2 + { "", $1 } + | IDENT COLON Type2 + { $1, $3 } +; + +/* products */ +Type_list : + Type2 COMMA Type_list + { $1 :: $3 } + | Type2 + { [$1] } +; + +/* records */ +Type_record : + Labeled_type2 COMMA Type_record + { $1 :: $3 } + | Labeled_type2 + { [$1] } +; + +/* callback arguments or function results*/ +FType : + LPAREN RPAREN + { Unit } + | LPAREN Type2 RPAREN + { $2 } + | LPAREN Type_record RPAREN + { Record $2 } +; + +Type : + Type2 + { $1 } + | FUNCTION FType + { Function $2 } +; + + + +SimpleArg: + STRING + {StringArg $1} + | Type + {TypeArg ("", $1) } +; + +Arg: + STRING + {StringArg $1} + | Type + {TypeArg ("", $1) } + | IDENT COLON Type + {TypeArg ($1, $3)} + | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList + {OptionalArgs ( $2, $5, $7 )} + | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList + {OptionalArgs ( "widget", $5, $7 )} + | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET + {OptionalArgs ( $2, $5, [] )} + | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET + {OptionalArgs ( "widget", $5, [] )} + | WIDGET COLON Type + {TypeArg ("widget", $3)} + | Template + { $1 } +; + +SimpleArgList: + SimpleArg SEMICOLON SimpleArgList + { $1 :: $3} + | SimpleArg + { [$1] } +; + +ArgList: + Arg SEMICOLON ArgList + { $1 :: $3} + | Arg + { [$1] } +; + +/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */ +DefaultList : + LBRACKET LBRACE ArgList RBRACE RBRACKET + {$3} + +/* Template */ +Template : + LBRACKET ArgList RBRACKET + { ListArg $2 } +; + + +/* Constructors for type declarations */ +Constructor : + IDENT Template + {{ component = Constructor; + ml_name = $1; + var_name = getvarname $1 $2; + template = $2; + result = Unit; + safe = true }} + | IDENT LPAREN IDENT RPAREN Template + {{ component = Constructor; + ml_name = $1; + var_name = $3; + template = $5; + result = Unit; + safe = true }} +; + +AbbrevConstructor : + Constructor + { Full $1 } + | IDENT + { Abbrev $1 } +; + +Constructors : + Constructor Constructors + { $1 :: $2 } +| Constructor + { [$1] } +; + +AbbrevConstructors : + AbbrevConstructor AbbrevConstructors + { $1 :: $2 } +| AbbrevConstructor + { [$1] } +; + +Safe: + /* */ + { true } + | UNSAFE + { false } + +Command : + Safe FUNCTION FType IDENT Template + {{component = Command; ml_name = $4; var_name = ""; + template = $5; result = $3; safe = $1 }} +; + +External : + Safe EXTERNAL IDENT STRING + {{component = External; ml_name = $3; var_name = ""; + template = StringArg $4; result = Unit; safe = $1}} +; + +Option : + OPTION IDENT Template + {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3; + template = $3; result = Unit; safe = true }} + /* Abbreviated */ +| OPTION IDENT LPAREN IDENT RPAREN Template + {{component = Constructor; ml_name = $2; var_name = $4; + template = $6; result = Unit; safe = true }} + /* Abbreviated */ +| OPTION IDENT + { retrieve_option $2 } +; + +WidgetComponents : + /* */ + { [] } + | Command WidgetComponents + { $1 :: $2 } + | Option WidgetComponents + { $1 :: $2 } + | External WidgetComponents + { $1 :: $2 } +; + +ModuleComponents : + /* */ + { [] } + | Command ModuleComponents + { $1 :: $2 } + | External ModuleComponents + { $1 :: $2 } +; + +ParserArity : + /* */ + { OneToken } + | SEQUENCE + { MultipleToken } +; + +ModuleName : + IDENT + { $1 } + | STRING + { $1 } +; + +entry : + TYPE ParserArity TypeName LBRACE Constructors RBRACE + { enter_type $3 $2 $5 } +| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE + { enter_type $4 $3 $6 ~variant: true } +| TYPE ParserArity TypeName EXTERNAL + { enter_external_type $3 $2 } +| SUBTYPE ParserArity OPTION LPAREN ModuleName RPAREN LBRACE AbbrevConstructors RBRACE + { enter_subtype "options" $2 $5 $8 } +| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE + { enter_subtype $3 $2 $5 $8 } +| Command + { enter_function $1 } +| WIDGET ModuleName LBRACE WidgetComponents RBRACE + { enter_widget $2 $4 } +| MODULE ModuleName LBRACE ModuleComponents RBRACE + { enter_module (String.uncapitalize_ascii $2) $4 } +| EOF + { raise End_of_file } +; diff --git a/compiler/pp.ml b/compiler/pp.ml new file mode 100644 index 0000000..c6d4f79 --- /dev/null +++ b/compiler/pp.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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 _ = + try + let code_list = Ppparse.parse_channel stdin in + List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list + with + | Ppparse.Error s -> prerr_endline s; exit 2 +;; diff --git a/compiler/ppexec.ml b/compiler/ppexec.ml new file mode 100644 index 0000000..dd66928 --- /dev/null +++ b/compiler/ppexec.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +open Code + +let debug = ref false +let defined = ref [] +let linenum = ref 1 + +let rec nop = function + | Line _ -> incr linenum + | Ifdef (_, _, c1, c2o) -> + List.iter nop c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end + | _ -> () +;; + +let rec exec lp f = function + | Line line -> + if !debug then + prerr_endline (Printf.sprintf "%03d: %s" !linenum + (String.sub line 0 ((String.length line) - 1))); + f line; incr linenum + | Ifdef (sw, k, c1, c2o) -> + if List.mem k !defined = sw then begin + List.iter (exec lp f) c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end; + lp !linenum + end else begin + List.iter nop c1; + match c2o with + | Some c2 -> + lp !linenum; + List.iter (exec lp f) c2 + | None -> () + end + | Define k -> defined := k :: !defined + | Undef k -> + defined := List.fold_right (fun k' s -> + if k = k' then s else k' :: s) [] !defined +;; diff --git a/compiler/pplex.mli b/compiler/pplex.mli new file mode 100644 index 0000000..0502fc9 --- /dev/null +++ b/compiler/pplex.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +exception Error of string +val token : Lexing.lexbuf -> Ppyac.token diff --git a/compiler/pplex.mll b/compiler/pplex.mll new file mode 100644 index 0000000..6559d8e --- /dev/null +++ b/compiler/pplex.mll @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +{ +open Ppyac +exception Error of string +let linenum = ref 1 +} + +let blank = [' ' '\013' '\009' '\012'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + +rule token = parse + blank + { token lexbuf } +| "##" [' ' '\t']* { directive lexbuf } +| ("#")? [^ '#' '\n']* '\n'? { + begin + let str = Lexing.lexeme lexbuf in + if String.length str <> 0 && str.[String.length str - 1] = '\n' then + begin + incr linenum + end; + OTHER (str) + end + } +| eof { EOF } + +and directive = parse +| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} +| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} +| "else" { ELSE } +| "endif" { ENDIF } +| "define" [' ' '\t']+* { DEFINE (ident lexbuf)} +| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} +| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} + +and ident = parse +| lowercase identchar* | uppercase identchar* + { Lexing.lexeme lexbuf } +| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/compiler/ppparse.ml b/compiler/ppparse.ml new file mode 100644 index 0000000..2b0fdbf --- /dev/null +++ b/compiler/ppparse.ml @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +exception Error of string + +let parse_channel ic = + let lexbuf = Lexing.from_channel ic in + try + Ppyac.code_list Pplex.token lexbuf + with + | Pplex.Error s -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d: %s" + loc_start loc_end s)) + | Parsing.Parse_error -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d" + loc_start loc_end)) +;; diff --git a/compiler/ppyac.mly b/compiler/ppyac.mly new file mode 100644 index 0000000..f92ef96 --- /dev/null +++ b/compiler/ppyac.mly @@ -0,0 +1,52 @@ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +%{ +open Code +%} + +%token IFDEF +%token IFNDEF +%token ELSE +%token ENDIF +%token DEFINE +%token UNDEF +%token OTHER +%token EOF + +/* entry */ + +%start code_list +%type code_list + +%% + +code_list: + /* empty */ { [] } + | code code_list { $1 :: $2 } +; + +code: + | DEFINE { Define $1 } + | UNDEF { Undef $1 } + | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } + | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } + | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } + | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } + | OTHER { Line $1 } +; + +%% diff --git a/compiler/printer.ml b/compiler/printer.ml new file mode 100644 index 0000000..bf421c6 --- /dev/null +++ b/compiler/printer.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. *) +(* *) +(***********************************************************************) + +open Tables;; + +open Format;; + +let (.![]<-) = Bytes.set ;; + +let escape_string s = + let more = ref 0 in + for i = 0 to String.length s - 1 do + match s.[i] with + | '\\' | '\"' | '\'' -> incr more + | _ -> () + done; + if !more = 0 then s else + let res = Bytes.create (String.length s + !more) in + let j = ref 0 in + for i = 0 to String.length s - 1 do + let c = s.[i] in + match c with + | '\\' | '\"' |'\'' -> res.![!j] <- '\\'; incr j; res.![!j] <- c; incr j + | _ -> res.![!j] <- c; incr j + done; + Bytes.to_string res +;; + +let escape_char c = if c = '\'' then "\\\'" else String.make 1 c;; + +let print_quoted_string s = printf "\"%s\"" (escape_string s);; +let print_quoted_char c = printf "\'%s\'" (escape_char c);; +let print_quoted_int i = + if i < 0 then printf "(%d)" i else printf "%d" i +;; +let print_quoted_float f = + if f <= 0.0 then printf "(%f)" f else printf "%f" f +;; + +(* Iterators *) +let print_list f l = + printf "@[<1>["; + let rec pl = function + | [] -> printf "@;<0 -1>]@]" + | [x] -> f x; pl [] + | x :: xs -> f x; printf ";@ "; pl xs in + pl l +;; + +let print_array f v = + printf "@[<2>[|"; + let l = Array.length v in + if l >= 1 then f v.(0); + if l >= 2 then + for i = 1 to l - 1 do + printf ";@ "; f v.(i) + done; + printf "@;<0 -1>|]@]" +;; + +let print_option f = function + | None -> print_string "None" + | Some x -> printf "@[<1>Some@ "; f x; printf "@]" +;; + +let print_bool = function + | true -> print_string "true" | _ -> print_string "false" +;; + +let print_poly x = print_string "";; + +(* Types of the description language *) +let rec print_mltype = function + | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" + | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" + | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" + | Product l_m -> + printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" + | Record l_t_s_m -> + printf "@[<1>(%s@ " "Record"; + print_list + (function (s, m) -> + printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; + printf ")@]") + l_t_s_m; + printf ")@]" + | UserDefined s -> + printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" + | Subtype (s, s0) -> + printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; + printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" + | Function m -> + printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" + | As (m, s) -> + printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; + print_quoted_string s; printf ")@]"; printf ")@]" +;; + +let rec print_template = function + | StringArg s -> + printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" + | TypeArg (s, m) -> + printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; + printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" + | ListArg l_t -> + printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; + printf ")@]" + | OptionalArgs (s, l_t, l_t0) -> + printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; + print_quoted_string s; printf ",@ "; print_list print_template l_t; + printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]" +;; + +(* Sorts of components *) +let rec print_component_type = function + | Constructor -> printf "Constructor" | Command -> printf "Command" + | External -> printf "External" +;; + +(* Full definition of a component *) +let rec print_fullcomponent = function + {component = c; ml_name = s; var_name = s0; template = t; result = m; + safe = b; + } -> + printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; + printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; + printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; + printf ";@]@ "; printf "@[<1>template =@ "; print_template t; + printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; + printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]" +;; + +(* components are given either in full or abbreviated *) +let rec print_component = function + | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" + | Abbrev s -> + printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]" +;; + +(* A type definition *) +(* + requires_widget_context: the converter of the type MUST be passed + an additional argument of type Widget. +*) +let rec print_parser_arity = function + | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken" +;; + +let rec print_type_def = function + {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; + requires_widget_context = b; variant = b0; + } -> + printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; + printf ";@]@ "; printf "@[<1>constructors =@ "; + print_list print_fullcomponent l_f; printf ";@]@ "; + printf "@[<1>subtypes =@ "; + print_list + (function (s, l_f0) -> + printf "@[<1>("; print_quoted_string s; printf ",@ "; + print_list print_fullcomponent l_f0; printf ")@]") + l_t_s_l_f; + printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; + printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; + printf "@,}@]" +;; + +let rec print_module_type = function + | Widget -> printf "Widget" | Family -> printf "Family" +;; + +let rec print_module_def = function + {module_type = m; commands = l_f; externals = l_f0; } -> + printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; + printf ";@]@ "; printf "@[<1>commands =@ "; + print_list print_fullcomponent l_f; printf ";@]@ "; + printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; + printf ";@]@ "; printf "@,}@]" +;; diff --git a/compiler/tables.ml b/compiler/tables.ml new file mode 100644 index 0000000..0fd3300 --- /dev/null +++ b/compiler/tables.ml @@ -0,0 +1,415 @@ +(***********************************************************************) +(* *) +(* 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 + +(* Internal compiler errors *) + +exception Compiler_Error of string +let fatal_error s = raise (Compiler_Error s) + + +(* Types of the description language *) +type mltype = + Unit + | Int + | Float + | Bool + | Char + | String + | List of mltype + | Product of mltype list + | Record of (string * mltype) list + | UserDefined of string + | Subtype of string * string + | Function of mltype (* arg type only *) + | As of mltype * string + +type template = + StringArg of string + | TypeArg of string * mltype + | ListArg of template list + | OptionalArgs of string * template list * template list + +(* Sorts of components *) +type component_type = + Constructor + | Command + | External + +(* Full definition of a component *) +type fullcomponent = { + component : component_type; + ml_name : string; (* used for camltk *) + var_name : string; (* used just for labltk *) + template : template; + result : mltype; + safe : bool + } + +let sort_components = + List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name) + + +(* components are given either in full or abbreviated *) +type component = + Full of fullcomponent + | Abbrev of string + +(* A type definition *) +(* + requires_widget_context: the converter of the type MUST be passed + an additional argument of type Widget. +*) + +type parser_arity = + OneToken +| MultipleToken + +type type_def = { + parser_arity : parser_arity; + mutable constructors : fullcomponent list; + mutable subtypes : (string * fullcomponent list) list; + mutable requires_widget_context : bool; + mutable variant : bool +} + +type module_type = + Widget + | Family + +type module_def = { + module_type : module_type; + commands : fullcomponent list; + externals : fullcomponent list +} + +(******************** The tables ********************) + +(* the table of all explicitly defined types *) +let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t) +(* "builtin" types *) +let types_external = ref ([] : (string * parser_arity) list) +(* dependancy order *) +let types_order = (Tsort.create () : string Tsort.porder) +(* Types of atomic values returned by Tk functions *) +let types_returned = ref ([] : string list) +(* Function table *) +let function_table = ref ([] : fullcomponent list) +(* Widget/Module table *) +let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) + + +(* variant name *) +let rec getvarname ml_name temp = + let offhypben s = + if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then + String.sub s ~pos:1 ~len:(String.length s - 1) + else s + in + let head = String.capitalize_ascii (offhypben begin + match temp with + StringArg s -> s + | TypeArg (s,t) -> s + | ListArg (h::_) -> getvarname ml_name h + | OptionalArgs (s,_,_) -> s + | ListArg [] -> "" + end) + in + let varname = if head = "" then ml_name + else if head.[0] >= 'A' && head.[0] <= 'Z' then head + else ml_name + in varname + +(***** Some utilities on the various tables *****) +(* Enter a new empty type *) +let new_type typname arity = + Tsort.add_element types_order typname; + let typdef = {parser_arity = arity; + constructors = []; + subtypes = []; + requires_widget_context = false; + variant = false} in + Hashtbl.add types_table typname typdef; + typdef + + +(* Assume that types not yet defined are not subtyped *) +(* Widget is builtin and implicitly subtyped *) +let is_subtyped s = + s = "widget" || + try + let typdef = Hashtbl.find types_table s in + typdef.subtypes <> [] + with + Not_found -> false + +let requires_widget_context s = + try + (Hashtbl.find types_table s).requires_widget_context + with + Not_found -> false + +let declared_type_parser_arity s = + try + (Hashtbl.find types_table s).parser_arity + with + Not_found -> + try List.assoc s !types_external + with + Not_found -> + prerr_string "Type "; prerr_string s; + prerr_string " is undeclared external or undefined\n"; + prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n"); + OneToken + +let rec type_parser_arity = function + Unit -> OneToken + | Int -> OneToken + | Float -> OneToken + | Bool -> OneToken + | Char -> OneToken + | String -> OneToken + | List _ -> MultipleToken + | Product _ -> MultipleToken + | Record _ -> MultipleToken + | UserDefined s -> declared_type_parser_arity s + | Subtype (s,_) -> declared_type_parser_arity s + | Function _ -> OneToken + | As (ty, _) -> type_parser_arity ty + +let enter_external_type s v = + types_external := (s,v)::!types_external + +(*** Stuff for topological Sort.list of types ***) +(* Make sure all types used in commands and functions are in *) +(* the table *) +let rec enter_argtype = function + Unit | Int | Float | Bool | Char | String -> () + | List ty -> enter_argtype ty + | Product tyl -> List.iter ~f:enter_argtype tyl + | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t) + | UserDefined s -> Tsort.add_element types_order s + | Subtype (s,_) -> Tsort.add_element types_order s + | Function ty -> enter_argtype ty + | As (ty, _) -> enter_argtype ty + +let rec enter_template_types = function + StringArg _ -> () + | TypeArg (l,t) -> enter_argtype t + | ListArg l -> List.iter ~f:enter_template_types l + | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl + +(* Find type dependancies on s *) +let rec add_dependancies s = + function + List ty -> add_dependancies s ty + | Product tyl -> List.iter ~f:(add_dependancies s) tyl + | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s) + | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s) + | Function ty -> add_dependancies s ty + | As (ty, _) -> add_dependancies s ty + | _ -> () + +let rec add_template_dependancies s = function + StringArg _ -> () + | TypeArg (l,t) -> add_dependancies s t + | ListArg l -> List.iter ~f:(add_template_dependancies s) l + | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl + +(* Assumes functions are not nested in products, which is reasonable due to syntax*) +let rec has_callback = function + StringArg _ -> false + | TypeArg (l,Function _ ) -> true + | TypeArg _ -> false + | ListArg l -> List.exists ~f:has_callback l + | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl + +(*** Returned types ***) +let really_add ty = + if List.mem ty !types_returned then () + else types_returned := ty :: !types_returned + +let rec add_return_type = function + Unit -> () + | Int -> () + | Float -> () + | Bool -> () + | Char -> () + | String -> () + | List ty -> add_return_type ty + | Product tyl -> List.iter ~f:add_return_type tyl + | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) + | UserDefined s -> really_add s + | Subtype (s,_) -> really_add s + | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) + | As (ty, _) -> add_return_type ty + +(*** Update tables for a component ***) +let enter_component_types {template = t; result = r} = + add_return_type r; + enter_argtype r; + enter_template_types t + + +(******************** Types and subtypes ********************) +exception Duplicate_Definition of string * string +exception Invalid_implicit_constructor of string + +(* Checking duplicate definition of constructor in subtypes *) +let rec check_duplicate_constr allowed c = + function + [] -> false (* not defined *) + | c'::rest -> + if c.ml_name = c'.ml_name then (* defined *) + if allowed then + if c.template = c'.template then true (* same arg *) + else raise (Duplicate_Definition ("constructor",c.ml_name)) + else raise (Duplicate_Definition ("constructor", c.ml_name)) + else check_duplicate_constr allowed c rest + +(* Retrieve constructor *) +let rec find_constructor cname = function + [] -> raise (Invalid_implicit_constructor cname) + | c::l -> if c.ml_name = cname then c + else find_constructor cname l + +(* Enter a type, must not be previously defined *) +let enter_type typname ?(variant = false) arity constructors = + if Hashtbl.mem types_table typname then + raise (Duplicate_Definition ("type", typname)) else + let typdef = new_type typname arity in + if variant then typdef.variant <- true; + List.iter constructors ~f: + begin fun c -> + if not (check_duplicate_constr false c typdef.constructors) + then begin + typdef.constructors <- c :: typdef.constructors; + add_template_dependancies typname c.template + end; + (* Callbacks require widget context *) + typdef.requires_widget_context <- + typdef.requires_widget_context || + has_callback c.template + end + +(* Enter a subtype *) +let enter_subtype typ arity subtyp constructors = + (* Retrieve the type if already defined, else add a new one *) + let typdef = + try Hashtbl.find types_table typ + with Not_found -> new_type typ arity + in + if List.mem_assoc subtyp typdef.subtypes + then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) + else begin + let real_constructors = + List.map constructors ~f: + begin function + Full c -> + if not (check_duplicate_constr true c typdef.constructors) + then begin + add_template_dependancies typ c.template; + typdef.constructors <- c :: typdef.constructors + end; + typdef.requires_widget_context <- + typdef.requires_widget_context || + has_callback c.template; + c + | Abbrev name -> find_constructor name typdef.constructors + end + in + (* TODO: duplicate def in subtype are not checked *) + typdef.subtypes <- + (subtyp , List.sort real_constructors + ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) :: + typdef.subtypes + end + +(******************** Widgets ********************) +(* used by the parser; when enter_widget is called, + all components are assumed to be in Full form *) +let retrieve_option optname = + let optiontyp = + try Hashtbl.find types_table "options" + with + Not_found -> raise (Invalid_implicit_constructor optname) + in find_constructor optname optiontyp.constructors + +(* Sort components by type *) +let rec add_sort l obj = + match l with + [] -> [obj.component ,[obj]] + | (s',l)::rest -> + if obj.component = s' then + (s',obj::l)::rest + else + (s',l)::(add_sort rest obj) + +let separate_components = List.fold_left ~f:add_sort ~init:[] + +let enter_widget name components = + if Hashtbl.mem module_table name then + raise (Duplicate_Definition ("widget/module", name)) else + let sorted_components = separate_components components in + List.iter sorted_components ~f: + begin function + Constructor, l -> + enter_subtype "options" MultipleToken + name (List.map ~f:(fun c -> Full c) l) + | Command, l -> + List.iter ~f:enter_component_types l + | External, _ -> () + end; + let commands = + try List.assoc Command sorted_components + with Not_found -> [] + and externals = + try List.assoc External sorted_components + with Not_found -> [] + in + Hashtbl.add module_table name + {module_type = Widget; commands = commands; externals = externals} + +(******************** Functions ********************) + +let enter_function comp = + enter_component_types comp; + function_table := comp :: !function_table + + +(******************** Modules ********************) +let enter_module name components = + if Hashtbl.mem module_table name then + raise (Duplicate_Definition ("widget/module", name)) else + let sorted_components = separate_components components in + List.iter sorted_components ~f: + begin function + Constructor, l -> fatal_error "unexpected Constructor" + | Command, l -> List.iter ~f:enter_component_types l + | External, _ -> () + end; + let commands = + try List.assoc Command sorted_components + with Not_found -> [] + and externals = + try List.assoc External sorted_components + with Not_found -> [] + in + Hashtbl.add module_table name + {module_type = Family; commands = commands; externals = externals} diff --git a/compiler/tsort.ml b/compiler/tsort.ml new file mode 100644 index 0000000..6768d0d --- /dev/null +++ b/compiler/tsort.ml @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* 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 + +(* Topological Sort.list *) +(* d'apres More Programming Pearls *) + +(* node * pred count * successors *) + +type 'a entry = + {node : 'a; + mutable pred_count : int; + mutable successors : 'a entry list + } + +type 'a porder = 'a entry list ref + +exception Cyclic + +let find_entry order node = + let rec search_entry = + function + [] -> raise Not_found + | x::l -> if x.node = node then x else search_entry l + in + try + search_entry !order + with + Not_found -> let entry = {node = node; + pred_count = 0; + successors = []} in + order := entry::!order; + entry + +let create () = ref [] + +(* Inverted args because Sort.list builds list in reverse order *) +let add_relation order (succ,pred) = + let pred_entry = find_entry order pred + and succ_entry = find_entry order succ in + succ_entry.pred_count <- succ_entry.pred_count + 1; + pred_entry.successors <- succ_entry::pred_entry.successors + +(* Just add it *) +let add_element order e = + ignore (find_entry order e) + +let sort order = + let q = Queue.create () + and result = ref [] in + List.iter !order + ~f:(function {pred_count = n} as node -> + if n = 0 then Queue.add node q); + begin try + while true do + let t = Queue.take q in + result := t.node :: !result; + List.iter t.successors ~f: + begin fun s -> + let n = s.pred_count - 1 in + s.pred_count <- n; + if n = 0 then Queue.add s q + end + done + with + Queue.Empty -> + List.iter !order + ~f:(fun node -> if node.pred_count <> 0 + then raise Cyclic) + end; + !result diff --git a/config/Makefile.mingw b/config/Makefile.mingw new file mode 100644 index 0000000..dd01c98 --- /dev/null +++ b/config/Makefile.mingw @@ -0,0 +1,7 @@ +# Configuration for Windows, Mingw compiler +include C:/ocamlmgw/lib/ocaml/Makefile.config +INSTALLDIR=$(LIBDIR)/labltk +INSTALLBINDIR=$(BINDIR) +TK_ROOT=c:/tcl +TK_DEFS=-I$(TK_ROOT)/include +TK_LINK=$(TK_ROOT)/bin/tk85.dll $(TK_ROOT)/bin/tcl85.dll -lws2_32 diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 new file mode 100644 index 0000000..b127258 --- /dev/null +++ b/config/Makefile.mingw64 @@ -0,0 +1,6 @@ +# Configuration for Windows, Mingw compiler -- NOT SUPPORTED +include C:/ocamlmgw64/lib/ocaml/Makefile.config +INSTALLDIR=$(LIBDIR)/labltk +INSTALLBINDIR=$(BINDIR) +TK_DEFS= +TK_LINK= diff --git a/config/Makefile.msvc b/config/Makefile.msvc new file mode 100644 index 0000000..ef263c4 --- /dev/null +++ b/config/Makefile.msvc @@ -0,0 +1,14 @@ +# Configuration for Windows, Visual C++ compiler +include C:/ocamlms/lib/ocaml/Makefile.config +INSTALLDIR=$(LIBDIR)/labltk +INSTALLBINDIR=$(BINDIR) +TK_ROOT=c:/tcl +TK_DEFS=-I$(TK_ROOT)/include +# The following definition avoids hard-wiring $(TK_ROOT) in the libraries +# produced by OCaml, and is therefore required for binary distribution +# of these libraries. However, $(TK_ROOT)/lib must be added to the LIB +# environment variable, as described in README.win32. +TK_LINK=tk85.lib tcl85.lib ws2_32.lib +# An alternative definition that avoids mucking with the LIB variable, +# but hard-wires the Tcl/Tk location in the binaries +# TK_LINK=$(TK_ROOT)/tk85.lib $(TK_ROOT)/tcl85.lib ws2_32.lib diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 new file mode 100644 index 0000000..baa8a56 --- /dev/null +++ b/config/Makefile.msvc64 @@ -0,0 +1,6 @@ +# Configuration for Windows, Visual C++ compiler -- NOT SUPPORTED +include C:/ocamlms64/lib/ocaml/Makefile.config +INSTALLDIR=$(LIBDIR)/labltk +INSTALLBINDIR=$(BINDIR) +TK_DEFS= +TK_LINK= diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot new file mode 100755 index 0000000..53d5786 --- /dev/null +++ b/config/auto-aux/hasgot @@ -0,0 +1,42 @@ +#!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1995 Institut National de Recherche en Informatique et # +# en Automatique. 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. # +# # +######################################################################### + +opts="" +libs="$cclibs" +args=$* +rm -f hasgot.c +var="x" +while : ; do + case "$1" in + -i) echo "#include <$2>" >> hasgot.c; shift;; + -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; + -l*|-L*|-F*) libs="$libs $1";; + -framework) libs="$libs $1 $2"; shift;; + -*) opts="$opts $1";; + *) break;; + esac + shift +done + +(echo "main() {" + for f in $*; do echo " $f();"; done + echo "}") >> hasgot.c + +if test "$verbose" = yes; then + echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2 + exec $cc $opts -o tst hasgot.c $libs > /dev/null +else + exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null +fi diff --git a/config/auto-aux/hasgot.c b/config/auto-aux/hasgot.c new file mode 100644 index 0000000..4a3a515 --- /dev/null +++ b/config/auto-aux/hasgot.c @@ -0,0 +1,3 @@ +main() { + Tk_SetGrid(); +} diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest new file mode 100755 index 0000000..c8d7c43 --- /dev/null +++ b/config/auto-aux/runtest @@ -0,0 +1,22 @@ +#!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1995 Institut National de Recherche en Informatique et # +# en Automatique. 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. # +# # +######################################################################### + +if test "$verbose" = yes; then +echo "runtest: $cc -o tst $* $cclibs" >&2 +$cc -o tst $* $cclibs || exit 100 +else +$cc -o tst $* $cclibs 2> /dev/null || exit 100 +fi +exec ./tst diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c new file mode 100644 index 0000000..4608ee9 --- /dev/null +++ b/config/auto-aux/tclversion.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* 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 +#include +#include + +main () +{ + puts(TCL_VERSION); +} diff --git a/configure b/configure new file mode 100755 index 0000000..6c93d8a --- /dev/null +++ b/configure @@ -0,0 +1,312 @@ +#! /bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. 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. # +# # +######################################################################### + +configure_options="$*" +where='' +installbindir='' +installdir='' +tk_defs='' +tk_libs='' +tk_x11=yes +use_findlib=no +verbose=no +optcomps=no + +# The inf(), wrn(), err() functions below can be used to provide a consistent +# way to notify the user. The notification is always given to the stdout +# descriptor. +inf() { + printf "%b\n" "$*" 1>&3 +} + +wrn() { + printf "[WARNING] %b\n" "$*" 1>&3 +} + +err() { + printf "[ERROR!]%b\n" "$*" 1>&3 + exit 2 +} + +exec 3>&1 + +# Parse command-line arguments + +if echo "$configure_options" | grep -q -e '--\?[a-zA-Z0-9-]\+='; then + err "Arguments to this script look like '-libdir /foo/bar', not '-libdir=/foo/bar' (note the '=')." +fi + +while : ; do + case "$1" in + "") break;; + -installbindir|--installbindir) + installbindir=$2; shift;; + -installdir|--installdir) + installdir=$2; shift;; + -libdir|--libdir) + where=$2; shift;; + -tkdefs*|--tkdefs*) + tk_defs=$2; shift;; + -tklibs*|--tklibs*) + tk_libs=$2; shift;; + -tk-no-x11|--tk-no-x11) + tk_x11=no;; + -use-findlib|--use-findlib) + use_findlib=yes;; + -verbose|--verbose) + verbose=yes;; + *) err "Unknown option \"$1\".";; + esac + shift +done + +export verbose + +# Where to install + +if test -n "$where"; then : +elif test $use_findlib = yes; then + where=`ocamlfind printconf stdlib` +else + where=`ocamlc -where 2> /dev/null || echo '/usr/local/lib/ocaml'` +fi + +if test -n "$installdir" ; then : +elif test "$use_findlib" = yes; then + installdir="`ocamlfind printconf destdir`/labltk" +else + installdir='$(LIBDIR)/labltk' +fi + +if test -z "$installbindir"; then + installbindir='$(BINDIR)' +fi + +# Sanity checks + +case "$where" in + /*) ;; + *) err "The ocaml library directory must be absolute.";; +esac +case "$installdir" in + /*|'$'*) ;; + *) err "The installation directory must be absolute.";; +esac +case "$installbindir" in + /*|'$'*) ;; + *) err "The binary installation directory must be absolute.";; +esac + +# Generate the files + +cd config/auto-aux +rm -f Makefile +touch Makefile + +# Write options to Makefile + +echo "# generated by ./configure $configure_options" >> Makefile + +# Include OCaml configuration + +echo "include $where/Makefile.config" >> Makefile + +# Where to install + +echo "USE_FINDLIB=$use_findlib" >> Makefile +echo "INSTALLDIR=$installdir" >> Makefile +echo "INSTALLBINDIR=$installbindir" >> Makefile + +# Which compiler to use + +ocamlc_where=`ocamlc -where 2> /dev/null` +ocamlc_ver=`ocamlc -version 2> /dev/null` +ocamlc_opt_ver=`ocamlc.opt -version 2> /dev/null` +ocamlopt_ver=`$ocamlopt -version 2> /dev/null` +ocamlopt_opt_ver=`$ocamlopt.opt -version 2> /dev/null` +if test x"$where" = x"$ocamlc_where" \ + && test -n "$ocamlc_opt_ver" && test x"$ocamlc_opt_ver" = x"$ocamlc_ver" \ + && (test -z "$ocamlopt_ver" || test x"$ocamlopt_ver" = x"$ocamlopt_opt_ver") +then + optcomps=yes + echo "OPT=.opt" >> Makefile +else + echo "OPT=" >> Makefile +fi + +# Look for tcl/tk + +inf "Configuring LablTk..." + +if test $tk_x11 = no; then + has_tk=true +else + tk_x11_include=`cat $where/Makefile.config | grep '^X11_INCLUDES=' | sed -e 's/^X11_INCLUDES=//'` + tk_x11_libs=`cat $where/Makefile.config | grep '^X11_LIBS=' | sed -e 's/^X11_LIBS=//'` + has_tk=true +fi + +cc=`cat $where/Makefile.config | grep '^CC=' | sed -e 's/^CC=//'` +cclibs=`cat $where/Makefile.config | grep '^NATIVECCLIBS=' | sed -e 's/^NATIVECCLIBS=//'` +export cc cclibs + +if test $has_tk = true; then + tcl_version='' + tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` + for tk_incs in \ + "-I/usr/local/include" \ + "-I/opt/local/include" \ + "-I/sw/include" \ + "-I/usr/pkg/include" \ + "-I/usr/include" \ + "-I/usr/local/include/tcl8.6 -I/usr/local/include/tk8.6" \ + "-I/usr/include/tcl8.6 -I/usr/include/tk8.6" \ + "-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \ + "-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \ + "-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \ + "-I/usr/include/tcl8.4 -I/usr/include/tk8.4" \ + "-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3" \ + "-I/usr/include/tcl8.3 -I/usr/include/tk8.3" \ + "-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2" \ + "-I/usr/include/tcl8.2 -I/usr/include/tk8.2" + do if test -z "$tcl_version"; then + tk_defs="$tk_incs" + tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` + fi; done + if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then + inf "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"." + case $tcl_version in + 8.6) tclmaj=8 tclmin=6 tkmaj=8 tkmin=6 ;; + 8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;; + 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; + 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; + 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; + 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;; + 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;; + 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;; + 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;; + *) wrn "This version is not known." ; has_tk=false ;; + esac + else + inf "tcl.h and/or tk.h not found." + has_tk=false + fi +fi + +system=`cat $where/Makefile.config | grep '^SYSTEM=' | sed -e 's/^SYSTEM=//'` + +if test $has_tk = true && test -z "$tk_libs"; then + tklibdir="" + if test -n "$tk_defs"; then + tkinclude="$tk_defs" + else + tkinclude="$tk_x11_include" + fi + case "$tkinclude" in + -I/opt/local/include*) tklibdir="/opt/local/lib" ;; + -I/usr/local/include*) tklibdir="/usr/local/lib" ;; + -I/sw/include*) tklibdir="/sw/lib" ;; + -I/usr/pkg/include*) tklibdir="/usr/pkg/lib" ;; + esac + if test -n "$tklibdir"; then + case "$system" in + *bsd*) tk_libs="-R$tklibdir -L$tklibdir" ;; + *) tk_libs="-L$tklibdir" ;; + esac + else + tk + fi +fi + +tkauxlibs="$cclibs" +if test $has_tk = true; then + if test -n "$tk_libs" && \ + sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent + then tk_libs="$tk_libs $dllib" + elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent + then + tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" + elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent + then + tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" + elif test -z "$tk_libs" && tk_libs=-L/usr/local/lib && \ + sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent + then + tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" + elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent + then + tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" + else + inf "Tcl library not found." + has_tk=false + fi +fi + +if test $has_tk = true; then + if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then + inf "Tcl/Tk libraries found." + else + has_tk=false + for tklibdir in "/usr/local/lib" "/opt/local/lib" "/sw/lib" "/usr/pkg/lib"; + do + if test $found = no && + sh ./hasgot -L$tklibdir $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid + then + has_tk=true + case "$system" in + *bsd*) tk_libs="-R$tklibdir -L$tklibdir $tk_libs";; + *) tk_libs="-L$tklibdir $tk_libs";; + esac + fi + done + if test $has_tk = true; then + inf "Tcl/Tk libraries found." + else + inf "Tcl library found." + wrn "Tk library not found." + fi + fi +fi + +if test $has_tk = true; then + if test $tk_x11 = yes; then + echo "TK_DEFS=$tk_defs "'$(X11_INCLUDES)' >> Makefile + echo "TK_LINK=$tk_libs "'$(X11_LINK)' >> Makefile + else + echo "TK_DEFS=$tk_defs" >> Makefile + echo "TK_LINK=$tk_libs" >> Makefile + fi + otherlibraries="$otherlibraries labltk" +else + echo "TK_DEFS=" >> Makefile + echo "TK_LINK=" >> Makefile +fi + +mv Makefile .. + +# Print a summary + +inf +inf "** Configuration summary **" +inf +if test $has_tk = true; then +inf "Configuration for the \"labltk\" library:" +inf " use tcl/tk version ....... $tcl_version" +inf " options for compiling .... $tk_defs $tk_x11_include" +inf " options for linking ...... $tk_libs $tk_x11_libs" +inf " use native compilers ..... $optcomps" +else +inf "The \"labltk\" library: not supported" +fi diff --git a/examples_camltk/.gitignore b/examples_camltk/.gitignore new file mode 100644 index 0000000..801812f --- /dev/null +++ b/examples_camltk/.gitignore @@ -0,0 +1,8 @@ +addition +eyes +fileinput +fileopen +helloworld +tetris +winskel +mytext diff --git a/examples_camltk/Makefile b/examples_camltk/Makefile new file mode 100644 index 0000000..e9c4c6a --- /dev/null +++ b/examples_camltk/Makefile @@ -0,0 +1,118 @@ +####################################################################### +# # +# 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 + +# We are using the non-installed library ! +BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -dllpath ../support +BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s + +WITH_BYT_CAMLTK=labltk.cma camltk.cmo +WITH_BIN_CAMLTK=labltk.cmxa camltk.cmx + +BYT_EXECS =\ + addition.byt helloworld.byt winskel.byt fileinput.byt\ + eyes.byt taquin.byt tetris.byt mytext.byt fileopen.byt\ + +BIN_EXECS=$(BYT_EXECS:.byt=.bin) + +EXECS=$(BYT_EXECS:.byt=$(EXE)) + +all: byt bin + +byt: $(BYT_EXECS) + +#opt: hello.opt demo.opt calc.opt clock.opt tetris.opt + +bin: opt + +opt: $(BIN_EXECS) + +addition.bin: addition.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) addition.cmx + +helloworld.bin: helloworld.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) helloworld.cmx + +winskel.bin: winskel.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) winskel.cmx + +fileinput.bin: fileinput.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) unix.cmxa fileinput.cmx + +socketinput.bin: socketinput.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) socketinput.cmx + +eyes.bin: eyes.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) eyes.cmx + +taquin.bin: taquin.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) taquin.cmx + +tetris.bin: tetris.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) tetris.cmx + +mytext.bin: mytext.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) mytext.cmx + +fileopen.bin: fileopen.cmx + $(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) fileopen.cmx + + +addition.byt: addition.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo + +helloworld.byt: helloworld.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo + +winskel.byt: winskel.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo + +fileinput.byt: fileinput.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo + +socketinput.byt: socketinput.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo + +eyes.byt: eyes.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo + +taquin.byt: taquin.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma taquin.cmo + +tetris.byt: tetris.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo + +mytext.byt: mytext.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo + +fileopen.byt: fileopen.cmo + $(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo + +clean : + rm -f *.cm? *.o a.out $(EXECS) $(BYT_EXECS) $(BIN_EXECS) + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .cmx .cma .cmxa + +.mli.cmi: + $(CAMLCOMP) $(BYT_COMPFLAGS) -c $< + +.ml.cmo: + $(CAMLCOMP) $(BYT_COMPFLAGS) -c $< + +.ml.cmx: + $(CAMLOPT) $(BIN_COMPFLAGS) -c $< diff --git a/examples_camltk/Makefile.nt b/examples_camltk/Makefile.nt new file mode 100644 index 0000000..d84c978 --- /dev/null +++ b/examples_camltk/Makefile.nt @@ -0,0 +1,54 @@ +####################################################################### +# # +# 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 + +# We are using the non-installed library ! +COMPFLAGS= -I ../lib -I ../camltk -I ../support +LINKFLAGS= -I ../lib -I ../camltk -I ../support + +# Use pieces of Makefile.config +TKLINKOPT=$(LIBNAME).cma $(TKLIBS) + +all: addition.exe helloworld.exe winskel.exe socketinput.exe + +addition.exe: addition.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ addition.cmo + +helloworld.exe: helloworld.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ helloworld.cmo + +winskel.exe: winskel.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ winskel.cmo + +socketinput.exe: socketinput.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ + -o $@ socketinput.cmo + +clean : + rm -f *.cm? *.exe + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/examples_camltk/addition.ml b/examples_camltk/addition.ml new file mode 100644 index 0000000..6bebe02 --- /dev/null +++ b/examples_camltk/addition.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +open Camltk;; + +let main () = + let top = opentk () in + (* The widgets. They all have "top" as parent widget. *) + let en1 = Entry.create top [TextWidth 6; Relief Sunken] in + let lab1 = Label.create top [Text "plus"] in + let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in + let lab2 = Label.create top [Text "="] in + let result_display = Label.create top [] in + (* References holding values of entry widgets *) + let n1 = ref 0 + and n2 = ref 0 in + (* Refresh result *) + let refresh () = + Label.configure result_display [Text (string_of_int (!n1 + !n2))] in + (* Electric *) + let get_and_refresh (w,r) = + fun _ _ -> + try + r := int_of_string (Entry.get w); + refresh () + with + Failure "int_of_string" -> + Label.configure result_display [Text "error"] + in + (* Set the callbacks *) + Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; + Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; + (* Map the widgets *) + pack [en1;lab1;en2;lab2;result_display] []; + (* Make the window resizable *) + Wm.minsize_set top 1 1; + (* Start interaction (event-driven program) *) + mainLoop () +;; + +Printexc.catch main () +;; diff --git a/examples_camltk/eyes.ml b/examples_camltk/eyes.ml new file mode 100644 index 0000000..056b728 --- /dev/null +++ b/examples_camltk/eyes.ml @@ -0,0 +1,74 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* The eyes of OCaml (CamlTk) *) + +open Camltk;; + +let create_eye canvas cx cy wx wy ewx ewy bnd = + let _oval2 = + Canvas.create_oval canvas + (Pixels (cx - wx)) (Pixels (cy - wy)) + (Pixels (cx + wx)) (Pixels (cy + wy)) + [Outline (NamedColor "black"); Width (Pixels 7); + FillColor (NamedColor "white"); ] + and oval = + Canvas.create_oval canvas + (Pixels (cx - ewx)) (Pixels (cy - ewy)) + (Pixels (cx + ewx)) (Pixels (cy + ewy)) + [FillColor (NamedColor "black")] in + let curx = ref cx + and cury = ref cy in + + let treat_event e = + + let xdiff = e.ev_MouseX - cx + and ydiff = e.ev_MouseY - cy in + + let diff = + sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + (float ydiff /. (float wy *. bnd)) ** 2.0) in + + let nx, ny = + if diff <= 1.0 then e.ev_MouseX, e.ev_MouseY else + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy in + + Canvas.move canvas oval (Pixels (nx - !curx)) (Pixels (ny - !cury)); + curx := nx; + cury := ny; in + + bind canvas [[], Motion] ( + BindExtend ([Ev_MouseX; Ev_MouseY], treat_event) + ) +;; + +let main () = + let top = opentk () in + let fw = Frame.create top [] in + pack [fw] []; + + let canvas = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in + + create_eye canvas 60 100 30 40 5 6 0.6; + create_eye canvas 140 100 30 40 5 6 0.6; + pack [canvas] []; + + mainLoop (); +;; + +Printexc.print main ();; + diff --git a/examples_camltk/fileinput.ml b/examples_camltk/fileinput.ml new file mode 100644 index 0000000..70bc675 --- /dev/null +++ b/examples_camltk/fileinput.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk ;; + +let top_w = opentk () ;; +let buffer = String.create 256 ;; +let (fd_in, fd_out) = Unix.pipe () ;; +let text0_w = Text.create top_w [] ;; +let entry0_w = Entry.create top_w [] ;; +let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; +Fileevent.add_fileinput fd_in (fun _ -> + let n = Unix.read fd_in buffer 0 (String.length buffer) in + let txt = String.sub buffer 0 n in + Text.insert text0_w (TextIndex (End, [])) txt []) ;; +let send _ = + let txt = Entry.get entry0_w ^ "\n" in + Entry.delete_range entry0_w (At 0) End ; + ignore (Unix.write fd_out txt 0 (String.length txt));; + +bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ; +pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;; +mainLoop () ;; diff --git a/examples_camltk/fileopen.ml b/examples_camltk/fileopen.ml new file mode 100644 index 0000000..d0829bd --- /dev/null +++ b/examples_camltk/fileopen.ml @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk;; + +let win = opentk();; + +let cvs = Canvas.create win [];; + +let t = Label.create cvs [Text "File name"];; + +let b = + Button.create cvs + [Text "Save"; + Command + (function _ -> + let s = + getSaveFile + [Title "SAVE FILE TEST"; + DefaultExtension ".foo"; + FileTypes [ { typename= "just test"; + extensions= [".foo"; ".test"]; + mactypes= ["FOOO"; "BARR"] } ]; + InitialDir Filename.temp_dir_name; + InitialFile "hogehoge" ] in + Label.configure t [Text s])];; + +let bb = + Button.create cvs + [Text "Open"; + Command + (function _ -> + let s = getOpenFile [] in + Label.configure t [Text s])];; + +let q = + Button.create cvs + [Text "Quit"; + Command + (function _ -> closeTk (); exit 0)];; + +pack [cvs; q; bb; b; t] [];; + +mainLoop ();; diff --git a/examples_camltk/helloworld.ml b/examples_camltk/helloworld.ml new file mode 100644 index 0000000..c90d7bd --- /dev/null +++ b/examples_camltk/helloworld.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* Make interface functions available *) +open Camltk;; + +(* Initialisation of the interface. *) +let top = opentk ();; +(* top is now the toplevel widget. *) + +(* Widget initialisation *) +let b = + Button.create top [ + Text "foobar"; + Command + (function () -> + print_string "foobar"; + print_newline (); + flush stdout); + ] +;; +(* Now button [b] exists but is not yet visible. *) + +let q = + Button.create top [ + Text "quit"; + Command closeTk; + ] +;; +(* Button [q] also exists but is not yet visible. *) + +(* Make b and q visible. *) +pack [b; q] [];; + +(* Start user interaction. *) +mainLoop ();; +(* You can also quit this program by deleting its main window. *) diff --git a/examples_camltk/images/CamlBook.gif b/examples_camltk/images/CamlBook.gif new file mode 100644 index 0000000..ca9bd63 Binary files /dev/null and b/examples_camltk/images/CamlBook.gif differ diff --git a/examples_camltk/images/Lambda2.back.gif b/examples_camltk/images/Lambda2.back.gif new file mode 100644 index 0000000..7cb3d2c Binary files /dev/null and b/examples_camltk/images/Lambda2.back.gif differ diff --git a/examples_camltk/images/dojoji.back.gif b/examples_camltk/images/dojoji.back.gif new file mode 100644 index 0000000..d397f02 Binary files /dev/null and b/examples_camltk/images/dojoji.back.gif differ diff --git a/examples_camltk/jptest.ml b/examples_camltk/jptest.ml new file mode 100644 index 0000000..9ec06ac --- /dev/null +++ b/examples_camltk/jptest.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Tk + +let win = opentk();; + +let b = Button.create win [ Text "�������" ];; +let _ = pack [b] [];; + +mainLoop();; diff --git a/examples_camltk/mytext.ml b/examples_camltk/mytext.ml new file mode 100644 index 0000000..f3aadfb --- /dev/null +++ b/examples_camltk/mytext.ml @@ -0,0 +1,62 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let top = opentk () + +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + +let f = Frame.create top [] +let text = Text.create f [] +let scrollbar = Scrollbar.create f [] + +(* kill buffer *) +let buffer = ref "" + +(* Note: for the text widgets, the insertion cursor is + not TextIndex(Insert, []), + but TextIndex(Mark "insert", []) +*) +let insertMark = TextIndex(Mark "insert", []) +let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) + +let kill () = + buffer := + Text.get text insertMark eol_insertMark; + prerr_endline ("Killed: " ^ !buffer); + Text.delete text insertMark eol_insertMark +;; + +let yank () = + Text.insert text insertMark !buffer []; + prerr_endline ("Yanked: " ^ !buffer) +;; + +let _ = + scroll_link scrollbar text; + + pack [text; scrollbar][Side Side_Left; Fill Fill_Y]; + pack [f][]; + + bind text [[Control], KeyPressDetail "y"] + (BindSet ([], fun _ -> yank () )); + bind text [[Control], KeyPressDetail "k"] + (BindSet ([], fun _ -> kill () )); + + mainLoop () +;; diff --git a/examples_camltk/socketinput.ml b/examples_camltk/socketinput.ml new file mode 100644 index 0000000..485c258 --- /dev/null +++ b/examples_camltk/socketinput.ml @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let _ = + let top_w = opentk () in + let text0_w = Text.create top_w [] in + let entry0_w = Entry.create top_w [] in + let button0_w = Button.create top_w + [Text "Quit"; Command (fun _ -> exit 0)] in + let buffer = String.create 256 in + let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); + Unix.listen master_socket 3; + print_string "Please connect to port 6789..."; print_newline(); + let (sock, _) = Unix.accept master_socket in + Fileevent.add_fileinput sock + (fun _ -> + let n = Unix.recv sock buffer 0 (String.length buffer) [] in + let txt = String.sub buffer 0 n in + Text.insert text0_w (TextIndex (End, [])) txt []); + let send _ = + let txt = Entry.get entry0_w ^ "\n" in + Entry.delete_range entry0_w (At 0) End ; + Unix.send sock txt 0 (String.length txt) []; + () in + bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); + pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; + mainLoop () diff --git a/examples_camltk/taddition.ml b/examples_camltk/taddition.ml new file mode 100644 index 0000000..c186730 --- /dev/null +++ b/examples_camltk/taddition.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Tk + +let main () = + let top = opentk () in + (* The widgets. They all have "top" as parent widget. *) + let en1 = Entry.create top [TextWidth 6; Relief Sunken] in + let lab1 = Label.create top [Text "plus"] in + let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in + let lab2 = Label.create top [Text "="] in + let result_display = Label.create top [] in + (* References holding values of entry widgets *) + let n1 = ref 0 + and n2 = ref 0 in + (* Refresh result *) + let refresh () = + Label.configure result_display [Text (string_of_int (!n1 + !n2))] in + (* Electric *) + let get_and_refresh (w,r) = + fun _ _ -> + try + r := int_of_string (Entry.get w); + refresh () + with + Failure "int_of_string" -> + Label.configure result_display [Text "error"] + in + (* Set the callbacks *) + Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; + Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; + (* Map the widgets *) + pack [en1;lab1;en2;lab2;result_display] []; + (* Make the window resizable *) + Wm.minsize_set top 1 1; + (* Start interaction (event-driven program) *) + Threadtk.mainLoop () +;; + +let _ = Printexc.catch main () ;; diff --git a/examples_camltk/taquin.ml b/examples_camltk/taquin.ml new file mode 100644 index 0000000..70ac934 --- /dev/null +++ b/examples_camltk/taquin.ml @@ -0,0 +1,146 @@ +(***********************************************************************) +(* *) +(* Caml examples *) +(* *) +(* Pierre Weis *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright (c) 1994-2011, INRIA *) +(* All rights reserved. *) +(* *) +(* Distributed under the BSD license. *) +(* *) +(***********************************************************************) + +(* $Id: taquin.ml,v 1.4 2011-08-08 19:31:17 weis Exp $ *) + +open Camltk;; + +let d�coupe_image img nx ny = + let l = Imagephoto.width img + and h = Imagephoto.height img in + let tx = l / nx and ty = h / ny in + let pi�ces = ref [] in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + let pi�ce = + Imagephoto.create [Width (Pixels tx); Height (Pixels ty)] in + Imagephoto.copy pi�ce img + [ImgFrom(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty)]; + pi�ces := pi�ce :: !pi�ces + done + done; + (tx, ty, List.tl !pi�ces) +;; + +let remplir_taquin c nx ny tx ty pi�ces = + let trou_x = ref (nx - 1) + and trou_y = ref (ny - 1) in + let trou = + Canvas.create_rectangle c + (Pixels (!trou_x * tx)) (Pixels (!trou_y * ty)) + (Pixels tx) (Pixels ty) [] in + let taquin = Array.make_matrix nx ny trou in + let p = ref pi�ces in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + match !p with + | [] -> () + | pi�ce :: reste -> + taquin.(x).(y) <- + Canvas.create_image c + (Pixels (x * tx)) (Pixels (y * ty)) + [ImagePhoto pi�ce; Anchor NW; Tags [Tag "pi�ce"]]; + p := reste + done + done; + let d�placer x y = + let pi�ce = taquin.(x).(y) in + Canvas.coords_set c pi�ce + [Pixels (!trou_x * tx); Pixels(!trou_y * ty)]; + Canvas.coords_set c trou + [Pixels (x * tx); Pixels(y * ty); Pixels tx; Pixels ty]; + taquin.(!trou_x).(!trou_y) <- pi�ce; + taquin.(x).(y) <- trou; + trou_x := x; trou_y := y in + let jouer ei = + let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in + if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) + || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) + then d�placer x y in + Canvas.bind c (Tag "pi�ce") [[], ButtonPress] + (BindSet ([Ev_MouseX; Ev_MouseY], jouer));; + +let rec permutation = function + | [] -> [] + | l -> let n = Random.int (List.length l) in + let (�l�ment, reste) = partage l n in + �l�ment :: permutation reste + +and partage l n = + match l with + | [] -> failwith "partage" + | t�te :: reste -> + if n = 0 then (t�te, reste) else + let (�l�ment, reste') = partage reste (n - 1) in + (�l�ment, t�te :: reste') +;; + +let create_filled_text parent lines = + let lnum = List.length lines + and lwidth = + List.fold_right + (fun line max -> + let l = String.length line in + if l > max then l else max) + lines 1 in + let txtw = Text.create parent [TextWidth lwidth; TextHeight lnum] in + List.iter + (fun line -> + Text.insert txtw (TextIndex (End, [])) line []; + Text.insert txtw (TextIndex (End, [])) "\n" []) + lines; + txtw +;; + +let give_help parent lines () = + let help_window = Toplevel.create parent [] in + Wm.title_set help_window "Help"; + + let help_frame = Frame.create help_window [] in + + let help_txtw = create_filled_text help_frame lines in + + let quit_help () = destroy help_window in + let ok_button = Button.create help_frame [Text "Ok"; Command quit_help] in + + pack [help_txtw; ok_button ] [Side Side_Bottom]; + pack [help_frame] [] +;; + +let taquin nom_fichier nx ny = + let fp = openTk () in + Wm.title_set fp "Taquin"; + let img = Imagephoto.create [File nom_fichier] in + let c = + Canvas.create fp + [Width(Pixels(Imagephoto.width img)); + Height(Pixels(Imagephoto.height img))] in + let (tx, ty, pi�ces) = d�coupe_image img nx ny in + remplir_taquin c nx ny tx ty (permutation pi�ces); + pack [c] []; + + let quit = Button.create fp [Text "Quit"; Command closeTk] in + let help_lines = + ["Pour jouer, cliquer sur une des pi�ces"; + "entourant le trou"; + ""; + "To play, click on a part around the hole"] in + let help = + Button.create fp [Text "Help"; Command (give_help fp help_lines)] in + pack [quit; help] [Side Side_Left; Fill Fill_X]; + mainLoop () +;; + +if !Sys.interactive then () else begin taquin "joconde.gif" 3 5; exit 0 end;; diff --git a/examples_camltk/tetris.ml b/examples_camltk/tetris.ml new file mode 100644 index 0000000..a46de60 --- /dev/null +++ b/examples_camltk/tetris.ml @@ -0,0 +1,542 @@ +(***********************************************************************) +(* *) +(* Caml examples *) +(* *) +(* Pierre Weis *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright (c) 1994-2011, INRIA *) +(* All rights reserved. *) +(* *) +(* Distributed under the BSD license. *) +(* *) +(***********************************************************************) + +(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *) + +(* A Tetris game for CamlTk. + Written by Jun P. Furuse. + Adapted to the oc examples repository by P. Weis *) + +open Camltk;; + +(* The directory where images will be found. *) +let baseurl = "images/";; + +exception Done;; + +type cell = { + mutable color : int; + tag : tagOrId * tagOrId * tagOrId; +} +;; + +type falling_block = { + mutable pattern : int array list; + mutable bcolor : int; + mutable x : int; + mutable y : int; + mutable d : int; + mutable alive: bool; +} +;; + +let stop_a_bit = 300;; + +let colors = [| + NamedColor "red"; NamedColor "yellow"; NamedColor "blue"; + NamedColor "orange"; NamedColor "magenta"; NamedColor "green"; + NamedColor "cyan"; +|] +;; + +let backgrounds = + List.map (fun s -> baseurl ^ s) + [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];; + +(* blocks *) +let block_size = 16 +and cell_border = 2 +;; + +let blocks = [ + [ [|"0000"; "0000"; "1111"; "0000" |]; + [|"0010"; "0010"; "0010"; "0010" |]; + [|"0000"; "0000"; "1111"; "0000" |]; + [|"0010"; "0010"; "0010"; "0010" |] ]; + + [ [|"0000"; "0110"; "0110"; "0000" |]; + [|"0000"; "0110"; "0110"; "0000" |]; + [|"0000"; "0110"; "0110"; "0000" |]; + [|"0000"; "0110"; "0110"; "0000" |] ]; + + [ [|"0000"; "0111"; "0100"; "0000" |]; + [|"0000"; "0110"; "0010"; "0010" |]; + [|"0000"; "0010"; "1110"; "0000" |]; + [|"0100"; "0100"; "0110"; "0000" |] ]; + + [ [|"0000"; "0100"; "0111"; "0000" |]; + [|"0000"; "0110"; "0100"; "0100" |]; + [|"0000"; "1110"; "0010"; "0000" |]; + [|"0010"; "0010"; "0110"; "0000" |] ]; + + [ [|"0000"; "1100"; "0110"; "0000" |]; + [|"0010"; "0110"; "0100"; "0000" |]; + [|"0000"; "1100"; "0110"; "0000" |]; + [|"0010"; "0110"; "0100"; "0000" |] ]; + + [ [|"0000"; "0011"; "0110"; "0000" |]; + [|"0100"; "0110"; "0010"; "0000" |]; + [|"0000"; "0011"; "0110"; "0000" |]; + [|"0000"; "0100"; "0110"; "0010" |] ]; + + [ [|"0000"; "0000"; "1110"; "0100" |]; + [|"0000"; "0100"; "1100"; "0100" |]; + [|"0000"; "0100"; "1110"; "0000" |]; + [|"0000"; "0100"; "0110"; "0100" |] ]; +] +;; + +let line_empty = int_of_string "0b1110000000000111" +and line_full = int_of_string "0b1111111111111111" +;; + +let decode_block dvec = + let btoi d = int_of_string ("0b" ^ d) in + Array.map btoi dvec +;; + +let init fw = + let scorev = Textvariable.create () + and linev = Textvariable.create () + and levv = Textvariable.create () + and _namev = Textvariable.create () in + let f = Frame.create fw [BorderWidth (Pixels 2)] in + let c = + Canvas.create f + [Width (Pixels (block_size * 10)); + Height (Pixels (block_size * 20)); + BorderWidth (Pixels cell_border); + Relief Sunken; + Background Black] + and r = Frame.create f [] + and r' = Frame.create f [] in + + let nl = Label.create r [Text "Next"; Font "variable"] in + let nc = + Canvas.create r + [Width (Pixels (block_size * 4)); + Height (Pixels (block_size * 4)); + BorderWidth (Pixels cell_border); + Relief Sunken; + Background Black] in + let scl = Label.create r [Text "Score"; Font "variable"] in + let sc = Label.create r [TextVariable scorev; Font "variable"] in + let lnl = Label.create r [Text "Lines"; Font "variable"] in + let ln = Label.create r [TextVariable linev; Font "variable"] in + let levl = Label.create r [Text "Level"; Font "variable"] in + let lev = Label.create r [TextVariable levv; Font "Variable"] in + let newg = Button.create r [Text "New Game"; Font "variable"] in + let exitg = Button.create r [Text "Quit"; Font "variable"] in + + pack [f] []; + pack [c; r; r'] [Side Side_Left; Fill Fill_Y]; + pack [nl; nc] [Side Side_Top]; + pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top]; + + let cells_src = Array.make_matrix 20 10 () in + let cells = Array.map (Array.map (fun () -> + {tag = + (let t1, t2, t3 = + Canvas.create_rectangle c + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + (Pixels (-9)) (Pixels (-9)) [], + Canvas.create_rectangle c + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + (Pixels (-11)) (Pixels (-11)) [], + Canvas.create_rectangle c + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + (Pixels (-13)) (Pixels (-13)) [] in + Canvas.raise_top c t1; + Canvas.raise_top c t2; + Canvas.lower_bot c t3; + t1, t2, t3); + color = 0})) cells_src in + let nexts_src = Array.make_matrix 4 4 () in + let nexts = + Array.map (Array.map (fun () -> + {tag = + (let t1, t2, t3 = + Canvas.create_rectangle nc + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + (Pixels (-9)) (Pixels (-9)) [], + Canvas.create_rectangle nc + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + (Pixels (-11)) (Pixels (-11)) [], + Canvas.create_rectangle nc + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + (Pixels (-13)) (Pixels (-13)) [] in + Canvas.raise_top nc t1; + Canvas.raise_top nc t2; + Canvas.lower_bot nc t3; + t1, t2, t3); + color = 0})) nexts_src in + let game_over () = () + in + [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, + (c, cells), (nc, nexts), scorev, linev, levv, game_over +;; + +let cell_get (c, cf) x y = cf.(y).(x).color;; + +let cell_set (c, cf) x y col = + let cur = cf.(y).(x) in + let t1, t2, t3 = cur.tag in + if cur.color = col then () else + if cur.color <> 0 && col = 0 then begin + Canvas.move c t1 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); + Canvas.move c t2 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); + Canvas.move c t3 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)) + + end else begin + Canvas.configure_rectangle c t2 + [FillColor (Array.get colors (col - 1)); + Outline (Array.get colors (col - 1))]; + Canvas.configure_rectangle c t1 + [FillColor Black; + Outline Black]; + Canvas.configure_rectangle c t3 + [FillColor (NamedColor "light gray"); + Outline (NamedColor "light gray")]; + if cur.color = 0 && col <> 0 then begin + Canvas.move c t1 + (Pixels (block_size * (x + 1) + 10 + cell_border * 2)) + (Pixels (block_size * (y + 1) + 10 + cell_border * 2)); + Canvas.move c t2 + (Pixels (block_size * (x + 1) + 10 + cell_border * 2)) + (Pixels (block_size * (y + 1) + 10 + cell_border * 2)); + Canvas.move c t3 + (Pixels (block_size * (x + 1) + 10 + cell_border * 2)) + (Pixels (block_size * (y + 1) + 10 + cell_border * 2)) + end + end; + cur.color <- col +;; + +let draw_block field col d x y = + for iy = 0 to 3 do + let base = ref 1 in + let xd = Array.get d iy in + for ix = 0 to 3 do + if xd land !base <> 0 then begin + try cell_set field (ix + x) (iy + y) col with _ -> () + end; + base := !base lsl 1 + done + done +;; + +let timer_ref = (ref None : Timer.t option ref);; + +let remove_timer () = + match !timer_ref with + | None -> () + | Some t -> Timer.remove t +;; + +let do_after milli f = timer_ref := Some (Timer.add milli f);; + +let copy_block c = + { pattern = !c.pattern; + bcolor = !c.bcolor; + x = !c.x; + y = !c.y; + d = !c.d; + alive = !c.alive } +;; + +let start_game () = + let top = openTk () in + Wm.title_set top ""; + let lb = Label.create top [] + and fw = Frame.create top [] in + let set_message s = Label.configure lb [Text s] in + pack [lb; fw] [Side Side_Top]; + let score = ref 0 in + let line = ref 0 in + let level = ref 0 in + let time = ref 1000 in + let blocks = List.map (List.map decode_block) blocks in + let field = Array.make 26 0 in + let widgets, newg, exitg, cell_field, next_field, + scorev, linev, levv, game_over = init fw in + let canvas = fst cell_field in + + let init_field () = + for i = 0 to 25 do + field.(i) <- line_empty + done; + field.(23) <- line_full; + for i = 0 to 19 do + for j = 0 to 9 do + cell_set cell_field j i 0 + done + done; + for i = 0 to 3 do + for j = 0 to 3 do + cell_set next_field j i 0 + done + done in + + let draw_falling_block fb = + draw_block cell_field fb.bcolor + (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) + and erase_falling_block fb = + draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in + + let stone fb = + for i = 0 to 3 do + let cur = field.(i + fb.y) in + field.(i + fb.y) <- + cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) + done; + for i = 0 to 2 do field.(i) <- line_empty done + + and clear fb = + let l = ref 0 in + for i = 0 to 3 do + if i + fb.y >= 3 && i + fb.y <= 22 && + field.(i + fb.y) = line_full then begin + incr l; + field.(i + fb.y) <- line_empty; + for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done + end + done; + !l + + and fall_lines () = + let eye = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) in + try + while !eye >= 3 do + while field.(!eye) = line_empty do + decr eye; + if !eye = 2 then raise Done + done; + field.(!cur) <- field.(!eye); + for j = 0 to 9 do + cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) + done; + decr eye; + decr cur + done + with Done -> (); + for i = 3 to !cur do + field.(i) <- line_empty; + for j = 0 to 9 do cell_set cell_field j (i - 3) 0 done + done in + + let next = ref 42 (* THE ANSWER *) + and current = + ref { pattern= [[|0; 0; 0; 0|]]; + bcolor = 0; x = 0; y = 0; d = 0; alive = false} in + + let draw_next () = + draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0 + + and erase_next () = + draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in + + let set_nextblock () = + current := + { pattern = (List.nth blocks !next); + bcolor = !next + 1; + x = 6; y = 1; d = 0; alive = true}; + erase_next (); + next := Random.int 7; + draw_next () in + + let death_check fb = + try + for i=0 to 3 do + let cur = field.(i + fb.y) in + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + then raise Done + done; + false + with + Done -> true in + + let try_to_move m = + if !current.alive then + let sub m = + if death_check m then false + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + true + end in + if sub m then () else begin + m.x <- m.x + 1; + if sub m then () else begin + m.x <- m.x - 2; + ignore (sub m) + end + end + else () in + + let image_load = + let i = + Canvas.create_image canvas + (Pixels (block_size * 5 + block_size / 2)) + (Pixels (block_size * 10 + block_size / 2)) + [Anchor Center] in + Canvas.lower_bot canvas i; + let img = Imagephoto.create [] in + fun file -> + try + Imagephoto.configure img [File file]; + Canvas.configure_image canvas i [ImagePhoto img] + with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in + + let add_score l = + let pline = !line in + if l <> 0 then + begin + line := !line + l; + score := !score + l * l; + set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) + end; + Textvariable.set linev (string_of_int !line); + Textvariable.set scorev (string_of_int !score); + + if !line / 10 <> pline / 10 then + (* update the background every 10 lines. *) + begin + let num_image = List.length backgrounds - 1 in + let n = !line / 10 in + let n = if n > num_image then num_image else n in + let file = List.nth backgrounds n in + image_load file; + (* Future work: We should gain level after an image is put... *) + incr level; + Textvariable.set levv (string_of_int !level) + end in + + let rec newblock () = + set_message "TETRIS"; + set_nextblock (); + draw_falling_block !current; + if death_check !current then begin + !current.alive <- false; + set_message "GAME OVER"; + game_over () + end else begin + time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); + if !time < 60 - !level * 3 then time := 60 - !level * 3; + do_after stop_a_bit loop + end + + and loop () = + let m = copy_block current in + m.y <- m.y + 1; + if death_check m then begin + !current.alive <- false; + stone !current; + do_after stop_a_bit (fun () -> + let l = clear !current in + if l > 0 then + do_after stop_a_bit (fun () -> + fall_lines (); + add_score l; + do_after stop_a_bit newblock) + else newblock ()) + end else begin + erase_falling_block !current; + draw_falling_block m; + current := m; + do_after !time loop + end in + + let bind_game w = + bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], + fun e -> + match e.ev_KeySymString with + | "h" -> + let m = copy_block current in + m.x <- m.x - 1; + try_to_move m + | "j" -> + let m = copy_block current in + m.d <- m.d + 1; + if m.d = List.length m.pattern then m.d <- 0; + try_to_move m + | "k" -> + let m = copy_block current in + m.d <- m.d - 1; + if m.d < 0 then m.d <- List.length m.pattern - 1; + try_to_move m + | "l" -> + let m = copy_block current in + m.x <- m.x + 1; + try_to_move m + | "m" -> + remove_timer (); + loop () + | "space" -> + if !current.alive then + begin + let m = copy_block current + and n = copy_block current in + while + m.y <- m.y + 1; + if death_check m then false + else begin n.y <- m.y; true end + do () done; + erase_falling_block !current; + draw_falling_block n; + current := n; + remove_timer (); + loop () + end + | _ -> () + )) in + + let game_init () = + (* Game Initialization *) + set_message "Initializing ..."; + remove_timer (); + image_load (List.hd backgrounds); + time := 1000; + score := 0; + line := 0; + level := 1; + add_score 0; + init_field (); + next := Random.int 7; + set_message "Welcome to TETRIS"; + set_nextblock (); + draw_falling_block !current; + do_after !time loop in + + bind_game top; + Button.configure newg [Command game_init]; + Button.configure exitg [Command (fun () -> exit 0)]; + game_init () +;; + +let tetris () = + start_game (); + Printexc.print mainLoop () +;; + +if !Sys.interactive then () else begin tetris (); exit 0 end;; diff --git a/examples_camltk/text.ml b/examples_camltk/text.ml new file mode 100644 index 0000000..0f87633 --- /dev/null +++ b/examples_camltk/text.ml @@ -0,0 +1,54 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Tk + +let top = opentk () + +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + +let f = Frame.create top [] +let text = Text.create f [] +let scrollbar = Scrollbar.create f [] + +let buffer = ref "" + +let kill () = + buffer := + Text.get text (TextIndex (Insert, [])) + (TextIndex (Insert, [LineEnd])); + Text.delete text (TextIndex (Insert, [])) + (TextIndex (Insert, [LineEnd])) +;; + +let yank () = + Text.insert text (TextIndex (Insert, [])) !buffer [] + +let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> + yank () )) +;; +let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> + kill () )) +;; + +let _ = + scroll_link scrollbar text; + + pack [text;f][]; + pack [f][]; + mainLoop () +;; diff --git a/examples_camltk/winskel.ml b/examples_camltk/winskel.ml new file mode 100644 index 0000000..c83e643 --- /dev/null +++ b/examples_camltk/winskel.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* This examples is based on Ousterhout's book (fig 16.15) *) +open Camltk + +let main () = + let top = opentk() in + let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] + and dummy = + Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in + pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; + let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] + and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0] + and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0] + and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0] + and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0] + and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in + pack [file;edit;graphics;text;view] [Side Side_Left]; + pack [help] [Side Side_Right]; + (* same code as chap16-14 *) + let m = Menu.create text [] in + let bold = Textvariable.create() + and italic = Textvariable.create() + and underline = Textvariable.create() in + Menu.add_checkbutton m [Label "Bold"; Variable bold]; + Menu.add_checkbutton m [Label "Italic"; Variable italic]; + Menu.add_checkbutton m [Label "Underline"; Variable underline]; + Menu.add_separator m; + let font = Textvariable.create() in + Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"]; + Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"] +; + Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; + Menu.add_separator m; + Menu.add_command m [Label "Insert Bullet"; + Command (function () -> + print_string "Insert Bullet\n"; + flush stdout)]; + Menu.add_command m [Label "Margins and Tags..."; + Command (function () -> + print_string "margins\n"; + flush stdout)]; + Menubutton.configure text [Menu m]; + + mainLoop() + + + +let _ = + Printexc.catch main () diff --git a/examples_labltk/.gitignore b/examples_labltk/.gitignore new file mode 100644 index 0000000..c1f6ec6 --- /dev/null +++ b/examples_labltk/.gitignore @@ -0,0 +1,8 @@ +calc +clock +demo +eyes +hello +tetris +lang +taquin diff --git a/examples_labltk/Lambda2.back.gif b/examples_labltk/Lambda2.back.gif new file mode 100644 index 0000000..7cb3d2c Binary files /dev/null and b/examples_labltk/Lambda2.back.gif differ diff --git a/examples_labltk/Makefile b/examples_labltk/Makefile new file mode 100644 index 0000000..798d363 --- /dev/null +++ b/examples_labltk/Makefile @@ -0,0 +1,69 @@ +####################################################################### +# # +# 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 ../lib -I ../labltk -I ../support -w s -dllpath ../support + +all: hello demo eyes calc clock tetris lang + +opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt + +hello: hello.cmo + $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo + +demo: demo.cmo + $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo + +eyes: eyes.cmo + $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo + +calc: calc.cmo + $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo + +clock: clock.cmo + $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo + +clock.opt: clock.cmx + $(CAMLOPT) $(COMPFLAGS) -o clock.opt \ + $(LIBNAME).cmxa unix.cmxa clock.cmx + +tetris: tetris.cmo + $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo + +taquin: taquin.cmo + $(CAMLC) $(COMPFLAGS) -o taquin $(LIBNAME).cma taquin.cmo + +lang: lang.cmo + $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo + +clean: + rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm* + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.cmx.opt: + $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $< diff --git a/examples_labltk/Makefile.nt b/examples_labltk/Makefile.nt new file mode 100644 index 0000000..f3a127b --- /dev/null +++ b/examples_labltk/Makefile.nt @@ -0,0 +1,66 @@ +####################################################################### +# # +# 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 + +# We are using the non-installed library ! +COMPFLAGS= -I ../lib -I ../labltk -I ../support +LINKFLAGS= -I ../lib -I ../labltk -I ../support + +# Use pieces of Makefile.config +TKLINKOPT=$(LIBNAME).cma $(TKLIBS) + +all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe + +hello.exe: hello.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ hello.cmo + +demo.exe: demo.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ demo.cmo + +eyes.exe: eyes.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ eyes.cmo + +calc.exe: calc.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ calc.cmo + +clock.exe: clock.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ + -o $@ clock.cmo + +tetris.exe: tetris.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ tetris.cmo + +lang.exe: lang.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ lang.cmo + +clean : + rm -f *.cm? *.exe + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/examples_labltk/README b/examples_labltk/README new file mode 100644 index 0000000..ec0f20d --- /dev/null +++ b/examples_labltk/README @@ -0,0 +1,20 @@ +$Id$ + +Some examples for LablTk. +They are written in classic mode, except testris.ml which uses label +commutation. +You may either compile them here, or just run them as scripts with + labltk example.ml + +hello.ml A very simple example of CamlTk +hello.tcl The same programme in Tcl/Tk + +demo.ml A demonstration using many widget classes + +eyes.ml A "bind" test + +calc.ml A little calculator + +clock.ml An analog clock (uses unix.cma) + +tetris.ml You NEED a game also (uses -labels) diff --git a/examples_labltk/calc.ml b/examples_labltk/calc.ml new file mode 100644 index 0000000..17a410c --- /dev/null +++ b/examples_labltk/calc.ml @@ -0,0 +1,129 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* A simple calculator demonstrating OO programming with O'Labl + and LablTk. + + LablTk itself is not OO, but it is good to wrap complex + structures in objects. Even if the absence of initializers + makes things a little bit awkward. +*) + +open StdLabels +open Tk + +let mem_string ~elt:c s = + try + for i = 0 to String.length s -1 do + if s.[i] = c then raise Exit + done; false + with Exit -> true + +let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] + +(* The abstract calculator class. + Does not use Tk (only Textvariable) *) + +class calc () = object (calc) + val variable = Textvariable.create () + val mutable x = 0.0 + val mutable op = None + val mutable displaying = true + + method set = Textvariable.set variable + method get = Textvariable.get variable + method insert s = calc#set (calc#get ^ s) + method get_float = float_of_string (calc#get) + + method command s = + if s <> "" then match s.[0] with + '0'..'9' -> + if displaying then (calc#set ""; displaying <- false); + calc#insert s + | '.' -> + if displaying then + (calc#set "0."; displaying <- false) + else + if not (mem_string ~elt:'.' calc#get) then calc#insert s + | '+'|'-'|'*'|'/' as c -> + displaying <- true; + begin match op with + None -> + x <- calc#get_float; + op <- Some (List.assoc c ops) + | Some f -> + x <- f x (calc#get_float); + op <- Some (List.assoc c ops); + calc#set (Printf.sprintf "%g" x) + end + | '='|'\n'|'\r' -> + displaying <- true; + begin match op with + None -> () + | Some f -> + x <- f x (calc#get_float); + op <- None; + calc#set (Printf.sprintf "%g" x) + end + | 'q' -> closeTk (); exit 0 + | _ -> () +end + +(* Buttons for the calculator *) + +let m = + [|["7";"8";"9";"+"]; + ["4";"5";"6";"-"]; + ["1";"2";"3";"*"]; + ["0";".";"=";"/"]|] + +(* The physical calculator. Inherits from the abstract one *) + +class calculator ~parent = object + inherit calc () as calc + + val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent + val frame = Frame.create parent + + initializer + let buttons = + Array.map ~f: + (List.map ~f: + (fun text -> + Button.create ~text ~command:(fun () -> calc#command text) frame)) + m + in + Label.configure ~textvariable:variable label; + calc#set "0"; + bind ~events:[`KeyPress] ~fields:[`Char] + ~action:(fun ev -> calc#command ev.ev_Char) + parent; + for i = 0 to Array.length m - 1 do + Grid.configure ~row:i buttons.(i) + done; + pack ~side:`Top ~fill:`X [label]; + pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; +end + +(* Finally start everything *) + +let top = openTk () + +let applet = new calculator ~parent:top + +let _ = mainLoop () diff --git a/examples_labltk/clock.ml b/examples_labltk/clock.ml new file mode 100644 index 0000000..6903acb --- /dev/null +++ b/examples_labltk/clock.ml @@ -0,0 +1,133 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Clock/V, a simple clock. + Reverts every time you push the right button. + Adapted from ASCII/V May 1997 + + Uses Tk and Unix, so you must link with + labltklink unix.cma clock.ml -o clock -cclib -lunix +*) + +open Tk + +(* pi is not a constant! *) +let pi = acos (-1.) + +(* The main class: + * create it with a parent: [new clock parent:top] + * initialize with [#init] +*) + +class clock ~parent = object (self) + + (* Instance variables *) + val canvas = Canvas.create ~width:100 ~height:100 parent + val mutable height = 100 + val mutable width = 100 + val mutable rflag = -1 + + (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) + method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) + method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) + + initializer + (* Create the oval border *) + Canvas.create_oval canvas ~tags:["cadran"] + ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) + ~width:3 ~outline:`Yellow ~fill:`White; + (* Draw the figures *) + self#draw_figures; + (* Create the arrows with dummy position *) + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["hours"] ~fill:`Red; + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["minutes"] ~fill:`Blue; + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["seconds"] ~fill:`Black; + (* Setup a timer every second *) + let rec timer () = + self#draw_arrows (Unix.localtime (Unix.time ())); + Timer.add ~ms:1000 ~callback:timer; () + in timer (); + (* Redraw when configured (changes size) *) + bind canvas ~events:[`Configure] ~action: + begin fun _ -> + width <- Winfo.width canvas; + height <- Winfo.height canvas; + self#redraw + end; + (* Change direction with right button *) + bind canvas ~events:[`ButtonPressDetail 3] + ~action:(fun _ -> rflag <- -rflag; self#redraw); + (* Pack, expanding in both directions *) + pack ~fill:`Both ~expand:true [canvas] + + (* Redraw everything *) + method redraw = + Canvas.coords_set canvas (`Tag "cadran") + ~xys:[ 1, 1; width - 2, height - 2 ]; + self#draw_figures; + self#draw_arrows (Unix.localtime (Unix.time ())) + + (* Delete and redraw the figures *) + method draw_figures = + Canvas.delete canvas [`Tag "figures"]; + for i = 1 to 12 do + let angle = float (rflag * i - 3) *. pi /. 6. in + Canvas.create_text canvas + ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) + ~tags:["figures"] + ~text:(string_of_int i) ~font:"variable" + ~anchor:`Center + done + + (* Resize and reposition the arrows *) + method draw_arrows tm = + Canvas.configure_line ~width:(min width height / 40) + canvas (`Tag "hours"); + let hangle = + float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) + *. pi /. 360. in + Canvas.coords_set canvas (`Tag "hours") + ~xys:[ self#x 0., self#y 0.; + self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; + Canvas.configure_line ~width:(min width height / 50) + canvas (`Tag "minutes"); + let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in + Canvas.coords_set canvas (`Tag "minutes") + ~xys:[ self#x 0., self#y 0.; + self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; + let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in + Canvas.coords_set canvas (`Tag "seconds") + ~xys:[ self#x 0., self#y 0.; + self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] +end + +(* Initialize the Tcl interpreter *) +let top = openTk () + +(* Create a clock on the main window *) +let clock = + new clock ~parent:top + +(* Wait for events *) +let _ = mainLoop () diff --git a/examples_labltk/demo.ml b/examples_labltk/demo.ml new file mode 100644 index 0000000..9524c1c --- /dev/null +++ b/examples_labltk/demo.ml @@ -0,0 +1,166 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Some CamlTk4 Demonstration by JPF *) + +(* First, open these modules for convenience *) +open StdLabels +open Tk + +(* Dummy let *) +let _ = + +(* Initialize Tk *) +let top = openTk () in +(* Title setting *) +Wm.title_set top "LablTk demo"; + +(* Base frame *) +let base = Frame.create top in +pack [base]; + +(* Menu bar *) +let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in +pack ~fill:`X [bar]; + + (* Menu and Menubutton *) + let meb = Menubutton.create ~text:"Menu" bar in + let men = Menu.create meb in + Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; + Menubutton.configure ~menu:men meb; + + (* Frames *) + let base2 = Frame.create base in + let left = Frame.create base2 in + let right = Frame.create base2 in + pack [base2]; + pack ~side:`Left [left; right]; + + (* Widgets on left and right *) + + (* Button *) + let but = Button.create ~text:"Welcome to LablTk" left in + + (* Canvas *) + let can = + Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left + in + let oval = Canvas.create_oval ~x1: 10 ~y1: 10 + ~x2: 90 ~y2: 90 + ~fill: `Red + can + in ignore oval; + + (* Check button *) + let che = Checkbutton.create ~text:"Check" left in + + (* Entry *) + let ent = Entry.create ~width:10 left in + + (* Label *) + let lab = Label.create ~text:"Welcome to LablTk" left in + + (* Listbox *) + let lis = Listbox.create left in + Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; + + (* Message *) + let mes = Message.create + ~text: "Hello this is a message widget with very long text, but ..." + left in + + (* Radio buttons *) + let tv = Textvariable.create () in + Textvariable.set tv "One"; + let radf = Frame.create right in + let rads = List.map + ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) + ["One"; "Two"; "Three"] in + + (* Scale *) + let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in + + (* Text and scrollbar *) + let texf = Frame.create right in + + (* Text *) + let tex = Text.create ~width:20 ~height:8 texf in + Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; + + (* Scrollbar *) + let scr = Scrollbar.create texf in + + (* Text and Scrollbar widget link *) + let scroll_link sb tx = + Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; + Scrollbar.configure ~command:(Text.yview tx) sb in + scroll_link scr tex; + + pack ~side:`Right ~fill:`Y [scr]; + pack ~side:`Left ~fill:`Both ~expand:true [tex]; + + (* Pack them *) + pack ~side:`Left [meb]; + pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; + pack [coe radf; coe sca; coe texf]; + pack rads; + + (* Toplevel *) + let top2 = Toplevel.create top in + Wm.title_set top2 "LablTk demo control"; + let defcol = `Color "#dfdfdf" in + let selcol = `Color "#ffdfdf" in + let buttons = + List.map ~f:(fun (w, t, c, a) -> + let b = Button.create ~text:t ~command:c top2 in + bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; + bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; + b) + [coe bar, "Frame", (fun () -> ()), + (fun background -> Frame.configure ~background bar); + coe meb, "Menubutton", (fun () -> ()), + (fun background -> Menubutton.configure ~background meb); + coe but, "Button", (fun () -> ()), + (fun background -> Button.configure ~background but); + coe can, "Canvas", (fun () -> ()), + (fun background -> Canvas.configure ~background can); + coe che, "CheckButton", (fun () -> ()), + (fun background -> Checkbutton.configure ~background che); + coe ent, "Entry", (fun () -> ()), + (fun background -> Entry.configure ~background ent); + coe lab, "Label", (fun () -> ()), + (fun background -> Label.configure ~background lab); + coe lis, "Listbox", (fun () -> ()), + (fun background -> Listbox.configure ~background lis); + coe mes, "Message", (fun () -> ()), + (fun background -> Message.configure ~background mes); + coe radf, "Radiobox", (fun () -> ()), + (fun background -> + List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); + coe sca, "Scale", (fun () -> ()), + (fun background -> Scale.configure ~background sca); + coe tex, "Text", (fun () -> ()), + (fun background -> Text.configure ~background tex); + coe scr, "Scrollbar", (fun () -> ()), + (fun background -> Scrollbar.configure ~background scr) + ] + in + pack ~fill:`X buttons; + +(* Main Loop *) +Printexc.print mainLoop () diff --git a/examples_labltk/eyes.ml b/examples_labltk/eyes.ml new file mode 100644 index 0000000..74f59f6 --- /dev/null +++ b/examples_labltk/eyes.ml @@ -0,0 +1,62 @@ +(***********************************************************************) +(* *) +(* 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 Tk + +let _ = + let top = openTk () in + let fw = Frame.create top in + pack [fw]; + let c = Canvas.create ~width: 200 ~height: 200 fw in + let create_eye cx cy wx wy ewx ewy bnd = + let _o2 = Canvas.create_oval + ~x1:(cx - wx) ~y1:(cy - wy) + ~x2:(cx + wx) ~y2:(cy + wy) + ~outline: `Black ~width: 7 + ~fill: `White + c + and o = Canvas.create_oval + ~x1:(cx - ewx) ~y1:(cy - ewy) + ~x2:(cx + ewx) ~y2:(cy + ewy) + ~fill:`Black + c in + let curx = ref cx + and cury = ref cy in + bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] + ~action:(fun e -> + let nx, ny = + let xdiff = e.ev_MouseX - cx + and ydiff = e.ev_MouseY - cy in + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + (float ydiff /. (float wy *. bnd)) ** 2.0) in + if diff > 1.0 then + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy + else + e.ev_MouseX, e.ev_MouseY + in + Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); + curx := nx; + cury := ny) + c + in + create_eye 60 100 30 40 5 6 0.6; + create_eye 140 100 30 40 5 6 0.6; + pack [c] + +let _ = Printexc.print mainLoop () diff --git a/examples_labltk/hello.ml b/examples_labltk/hello.ml new file mode 100644 index 0000000..838b50f --- /dev/null +++ b/examples_labltk/hello.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* LablTk4 Demonstration by JPF *) + +(* First, open this modules for convenience *) +open Tk + +(* initialization of Tk --- the result is a toplevel widget *) +let top = openTk () + +(* create a button on top *) +(* Button.create : use of create function defined in button.ml *) +(* But you shouldn't open Button module for other widget class modules use *) +let b = Button.create ~text: "Hello, LablTk!" top + +(* Lack of toplevel expressions in lsl, you must use dummy let exp. *) +let _ = pack [coe b] + +(* Last, you must call mainLoop *) +(* You can write just let _ = mainLoop () *) +(* But Printexc.print will help you *) +let _ = Printexc.print mainLoop () diff --git a/examples_labltk/hello.tcl b/examples_labltk/hello.tcl new file mode 100755 index 0000000..6791d2e --- /dev/null +++ b/examples_labltk/hello.tcl @@ -0,0 +1,21 @@ +#!/usr/bin/wish + +####################################################################### +# # +# 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. # +# # +####################################################################### + +button .hello -text "Hello, TclTk!" + +pack .hello diff --git a/examples_labltk/lang.ml b/examples_labltk/lang.ml new file mode 100644 index 0000000..0d6ba8c --- /dev/null +++ b/examples_labltk/lang.ml @@ -0,0 +1,75 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* language encoding using UTF-8 *) +open Tk + +let top = opentk () + +(* declare Tk that we use utf-8 to communicate *) +(* problem: Text display is highly dependent on your font installation + and configulation. The fonts with no-scale setting are selected + only if the point sizes are exactly same??? +*) +let _ = + Encoding.system_set "utf-8"; + let l = Label.create top ~text: "???" in + pack [l]; + let t = Text.create top in + pack [t]; + + let create_hello lang hello = + let b = Button.create t ~text: lang ~command: (fun () -> + Label.configure l ~text: hello) + in + Text.window_create t ~index: (`End,[]) ~window: b + in + List.iter (fun (lang, hello) -> create_hello lang hello) + ["Amharic(አማርኛ)", "ሠላም"; + "Arabic", "�����������"; + "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; + "Czech (česky)", "Dobrý den"; + "Danish (Dansk)", "Hej, Goddag"; + "English", "Hello"; + "Esperanto", "Saluton"; + "Estonian", "Tere, Tervist"; + "FORTRAN", "PROGRAM"; + "Finnish (Suomi)", "Hei"; + "French (Français)", "Bonjour, Salut"; + "German (Deutsch Nord)", "Guten Tag"; + "German (Deutsch Süd)", "Grüß Gott"; + "Greek (Ελληνικά)", "Γειά σας"; + "Hebrew", "שלום"; + "Italiano", "Ciao, Buon giorno"; + "Maltese", "Ciao"; + "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; + "Norwegian (Norsk)", "Hei, God dag"; + "Polish", "Cześć!"; + "Russian (Русский)", "Здравствуйте!"; + "Slovak", "Dobrý deň"; + "Spanish (Español)", "¡Hola!"; + "Swedish (Svenska)", "Hej, Goddag"; + "Thai (�������)", "�������, ������"; + "Tigrigna (ትግርኛ)", "ሰላማት"; + "Turkish (Türkçe)", "Merhaba"; + "Vietnamese (Tiếng Việt)", "Chào bạn"; + "Japanese (日本語)", "こんにちは"; + "Chinese (中文,普通话,汉语)", "你好"; + "Cantonese (粵語,廣東話)", "早晨, 你好"; + "Hangul (한글)", "안녕하세요, 안녕하십니까" ] +;; + +let _ = Printexc.print mainLoop () diff --git a/examples_labltk/taquin.ml b/examples_labltk/taquin.ml new file mode 100644 index 0000000..616f38c --- /dev/null +++ b/examples_labltk/taquin.ml @@ -0,0 +1,143 @@ +(***********************************************************************) +(* *) +(* 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 Tk;; + +let d�coupe_image img nx ny = + let l = Imagephoto.width img + and h = Imagephoto.height img in + let tx = l / nx and ty = h / ny in + let pi�ces = ref [] in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + let pi�ce = Imagephoto.create ~width:tx ~height:ty () in + Imagephoto.copy ~src:img + ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pi�ce; + pi�ces := pi�ce :: !pi�ces + done + done; + (tx, ty, List.tl !pi�ces);; + +let remplir_taquin c nx ny tx ty pi�ces = + let trou_x = ref (nx - 1) + and trou_y = ref (ny - 1) in + let trou = + Canvas.create_rectangle + ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in + let taquin = Array.make_matrix nx ny trou in + let p = ref pi�ces in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + match !p with + | [] -> () + | pi�ce :: reste -> + taquin.(x).(y) <- + Canvas.create_image + ~x:(x * tx) ~y:(y * ty) + ~image:pi�ce ~anchor:`Nw ~tags:["pi�ce"] c; + p := reste + done + done; + let d�placer x y = + let pi�ce = taquin.(x).(y) in + Canvas.coords_set c pi�ce + ~xys:[!trou_x * tx, !trou_y * ty]; + Canvas.coords_set c trou + ~xys:[x * tx, y * ty; tx, ty]; + taquin.(!trou_x).(!trou_y) <- pi�ce; + taquin.(x).(y) <- trou; + trou_x := x; trou_y := y in + let jouer ei = + let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in + if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) + || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) + then d�placer x y in + Canvas.bind ~events:[`ButtonPress] + ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pi�ce");; + +let rec permutation = function + | [] -> [] + | l -> let n = Random.int (List.length l) in + let (�l�ment, reste) = partage l n in + �l�ment :: permutation reste + +and partage l n = + match l with + | [] -> failwith "partage" + | t�te :: reste -> + if n = 0 then (t�te, reste) else + let (�l�ment, reste') = partage reste (n - 1) in + (�l�ment, t�te :: reste');; + +let create_filled_text parent lines = + let lnum = List.length lines + and lwidth = + List.fold_right + (fun line max -> + let l = String.length line in + if l > max then l else max) + lines 1 in + let txtw = Text.create ~width:lwidth ~height:lnum parent in + List.iter + (fun line -> + Text.insert ~index:(`End, []) ~text:line txtw; + Text.insert ~index:(`End, []) ~text:"\n" txtw) + lines; + txtw;; + +let give_help parent lines () = + let help_window = Toplevel.create parent in + Wm.title_set help_window "Help"; + + let help_frame = Frame.create help_window in + + let help_txtw = create_filled_text help_frame lines in + + let quit_help () = destroy help_window in + let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in + + pack ~side:`Bottom [help_txtw]; + pack ~side:`Bottom [ok_button ]; + pack [help_frame];; + +let taquin nom_fichier nx ny = + let fp = openTk () in + Wm.title_set fp "Taquin"; + let img = Imagephoto.create ~file:nom_fichier () in + let c = + Canvas.create ~background:`Black + ~width:(Imagephoto.width img) + ~height:(Imagephoto.height img) fp in + let (tx, ty, pi�ces) = d�coupe_image img nx ny in + remplir_taquin c nx ny tx ty (permutation pi�ces); + pack [c]; + + let quit = Button.create ~text:"Quit" ~command:closeTk fp in + let help_lines = + ["Pour jouer, cliquer sur une des pi�ces"; + "entourant le trou"; + ""; + "To play, click on a part around the hole"] in + let help = + Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in + pack ~side:`Left ~fill:`X [quit] ; + pack ~side:`Left ~fill:`X [help] ; + mainLoop ();; + +if !Sys.interactive then () else +begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/examples_labltk/tetris.ml b/examples_labltk/tetris.ml new file mode 100644 index 0000000..28544e0 --- /dev/null +++ b/examples_labltk/tetris.ml @@ -0,0 +1,709 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* A Tetris game for LablTk *) +(* written by Jun P. Furuse *) + +open StdLabels +open Tk + +exception Done + +type falling_block = { + mutable pattern: int array list; + mutable bcolor: int; + mutable x: int; + mutable y: int; + mutable d: int; + mutable alive: bool + } + +let stop_a_bit = 300 + +let field_width = 10 +let field_height = 20 + +let colors = [| + `Color "red"; + `Color "yellow"; + + `Color "blue"; + `Color "orange"; + + `Color "magenta"; + `Color "green"; + + `Color "cyan" +|] + +(* Put here your favorite image files *) +let backgrounds = [ + "Lambda2.back.gif" +] + +(* blocks *) +let block_size = 16 +let cell_border = 2 + +let blocks = [ + [ [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |]; + + [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |] ]; + + [ [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0111"; + "0100"; + "0000" |]; + + [|"0000"; + "0110"; + "0010"; + "0010" |]; + + [|"0000"; + "0010"; + "1110"; + "0000" |]; + + [|"0100"; + "0100"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0100"; + "0111"; + "0000" |]; + + [|"0000"; + "0110"; + "0100"; + "0100" |]; + + [|"0000"; + "1110"; + "0010"; + "0000" |]; + + [|"0010"; + "0010"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |]; + + [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |] ]; + + [ [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0100"; + "0110"; + "0010"; + "0000" |]; + + [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0010" |] ]; + + [ [|"0000"; + "0000"; + "1110"; + "0100" |]; + + [|"0000"; + "0100"; + "1100"; + "0100" |]; + + [|"0000"; + "0100"; + "1110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0100" |] ] + +] + +let line_empty = int_of_string "0b1110000000000111" +let line_full = int_of_string "0b1111111111111111" + +let decode_block dvec = + let btoi d = int_of_string ("0b"^d) in + Array.map ~f:btoi dvec + +class cell t1 t2 t3 ~canvas ~x ~y = object + val mutable color = 0 + method get = color + method set ~color:col = + if color = col then () else + if color <> 0 && col = 0 then begin + Canvas.move canvas t1 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2); + Canvas.move canvas t2 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2); + Canvas.move canvas t3 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2) + end else begin + Canvas.configure_rectangle canvas t2 + ~fill: colors.(col - 1) + ~outline: colors.(col - 1); + Canvas.configure_rectangle canvas t1 + ~fill: `Black + ~outline: `Black; + Canvas.configure_rectangle canvas t3 + ~fill: (`Color "light gray") + ~outline: (`Color "light gray"); + if color = 0 && col <> 0 then begin + Canvas.move canvas t1 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2); + Canvas.move canvas t2 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2); + Canvas.move canvas t3 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2) + end + end; + color <- col +end + +let cell_get (c, cf) x y = cf.(y).(x) #get + +let cell_set (c, cf) ~x ~y ~color = + if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then + let cur = cf.(y).(x) in + if cur#get = color then () else cur#set ~color + +let create_base_matrix ~cols ~rows = + let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in + for x = 0 to cols - 1 do for y = 0 to rows - 1 do + m.(y).(x) <- (x,y) + done done; + m + +let init fw = + let scorev = Textvariable.create () + and linev = Textvariable.create () + and levv = Textvariable.create () + in + let f = Frame.create fw ~borderwidth: 2 in + let c = Canvas.create f ~width: (block_size * 10) + ~height: (block_size * 20) + ~borderwidth: cell_border + ~relief: `Sunken + ~background: `Black + and r = Frame.create f + and r' = Frame.create f in + + let nl = Label.create r ~text: "Next" ~font: "variable" in + let nc = Canvas.create r ~width: (block_size * 4) + ~height: (block_size * 4) + ~borderwidth: cell_border + ~relief: `Sunken + ~background: `Black in + let scl = Label.create r ~text: "Score" ~font: "variable" in + let sc = Label.create r ~textvariable: scorev ~font: "variable" in + let lnl = Label.create r ~text: "Lines" ~font: "variable" in + let ln = Label.create r ~textvariable: linev ~font: "variable" in + let levl = Label.create r ~text: "Level" ~font: "variable" in + let lev = Label.create r ~textvariable: levv ~font: "variable" in + let newg = Button.create r ~text: "New Game" ~font: "variable" in + + pack [f]; + pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; + pack [coe nl; coe nc] ~side: `Top; + pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] + ~side: `Top; + + let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in + let cells = + Array.map cells_src ~f: + (Array.map ~f: + begin fun (x,y) -> + let t1 = + Canvas.create_rectangle c + ~x1:(-block_size - 8) ~y1:(-block_size - 8) + ~x2:(-9) ~y2:(-9) + and t2 = + Canvas.create_rectangle c + ~x1:(-block_size - 10) ~y1:(-block_size - 10) + ~x2:(-11) ~y2:(-11) + and t3 = + Canvas.create_rectangle c + ~x1:(-block_size - 12) ~y1:(-block_size - 12) + ~x2:(-13) ~y2:(-13) + in + Canvas.raise c t1; + Canvas.raise c t2; + Canvas.lower c t3; + new cell ~canvas:c ~x ~y t1 t2 t3 + end) + in + let nexts_src = create_base_matrix ~cols:4 ~rows:4 in + let nexts = + Array.map nexts_src ~f: + (Array.map ~f: + begin fun (x,y) -> + let t1 = + Canvas.create_rectangle nc + ~x1:(-block_size - 8) ~y1:(-block_size - 8) + ~x2:(-9) ~y2:(-9) + and t2 = + Canvas.create_rectangle nc + ~x1:(-block_size - 10) ~y1:(-block_size - 10) + ~x2:(-11) ~y2:(-11) + and t3 = + Canvas.create_rectangle nc + ~x1:(-block_size - 12) ~y1:(-block_size - 12) + ~x2:(-13) ~y2:(-13) + in + Canvas.raise nc t1; + Canvas.raise nc t2; + Canvas.lower nc t3; + new cell ~canvas:nc ~x ~y t1 t2 t3 + end) + in + let game_over () = () + in + (* What a mess ! *) + [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; + coe lnl; coe ln ], + newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over + + +let draw_block field ~color ~block ~x ~y = + for iy = 0 to 3 do + let base = ref 1 in + let xd = block.(iy) in + for ix = 0 to 3 do + if xd land !base <> 0 then + cell_set field ~x:(ix + x) ~y:(iy + y) ~color; + base := !base lsl 1 + done + done + +let timer_ref = (ref None : Timer.t option ref) +(* I know, this should be timer ref, but I'm not sure what should be + the initial value ... *) + +let remove_timer () = + match !timer_ref with + None -> () + | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) + +let do_after ~ms ~callback = + timer_ref := Some (Timer.add ~ms ~callback) + +let copy_block c = + { pattern= !c.pattern; + bcolor= !c.bcolor; + x= !c.x; + y= !c.y; + d= !c.d; + alive= !c.alive } + +let _ = + let top = openTk () in + let lb = Label.create top + and fw = Frame.create top + in + let set_message s = Label.configure lb ~text:s in + pack [coe lb; coe fw] ~side: `Top; + let score = ref 0 in + let line = ref 0 in + let level = ref 0 in + let time = ref 1000 in + let blocks = List.map ~f:(List.map ~f:decode_block) blocks in + let field = Array.create 26 0 in + let widgets, button, cell_field, next_field, scorev, linev, levv, game_over + = init fw in + let canvas = fst cell_field in + + let init_field () = + for i = 0 to 25 do + field.(i) <- line_empty + done; + field.(23) <- line_full; + for i = 0 to 19 do + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:i ~color:0 + done + done; + for i = 0 to 3 do + for j = 0 to 3 do + cell_set next_field ~x:j ~y:i ~color:0 + done + done + in + + let draw_falling_block fb = + draw_block cell_field ~color: fb.bcolor + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) + ~y: (fb.y - 3) + + and erase_falling_block fb = + draw_block cell_field ~color: 0 + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) + ~y: (fb.y - 3) + in + + let stone fb = + for i=0 to 3 do + let cur = field.(i + fb.y) in + field.(i + fb.y) <- + cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) + done; + for i=0 to 2 do + field.(i) <- line_empty + done + + and clear fb = + let l = ref 0 in + for i = 0 to 3 do + if i + fb.y >= 3 && i + fb.y <= 22 then + if field.(i + fb.y) = line_full then + begin + incr l; + field.(i + fb.y) <- line_empty; + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 + done + end + done; + !l + + and fall_lines () = + let eye = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) + in + try + while !eye >= 3 do + while field.(!eye) = line_empty do + decr eye; + if !eye = 2 then raise Done + done; + field.(!cur) <- field.(!eye); + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(!cur-3) + ~color:(cell_get cell_field j (!eye-3)) + done; + decr eye; + decr cur + done + with Done -> (); + for i = 3 to !cur do + field.(i) <- line_empty; + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(i-3) ~color:0 + done + done + in + + let next = ref 42 (* THE ANSWER *) + and current = + ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} + in + + let draw_next () = + draw_block next_field ~color: (!next+1) + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 + + and erase_next () = + draw_block next_field ~color: 0 + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 + in + + let set_nextblock () = + current := + { pattern= (List.nth blocks !next); + bcolor= !next+1; + x=6; y= 1; d= 0; alive= true}; + erase_next (); + next := Random.int 7; + draw_next () + in + + let death_check fb = + try + for i=0 to 3 do + let cur = field.(i + fb.y) in + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + then raise Done + done; + false + with + Done -> true + in + + let try_to_move m = + if !current.alive then + let sub m = + if death_check m then false + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + true + end + in + if sub m then true + else + begin + m.x <- m.x + 1; + if sub m then true + else + begin + m.x <- m.x - 2; + sub m + end + end + else false + in + + let image_load = + let i = Canvas.create_image canvas + ~x: (block_size * 5 + block_size / 2) + ~y: (block_size * 10 + block_size / 2) + ~anchor: `Center in + Canvas.lower canvas i; + let img = Imagephoto.create () in + fun file -> + try + Imagephoto.configure img ~file: file; + Canvas.configure_image canvas i ~image: img + with + _ -> + begin + Printf.eprintf "%s : No such image...\n" file; + flush stderr + end + in + + let add_score l = + let pline = !line in + if l <> 0 then + begin + line := !line + l; + score := !score + l * l; + set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) + end; + Textvariable.set linev (string_of_int !line); + Textvariable.set scorev (string_of_int !score); + + if !line /10 <> pline /10 then + (* update the background every 10 lines. *) + begin + let num_image = List.length backgrounds - 1 in + let n = !line/10 in + let n = if n > num_image then num_image else n in + let file = List.nth backgrounds n in + image_load file; + incr level; + Textvariable.set levv (string_of_int !level) + end + in + + let rec newblock () = + set_message "TETRIS"; + set_nextblock (); + draw_falling_block !current; + if death_check !current then + begin + !current.alive <- false; + set_message "GAME OVER"; + game_over () + end + else + begin + time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); + if !time < 60 - !level * 3 then time := 60 - !level * 3; + do_after ~ms:stop_a_bit ~callback:loop + end + + and loop () = + let m = copy_block current in + m.y <- m.y + 1; + if death_check m then + begin + !current.alive <- false; + stone !current; + do_after ~ms:stop_a_bit ~callback: + begin fun () -> + let l = clear !current in + if l > 0 then + do_after ~ms:stop_a_bit ~callback: + begin fun () -> + fall_lines (); + add_score l; + do_after ~ms:stop_a_bit ~callback:newblock + end + else + newblock () + end + end + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + do_after ~ms:!time ~callback:loop + end + in + + let bind_game w = + bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: + begin fun e -> + match e.ev_KeySymString with + | "h"|"Left" -> + let m = copy_block current in + m.x <- m.x - 1; + ignore (try_to_move m) + | "j"|"Up" -> + let m = copy_block current in + m.d <- m.d + 1; + if m.d = List.length m.pattern then m.d <- 0; + ignore (try_to_move m) + | "k"|"Down" -> + let m = copy_block current in + m.d <- m.d - 1; + if m.d < 0 then m.d <- List.length m.pattern - 1; + ignore (try_to_move m) + | "l"|"Right" -> + let m = copy_block current in + m.x <- m.x + 1; + ignore (try_to_move m) + | "m" -> + remove_timer (); + loop () + | "space" -> + if !current.alive then + begin + let m = copy_block current + and n = copy_block current in + while + m.y <- m.y + 1; + if death_check m then false + else begin n.y <- m.y; true end + do () done; + erase_falling_block !current; + draw_falling_block n; + current := n; + remove_timer (); + loop () + end + | _ -> () + end + in + + let game_init () = + (* Game Initialization *) + set_message "Initializing ..."; + remove_timer (); + image_load (List.hd backgrounds); + time := 1000; + score := 0; + line := 0; + level := 1; + add_score 0; + init_field (); + next := Random.int 7; + set_message "Welcome to TETRIS"; + set_nextblock (); + draw_falling_block !current; + do_after ~ms:!time ~callback:loop + in + (* As an applet, it was required... *) + (* List.iter f: bind_game widgets; *) + bind_game top; + Button.configure button ~command: game_init; + game_init () + +let _ = Printexc.print mainLoop () diff --git a/frx/.depend b/frx/.depend new file mode 100644 index 0000000..9b27a76 --- /dev/null +++ b/frx/.depend @@ -0,0 +1,38 @@ +frx_after.cmo: frx_after.cmi +frx_after.cmx: frx_after.cmi +frx_color.cmo: frx_color.cmi +frx_color.cmx: frx_color.cmi +frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi +frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi +frx_dialog.cmo: frx_dialog.cmi +frx_dialog.cmx: frx_dialog.cmi +frx_entry.cmo: frx_entry.cmi +frx_entry.cmx: frx_entry.cmi +frx_fillbox.cmo: frx_fillbox.cmi +frx_fillbox.cmx: frx_fillbox.cmi +frx_fit.cmo: frx_after.cmi frx_fit.cmi +frx_fit.cmx: frx_after.cmx frx_fit.cmi +frx_focus.cmo: frx_focus.cmi +frx_focus.cmx: frx_focus.cmi +frx_font.cmo: frx_misc.cmi frx_font.cmi +frx_font.cmx: frx_misc.cmx frx_font.cmi +frx_lbutton.cmo: frx_lbutton.cmi +frx_lbutton.cmx: frx_lbutton.cmi +frx_listbox.cmo: frx_listbox.cmi +frx_listbox.cmx: frx_listbox.cmi +frx_mem.cmo: frx_mem.cmi +frx_mem.cmx: frx_mem.cmi +frx_misc.cmo: frx_misc.cmi +frx_misc.cmx: frx_misc.cmi +frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi +frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi +frx_rpc.cmo: frx_rpc.cmi +frx_rpc.cmx: frx_rpc.cmi +frx_selection.cmo: frx_selection.cmi +frx_selection.cmx: frx_selection.cmi +frx_synth.cmo: frx_synth.cmi +frx_synth.cmx: frx_synth.cmi +frx_text.cmo: frx_misc.cmi frx_text.cmi +frx_text.cmx: frx_misc.cmx frx_text.cmi +frx_widget.cmo: frx_widget.cmi +frx_widget.cmx: frx_widget.cmi diff --git a/frx/Makefile b/frx/Makefile new file mode 100644 index 0000000..a6c1ad6 --- /dev/null +++ b/frx/Makefile @@ -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 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 ../camltk -I ../support + +OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ + frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ + frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ + frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo + +OBJSX = $(OBJS:.cmo=.cmx) + +all: frxlib.cma + +opt: frxlib.cmxa + +frxlib.cma: $(OBJS) + $(CAMLLIBR) -o frxlib.cma $(OBJS) + +frxlib.cmxa: $(OBJSX) + $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) + +ifeq ($(USE_FINDLIB),yes) +install: + ocamlfind install labltk -add *.cmi *.mli frxlib.cma +installopt: + ocamlfind install labltk -add frxlib.cmxa frxlib.$(A) *.cmx + cd $(INSTALLDIR); ranlib frxlib.$(A) +else +install: + cp *.cmi *.mli frxlib.cma $(INSTALLDIR) + +installopt: + cp frxlib.cmxa frxlib.$(A) *.cmx $(INSTALLDIR) + cd $(INSTALLDIR); ranlib frxlib.$(A) +endif + +clean: + rm -f *.cm* *.$(O) *.$(A) + +$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma + +$(OBJSX): ../lib/$(LIBNAME).cmxa + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .cmx + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + + +depend: + $(CAMLDEP) *.mli *.ml > .depend + +include .depend diff --git a/frx/Makefile.nt b/frx/Makefile.nt new file mode 100644 index 0000000..74203f0 --- /dev/null +++ b/frx/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/frx/README b/frx/README new file mode 100644 index 0000000..65e5dc4 --- /dev/null +++ b/frx/README @@ -0,0 +1,2 @@ +This is Francois Rouaix's widget set library, Frx. +It uses CamlTk API. diff --git a/frx/frx_after.ml b/frx/frx_after.ml new file mode 100644 index 0000000..1b7dfef --- /dev/null +++ b/frx/frx_after.ml @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Protocol +let idle f = + let id = new_function_id () in + let wrapped _ = + clear_callback id; (* do it first in case f raises exception *) + f() in + Hashtbl.add callback_naming_table id wrapped; + tkCommand [| TkToken "after"; TkToken "idle"; + TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/frx/frx_after.mli b/frx/frx_after.mli new file mode 100644 index 0000000..45e3045 --- /dev/null +++ b/frx/frx_after.mli @@ -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. *) +(* *) +(***********************************************************************) +val idle : (unit -> unit) -> unit + (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) diff --git a/frx/frx_color.ml b/frx/frx_color.ml new file mode 100644 index 0000000..e3e616a --- /dev/null +++ b/frx/frx_color.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Protocol + +module StringSet = Set.Make(struct type t = string let compare = compare end) + +(* should we keep a negative cache ? *) +let available_colors = ref (StringSet.empty) + +let check s = + if StringSet.mem s !available_colors then true + else begin + try + let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" + [Background (NamedColor s)] in + available_colors := StringSet.add s !available_colors; + destroy f; + true + with + TkError _ -> false + end diff --git a/frx/frx_color.mli b/frx/frx_color.mli new file mode 100644 index 0000000..b279165 --- /dev/null +++ b/frx/frx_color.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val check : string -> bool diff --git a/frx/frx_ctext.ml b/frx/frx_ctext.ml new file mode 100644 index 0000000..498fe8e --- /dev/null +++ b/frx/frx_ctext.ml @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* A trick by Steve Ball to do pixel scrolling on text widgets *) +(* USES frx_fit *) +open Camltk + +let create top opts navigation = + let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in + let lf = Frame.create f [] in + let rf = Frame.create f [] in + let c = Canvas.create lf [BorderWidth (Pixels 0)] + and xscroll = Scrollbar.create lf [Orient Horizontal] + and yscroll = Scrollbar.create rf [Orient Vertical] + and secret = Frame.create_named rf "secret" [] + in + let t = Text.create c (BorderWidth(Pixels 0) :: opts) in + if navigation then Frx_text.navigation_keys t; + + (* Make the text widget an embedded canvas object *) + ignore + (Canvas.create_window c (Pixels 0) (Pixels 0) + [Anchor NW; Window t; Tags [Tag "main"]]); + Canvas.focus c (Tag "main"); + (* + Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); + Height(Pixels (Winfo.reqheight t))]; + *) + Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; + (* The horizontal scrollbar is directly attached to the + * text widget, because h scrolling works properly *) + Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; + (* But vertical scroll is attached to the canvas *) + Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; + let scroll, check = Frx_fit.vert t in + Text.configure t [ + XScrollCommand (Scrollbar.set xscroll); + YScrollCommand (fun first last -> + scroll first last; + let x,y,w,h = Canvas.bbox c [Tag "main"] in + Canvas.configure c + [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) + ]; + + bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> + Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); + + pack [rf] [Side Side_Right; Fill Fill_Y]; + pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [secret] [Side Side_Bottom]; + pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; + pack [xscroll] [Side Side_Bottom; Fill Fill_X]; + pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; + f, t diff --git a/frx/frx_ctext.mli b/frx/frx_ctext.mli new file mode 100644 index 0000000..2f696ab --- /dev/null +++ b/frx/frx_ctext.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +val create : + Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget + (* [create parent opts nav_keys] creates a text widget + with "pixel scrolling". Based on a trick learned from Steve Ball. + Returns (frame widget, text widget). + *) diff --git a/frx/frx_dialog.ml b/frx/frx_dialog.ml new file mode 100644 index 0000000..096812d --- /dev/null +++ b/frx/frx_dialog.ml @@ -0,0 +1,115 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Protocol + +let rec mapi f n l = + match l with + [] -> [] + | x::l -> let v = f n x in v::(mapi f (succ n) l) + +(* Same as tk_dialog, but not sharing the tkwait variable *) +(* w IS the parent widget *) +let f w name title mesg bitmap def buttons = + let t = Toplevel.create_named w name [Class "Dialog"] in + Wm.title_set t title; + Wm.iconname_set t "Dialog"; + Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); + (* Wm.transient_set t (Winfo.toplevel w); *) + let ftop = + Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] + and fbot = + Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] + in + pack [ftop][Side Side_Top; Fill Fill_Both]; + pack [fbot][Side Side_Bottom; Fill Fill_Both]; + + let l = + Label.create_named ftop "msg" + [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in + pack [l][Side Side_Right; Expand true; Fill Fill_Both; + PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; + begin match bitmap with + Predefined "" -> () + | _ -> + let b = + Label.create_named ftop "bitmap" [Bitmap bitmap] in + pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] + end; + + let waitv = Textvariable.create_temporary t in + + let buttons = + mapi (fun i bname -> + let b = Button.create t + [Text bname; + Command (fun () -> Textvariable.set waitv (string_of_int i))] in + if i = def then begin + let f = Frame.create_named fbot "default" + [Relief Sunken; BorderWidth (Pixels 1)] in + raise_window_above b f; + pack [f][Side Side_Left; Expand true; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; + bind t [[], KeyPressDetail "Return"] + (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) + end + else + pack [b][In fbot; Side Side_Left; Expand true; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + b + ) + 0 buttons in + + Wm.withdraw t; + update_idletasks(); + let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - + (Winfo.vrootx (Winfo.parent t)) + and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - + (Winfo.vrooty (Winfo.parent t)) in + Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); + Wm.deiconify t; + + let oldfocus = try Some (Focus.get()) with _ -> None + and oldgrab = Grab.current ~displayof: t () + and grabstatus = ref None in + begin match oldgrab with + [] -> () + | x::l -> grabstatus := Some(Grab.status x) + end; + + (* avoid errors here because it makes the entire app useless *) + (try Grab.set t with TkError _ -> ()); + Tkwait.visibility t; + Focus.set (if def >= 0 then List.nth buttons def else t); + + Tkwait.variable waitv; + begin match oldfocus with + None -> () + | Some w -> try Focus.set w with _ -> () + end; + destroy t; + begin match oldgrab with + [] -> () + | x::l -> + try + match !grabstatus with + Some(GrabGlobal) -> Grab.set_global x + | _ -> Grab.set x + with TkError _ -> () + end; + + int_of_string (Textvariable.get waitv) diff --git a/frx/frx_dialog.mli b/frx/frx_dialog.mli new file mode 100644 index 0000000..fd816d3 --- /dev/null +++ b/frx/frx_dialog.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. *) +(* *) +(***********************************************************************) +open Camltk +val f : + Widget.widget -> + string -> string -> string -> Camltk.bitmap -> int -> string list -> int + (* same as Dialog.create_named, but with a local variable for + synchronisation. Makes it possible to have several dialogs + simultaneously *) diff --git a/frx/frx_entry.ml b/frx/frx_entry.ml new file mode 100644 index 0000000..0b7c339 --- /dev/null +++ b/frx/frx_entry.ml @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let version = "$Id$" + +(* + * Tk 4.0 has emacs bindings for entry widgets + *) + +let new_label_entry parent txt action = + let f = Frame.create parent [] in + let m = Label.create f [Text txt] + and e = Entry.create f [Relief Sunken; TextWidth 0] in + Camltk.bind e [[], KeyPressDetail "Return"] + (BindSet ([], fun _ -> action(Entry.get e))); + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + f,e + +let new_labelm_entry parent txt memo = + let f = Frame.create parent [] in + let m = Label.create f [Text txt] + and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + f,e diff --git a/frx/frx_entry.mli b/frx/frx_entry.mli new file mode 100644 index 0000000..0b09f16 --- /dev/null +++ b/frx/frx_entry.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +val new_label_entry : + Widget.widget -> + string -> (string -> unit) -> Widget.widget * Widget.widget + (* [new_label_entry parent label action] + creates a "labelled" entry widget where [action] will be invoked + when the user types Return in the widget. + Returns (frame widget, entry widget) + *) +val new_labelm_entry : + Widget.widget -> + string -> Textvariable.textVariable -> Widget.widget * Widget.widget + (* [new_labelm_entry parent label variable] + creates a "labelled" entry widget whose contents is [variable]. + Returns (frame widget, entry widget) + *) diff --git a/frx/frx_fileinput.ml b/frx/frx_fileinput.ml new file mode 100644 index 0000000..dfba7a0 --- /dev/null +++ b/frx/frx_fileinput.ml @@ -0,0 +1,39 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let version = "$Id$" + +(* + * Simple spooling for fileinput callbacks + *) + +let waiting_list = Queue. new() +and waiting = ref 0 +and max_open = ref 10 +and cur_open = ref 0 + +let add fd f = + if !cur_open < !max_open then begin + incr cur_open; + add_fileinput fd f + end + else begin + incr waiting; + Queue.add (fd,f) waiting_list + end + +let remove fd = diff --git a/frx/frx_fillbox.ml b/frx/frx_fillbox.ml new file mode 100644 index 0000000..143bea4 --- /dev/null +++ b/frx/frx_fillbox.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +(* + * Progress indicators + *) +let okcolor = NamedColor "#3cb371" +and kocolor = NamedColor "#dc5c5c" + + +let new_vertical parent w h = + let c = Canvas.create_named parent "fillbox" + [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); + Relief Sunken] + in + let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) + [FillColor okcolor; Outline okcolor] + in + c, (function + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels 0] + | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let hf = percent*h/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels hf]) + +let new_horizontal parent w h = + let c = Canvas.create_named parent "fillbox" + [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); + Relief Sunken] + in + let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) + [FillColor okcolor; Outline okcolor] + in + c, (function + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels 0; Pixels h] + | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let wf = percent*w/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels wf; Pixels h]) diff --git a/frx/frx_fillbox.mli b/frx/frx_fillbox.mli new file mode 100644 index 0000000..9cfc9e7 --- /dev/null +++ b/frx/frx_fillbox.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +val new_vertical : + Widget.widget -> int -> int -> Widget.widget * (int -> unit) + (* [new_vertical parent width height] + creates a vertical fillbox of [width] and [height]. + Returns a frame widget and a function to set the current value of + the fillbox. The value can be + n < 0 : the fillbox changes color (reddish) + 0 <= n <= 100: the fillbox fills up to n percent + 100 <= n : the fillbox fills up to 95% + *) + +val new_horizontal : + Widget.widget -> int -> int -> Widget.widget * (int -> unit) + (* save as above, except the widget is horizontal *) diff --git a/frx/frx_fit.ml b/frx/frx_fit.ml new file mode 100644 index 0000000..bcfd457 --- /dev/null +++ b/frx/frx_fit.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let debug = ref false + +let vert wid = + let newsize = ref 0 + and pending_resize = ref false + and last_last = ref 0.0 in + let rec resize () = + pending_resize := false; + if !debug then + (Printf.eprintf "%s Resize %d\n" + (Widget.name wid) !newsize; flush stderr); + Text.configure wid [TextHeight !newsize]; + () + and check () = + let first, last = Text.yview_get wid in + check1 first last + + and check1 first last = + let curheight = int_of_string (cget wid CHeight) in + if !debug then begin + Printf.eprintf "%s C %d %f %f\n" + (Widget.name wid) curheight first last; + flush stderr + end; + if first = 0.0 && last = 1.0 then () + (* Don't attempt anything if widget is not visible *) + else if not (Winfo.viewable wid) then begin + if !debug then + (Printf.eprintf "%s C notviewable\n" (Widget.name wid); + flush stderr); + (* Try again later *) + bind wid [[], Expose] (BindSet ([], fun _ -> + bind wid [[], Expose] BindRemove; + check())) + end + else begin + let delta = + if last = 0.0 then 1 + else if last = !last_last then + (* it didn't change since our last resize ! *) + 1 + else begin + last_last := last; + (* never to more than double *) + let visible = max 0.5 (last -. first) in + max 1 (truncate (float curheight *. (1. -. visible))) + end in + newsize := max (curheight + delta) !newsize; + if !debug then + (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; + flush stderr); + if !pending_resize then () + else begin + pending_resize := true; + Timer.set 300 (fun () -> Frx_after.idle resize) + end + end + + and scroll first last = + if !debug then + (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; + flush stderr); + if first = 0.0 && last = 1.0 then () + else check1 first last + in + scroll, check diff --git a/frx/frx_fit.mli b/frx/frx_fit.mli new file mode 100644 index 0000000..e614964 --- /dev/null +++ b/frx/frx_fit.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Widget + +val debug: bool ref +val vert: widget -> (float -> float -> unit) * (unit -> unit) + +(* [vert widget] + can be applied to a text widget so that it expands to show its full + contents. Returns [scroll] and [check]. [scroll] must be used as + the YScrollCommand of the widget. [check] can be called when some + modification occurs in the content of the widget (such as a size change + in some embedded windows. + This feature is a terrible hack and should be used with extreme caution. + *) diff --git a/frx/frx_focus.ml b/frx/frx_focus.ml new file mode 100644 index 0000000..29eba57 --- /dev/null +++ b/frx/frx_focus.ml @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +(* Temporary focus *) + +(* ? use bind tag ? how about the global reference then *) +let auto w = + let old_focus = ref w in + bind w [[],Enter] + (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); + bind w [[],Leave] + (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/frx/frx_focus.mli b/frx/frx_focus.mli new file mode 100644 index 0000000..dcb9317 --- /dev/null +++ b/frx/frx_focus.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +val auto : Widget.widget -> unit + (* *) diff --git a/frx/frx_font.ml b/frx/frx_font.ml new file mode 100644 index 0000000..4acb599 --- /dev/null +++ b/frx/frx_font.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Widget + +let version = "$Id$" + +(* + * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. + * Possibly bogus because some families use "i" for italic where others + * use "o". + * wght: bold, medium + * slant: i, o, r + * pxlsz: 8, 10, ... +*) +module StringSet = Set.Make(struct type t = string let compare = compare end) + +let available_fonts = ref (StringSet.empty) + +let get_canvas = + Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) + + +let find fmly wght slant pxlsz = + let fontspec = + "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in + if StringSet.mem fontspec !available_fonts then fontspec + else + let c = get_canvas() in + try + let tag = Canvas.create_text c (Pixels 0) (Pixels 0) + [Text "foo"; Font fontspec] in + Canvas.delete c [tag]; + available_fonts := StringSet.add fontspec !available_fonts; + fontspec + with + _ -> raise (Invalid_argument fontspec) diff --git a/frx/frx_font.mli b/frx/frx_font.mli new file mode 100644 index 0000000..4ed235f --- /dev/null +++ b/frx/frx_font.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val find : string -> string -> string -> int -> string + (* [find family weight slant pxlsz] returns the X11 full name of + the font required font, if available. + Raises Invalid_argument fullname otherwise. + *) diff --git a/frx/frx_group.ml b/frx/frx_group.ml new file mode 100644 index 0000000..1adc2d8 --- /dev/null +++ b/frx/frx_group.ml @@ -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. *) +(* *) +(***********************************************************************) +open Camltk + +let vgroup top l = + let f = Frame.create top [] in + Pack.forget l; + Pack.configure l [In f]; + f diff --git a/frx/frx_lbutton.ml b/frx/frx_lbutton.ml new file mode 100644 index 0000000..82ea8a8 --- /dev/null +++ b/frx/frx_lbutton.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +open Widget + + +let version = "$Id$" + +(* + * Simulate a button with a bitmap AND a label + *) + +let rec sort_options but lab com = function + [] -> but,lab,com + |(Command f as o)::l -> sort_options (o::but) lab com l + |(Bitmap b as o)::l -> sort_options (o::but) lab com l + |(Text t as o)::l -> sort_options but (o::lab) com l + |o::l -> sort_options but lab (o::com) l + +let create parent options = + let but,lab,com = sort_options [] [] [] options in + let f = Frame.create parent com in + let b = Button.create f (but@com) + and l = Label.create f (lab@com) in + pack [b;l][]; + bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); + f + +let configure f options = + let but,lab,com = sort_options [] [] [] options in + match Pack.slaves f with + [b;l] -> + Frame.configure f com; + Button.configure b (but@com); + Label.configure l (lab@com) + | _ -> raise (Invalid_argument "lbutton configure") diff --git a/frx/frx_lbutton.mli b/frx/frx_lbutton.mli new file mode 100644 index 0000000..5522e5c --- /dev/null +++ b/frx/frx_lbutton.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Widget +open Camltk + + +val version : string + +val create : Widget -> option list -> Widget +and configure : Widget -> option list -> unit diff --git a/frx/frx_listbox.ml b/frx/frx_listbox.ml new file mode 100644 index 0000000..6d04262 --- /dev/null +++ b/frx/frx_listbox.ml @@ -0,0 +1,92 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let version = "$Id$" + +(* + * Link a scrollbar and a listbox + *) +let scroll_link sb lb = + Listbox.configure lb + [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb + [ScrollCommand (Listbox.yview lb)] + +(* + * Completion for listboxes, Macintosh style. + * As long as you type fast enough, the listbox is repositioned to the + * first entry "greater" than the typed prefix. + * assumes: + * sorted list (otherwise it's stupid) + * fixed size, because we don't recompute size at each callback invocation + *) + +let add_completion lb action = + let prefx = ref "" (* current match prefix *) + and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) + and current = ref 0 (* current position *) + and lastevent = ref 0 in + + let rec move_forward () = + if Listbox.get lb (Number !current) < !prefx then + if !current < maxi then begin incr current; move_forward() end + + and recenter () = + let element = Number !current in + (* Clean the selection *) + Listbox.selection_clear lb (Number 0) End; + (* Set it to our unique element *) + Listbox.selection_set lb element element; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + Listbox.activate lb element; + Listbox.selection_anchor lb element; + Listbox.see lb element in + + let complete time s = + if time - !lastevent < 500 then (* sorry, hard coded limit *) + prefx := !prefx ^ s + else begin (* reset *) + current := 0; + prefx := s + end; + lastevent := time; + move_forward(); + recenter() in + + + bind lb [[], KeyPress] + (BindSet([Ev_Char; Ev_Time], + (function ev -> + (* consider only keys producing characters. The callback is called + * even if you press Shift. + *) + if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); + (* Key specific bindings override KeyPress *) + bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); + (* Finally, we have to set focus, otherwise events dont get through *) + Focus.set lb; + recenter() (* so that first item is selected *) + +let new_scrollable_listbox top options = + let f = Frame.create top [] in + let lb = Listbox.create f options + and sb = Scrollbar.create f [] in + scroll_link sb lb; + pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [sb] [Side Side_Left; Fill Fill_Y]; + f, lb diff --git a/frx/frx_listbox.mli b/frx/frx_listbox.mli new file mode 100644 index 0000000..54e7ec6 --- /dev/null +++ b/frx/frx_listbox.mli @@ -0,0 +1,32 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +val scroll_link : Widget.widget -> Widget.widget -> unit + (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] + as expected. + *) + +val add_completion : Widget.widget -> (eventInfo -> unit) -> unit + (* [add_completion listbox action] adds Macintosh like electric navigation + in the listbox when characters are typed in. + [action] is invoked if Return is pressed + *) + +val new_scrollable_listbox : + Widget.widget -> options list -> Widget.widget * Widget.widget + (* [new_scrollable_listbox parent options] makes a scrollable listbox and + returns (frame, listbox) + *) diff --git a/frx/frx_mem.ml b/frx/frx_mem.ml new file mode 100644 index 0000000..6df0da7 --- /dev/null +++ b/frx/frx_mem.ml @@ -0,0 +1,89 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Memory gauge *) +open Camltk +open Gc + +let inited = ref None +let w = ref 300 +let delay = ref 5 (* in seconds *) +let wordsize = (* officially approved *) + if 1 lsl 31 = 0 then 4 else 8 + + +let init () = + let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in + let name = Camltk.appname_get () in + Wm.title_set top (name ^ " Memory Gauge"); + Wm.withdraw top; + inited := Some top; + (* this should be executed before the internal "all" binding *) + bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); + let fminors = Frame.create top [] in + let lminors = Label.create fminors [Text "Minor collections"] + and vminors = Label.create fminors [] in + pack [lminors][Side Side_Left]; + pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; + let fmajors = Frame.create top [] in + let lmajors = Label.create fmajors [Text "Major collections"] + and vmajors = Label.create fmajors [] in + pack [lmajors][Side Side_Left]; + pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; + let fcompacts = Frame.create top [] in + let lcompacts = Label.create fcompacts [Text "Compactions"] + and vcompacts = Label.create fcompacts [] in + pack [lcompacts][Side Side_Left]; + pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; + let fsize = Frame.create top [] in + let lsize = Label.create fsize [Text "Heap size (bytes)"] + and vsize = Label.create fsize [] in + pack [lsize][Side Side_Left]; + pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; + let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in + let flive = Frame.create fheap [Background Red] + and ffree = Frame.create fheap [Background Green] + and fdead = Frame.create fheap [Background Black] in + pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; + + let display () = + let st = Gc.stat() in + Label.configure vminors [Text (string_of_int st.minor_collections)]; + Label.configure vmajors [Text (string_of_int st.major_collections)]; + Label.configure vcompacts [Text (string_of_int st.compactions)]; + Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; + let liver = (float st.live_words) /. (float st.heap_words) + and freer = (float st.free_words) /. (float st.heap_words) in + Place.configure flive [X (Pixels 0); Y (Pixels 0); + RelWidth liver; RelHeight 1.0]; + Place.configure ffree [RelX liver; Y (Pixels 0); + RelWidth freer; RelHeight 1.0]; + Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); + RelWidth (1.0 -. freer -. liver); RelHeight 1.0] + + in + let rec tim () = + if Winfo.exists top then begin + display(); + Timer.set (!delay * 1000) tim + end + in + tim() + + +let rec f () = + match !inited with + Some w -> Wm.deiconify w + | None -> init (); f() diff --git a/frx/frx_mem.mli b/frx/frx_mem.mli new file mode 100644 index 0000000..190297b --- /dev/null +++ b/frx/frx_mem.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. *) +(* *) +(***********************************************************************) +(* A Garbage Collector Gauge for OCaml *) + +val init : unit -> unit + (* [init ()] creates the gauge and its updater, but keeps it iconified *) + +val f : unit -> unit + (* [f ()] makes the gauge visible if it has not been destroyed *) diff --git a/frx/frx_misc.ml b/frx/frx_misc.ml new file mode 100644 index 0000000..e45c5f0 --- /dev/null +++ b/frx/frx_misc.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Delayed global, a.k.a cache&carry *) +let autodef f = + let v = ref None in + (function () -> + match !v with + None -> + let x = f() in + v := Some x; + x + | Some x -> x) + +open Camltk + +(* allows Data in options *) +let create_photo options = + let hasopt = ref None in + (* Check options *) + List.iter (function + Data s -> + begin match !hasopt with + None -> hasopt := Some (Data s) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end + | File f -> + begin match !hasopt with + None -> hasopt := Some (File f) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end + | o -> ()) + options; + match !hasopt with + None -> raise (Protocol.TkError "no data source in options") + | Some (Data s) -> + begin + let tmpfile = Filename.temp_file "img" "" in + let oc = open_out_bin tmpfile in + output_string oc s; + close_out oc; + let newopts = + List.map (function + | Data s -> File tmpfile + | o -> o) + options in + try + let i = Imagephoto.create newopts in + (try Sys.remove tmpfile with Sys_error _ -> ()); + i + with + e -> + (try Sys.remove tmpfile with Sys_error _ -> ()); + raise e + end + | Some (File s) -> Imagephoto.create options + | _ -> assert false diff --git a/frx/frx_misc.mli b/frx/frx_misc.mli new file mode 100644 index 0000000..cd3d589 --- /dev/null +++ b/frx/frx_misc.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +val autodef : (unit -> 'a) -> (unit -> 'a) + (* [autodef make] is a pleasant wrapper around 'a option ref *) + +val create_photo : Camltk.options list -> Camltk.imagePhoto + (* [create_photo options] allows Data in options (by saving to tmp file) *) diff --git a/frx/frx_req.ml b/frx/frx_req.ml new file mode 100644 index 0000000..41590c1 --- /dev/null +++ b/frx/frx_req.ml @@ -0,0 +1,198 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +(* + * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple + * jargon). +*) + +let version = "$Id$" + +(* + * Simple requester + * an entry field, unrestricted, with emacs-like bindings + * Note: grabs focus, thus always unique at one given moment, and we + * shouldn't have to worry about toplevel widget name. + * We add a title widget in case the window manager does not decorate + * toplevel windows. +*) + +let open_simple title action notaction memory = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] in + let len = max 40 (String.length (Textvariable.get memory)) in + let e = + Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in + + let activate _ = + let v = Entry.get e in + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) + action v in + + bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = Button.create f + [Text "Cancel"; + Command (fun () -> notaction(); Grab.release t; destroy t)] in + + bind e [[], KeyPressDetail "Escape"] + (BindSet ([], (fun _ -> Button.invoke bcancel))); + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;e] [Fill Fill_X]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Focus.set e; + Tkwait.visibility t; + Grab.set t + +(* A synchronous version *) +let open_simple_synchronous title memory = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] in + let len = max 40 (String.length (Textvariable.get memory)) in + let e = + Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in + + let waiting = Textvariable.create_temporary t in + + let activate _ = + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) + Textvariable.set waiting "1" in + + bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = + Button.create f + [Text "Cancel"; + Command (fun () -> + Grab.release t; destroy t; Textvariable.set waiting "0")] in + + bind e [[], KeyPressDetail "Escape"] + (BindSet ([], (fun _ -> Button.invoke bcancel))); + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;e] [Fill Fill_X]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Focus.set e; + Tkwait.visibility t; + Grab.set t; + Tkwait.variable waiting; + begin match Textvariable.get waiting with + "1" -> true + | _ -> false + end + +(* + * Simple list requester + * Same remarks as in open_simple. + * focus seems to be in the listbox automatically + *) +let open_list title elements action notaction = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Wm.title_set t title; + + let tit = Label.create t [Text title] in + let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in + let lb = Listbox.create fls [SelectMode Extended] in + let sb = Scrollbar.create fls [] in + Frx_listbox.scroll_link sb lb; + Listbox.insert lb End elements; + + (* activation: we have to break() because we destroy the requester *) + let activate _ = + let l = List.map (Listbox.get lb) (Listbox.curselection lb) in + Grab.release t; + destroy t; + List.iter action l; + break() in + + + bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); + + Frx_listbox.add_completion lb activate; + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = Button.create f + [Text "Cancel"; + Command (fun () -> notaction(); Grab.release t; destroy t)] in + + pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; + pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [sb] [Side Side_Right; Fill Fill_Y]; + pack [tit] [Fill Fill_X]; + pack [fls] [Fill Fill_Both; Expand true]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Tkwait.visibility t; + Grab.set t + + +(* Synchronous *) +let open_passwd title = + let username = ref "" + and password = ref "" + and cancelled = ref false in + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] + and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) + and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) + in + let fb = Frame.create t [] in + let bok = Button.create fb + [Text "Ok"; Command (fun _ -> + username := Entry.get eu; + password := Entry.get ep; + Grab.release t; (* because of wm *) + destroy t)] (* will return from tkwait *) + and bcancel = Button.create fb + [Text "Cancel"; Command (fun _ -> + cancelled := true; + Grab.release t; (* because of wm *) + destroy t)] (* will return from tkwait *) + in + Entry.configure ep [Show '*']; + bind eu [[], KeyPressDetail "Return"] + (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); + bind ep [[], KeyPressDetail "Return"] + (BindSetBreakable ([], (fun _ -> Button.flash bok; + Button.invoke bok; + break()))); + + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;fu;fp;fb] [Fill Fill_X]; + Tkwait.visibility t; + Focus.set eu; + Grab.set t; + Tkwait.window t; + if !cancelled then failwith "cancelled" + else (!username, !password) diff --git a/frx/frx_req.mli b/frx/frx_req.mli new file mode 100644 index 0000000..62985b9 --- /dev/null +++ b/frx/frx_req.mli @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Various dialog boxes *) +val open_simple : + string -> + (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit + (* [open_simple title action cancelled memory] + A dialog with a message and an entry field (with memory between + invocations). Either [action] or [cancelled] is called when the user + answers to the dialog (with Ok or Cancel) + *) + +val open_simple_synchronous : string -> Textvariable.textVariable -> bool + (* [open_simple_synchronous title memory] + A synchronous dialog with a message and an entry field (with + memory between invocations). Returns true if the user clicks Ok + or false if the user clicks Cancel. + *) +val open_list : + string -> string list -> (string -> unit) -> (unit -> unit) -> unit + (* [open_list title elements action cancelled] + A dialog for selecting from a list of elements. [action] is called + on each selected element, or [cancelled] is called if the user clicks + Cancel. + *) + +val open_passwd : string -> string * string + (* [open_passwd title] pops up a username/password dialog and returns + (username, password). + *) diff --git a/frx/frx_rpc.ml b/frx/frx_rpc.ml new file mode 100644 index 0000000..5de7a15 --- /dev/null +++ b/frx/frx_rpc.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of RPC *) +open Camltk +open Protocol + +(* A RPC is just a callback with a particular name, plus a Tcl procedure *) +let register name f = + let id = new_function_id() in + Hashtbl.add callback_naming_table id f; + (* For rpc_info *) + Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) + (string_of_cbid id); + tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; + TkToken ("camlcb "^(string_of_cbid id)^" $args") |] + +(* RPC *) +let invoke interp f args = + tkEval [| + TkToken "send"; + TkToken interp; + TkToken f; + TkTokenList (List.map (fun s -> TkToken s) args) + |] + +let async_invoke interp f args = + tkCommand [| + TkToken "send"; + TkToken "-async"; + TkToken interp; + TkToken f; + TkTokenList (List.map (fun s -> TkToken s) args) + |] + +let rpc_info interp = + tkEval [| + TkToken "send"; + TkToken interp; + TkToken "array"; + TkToken "names"; + TkToken "camltkrpc" + |] diff --git a/frx/frx_rpc.mli b/frx/frx_rpc.mli new file mode 100644 index 0000000..2081173 --- /dev/null +++ b/frx/frx_rpc.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of RPC *) + +val register : string -> (string list -> unit) -> unit + (* [register external_name f] *) +val invoke : string -> string -> string list -> string + (* [invoke interp name args] *) +val async_invoke : string -> string -> string list -> unit + (* [async_invoke interp name args] *) +val rpc_info : string -> string + (* [rpc_info interp] *) diff --git a/frx/frx_selection.ml b/frx/frx_selection.ml new file mode 100644 index 0000000..ad037ce --- /dev/null +++ b/frx/frx_selection.ml @@ -0,0 +1,45 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* A selection handler *) +open Widget +open Protocol +open Camltk + +let frame = ref None +let selection = ref "" + +let read ofs n = + let res = + if ofs < 0 then "" + else if ofs + n > String.length !selection + then String.sub !selection ofs (String.length !selection - ofs) + else String.sub !selection ofs n in + tkreturn res + +(* As long as we don't loose the selection, we keep the widget *) +(* Calling this function means that we own the selection *) +(* When we loose the selection, both cb are destroyed *) +let own () = + match !frame with + None -> + let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in + let lost () = selection := ""; destroy f; frame := None in + Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; + Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; + frame := Some f + | Some f -> () + +let set s = own(); selection := s diff --git a/frx/frx_selection.mli b/frx/frx_selection.mli new file mode 100644 index 0000000..b152658 --- /dev/null +++ b/frx/frx_selection.mli @@ -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. *) +(* *) +(***********************************************************************) +val set : string -> unit + (* [set s] sets the X PRIMARY selection to [s] *) diff --git a/frx/frx_synth.ml b/frx/frx_synth.ml new file mode 100644 index 0000000..21bd7fa --- /dev/null +++ b/frx/frx_synth.ml @@ -0,0 +1,88 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of synthetic events *) +open Camltk +open Widget +open Protocol + +(* To each event is associated a table of (widget, callback) *) +let events = Hashtbl.create 37 + +(* Notes: + * "cascading" events (on the same event) are not supported + * Only one binding active at a time for each event on each widget. + *) + +(* Get the callback table associated with . Initializes if required *) +let get_event name = + try Hashtbl.find events name + with + Not_found -> + let h = Hashtbl.create 37 in + Hashtbl.add events name h; + (* Initialize the callback invocation mechanism, based on + variable trace + *) + let var = "camltk_events(" ^ name ^")" in + let tkvar = Textvariable.coerce var in + let rec set () = + Textvariable.handle tkvar + (fun () -> + begin match Textvariable.get tkvar with + "all" -> (* Invoke all callbacks *) + Hashtbl.iter + (fun p f -> + try + f (cTKtoCAMLwidget p) + with _ -> ()) + h + | p -> (* Invoke callback for p *) + try + let w = cTKtoCAMLwidget p + and f = Hashtbl.find h p in + f w + with + _ -> () + end; + set ()(* reactivate the callback *) + ) in + set(); + h + +(* Remove binding for event on widget *) +let remove w name = + Hashtbl.remove (get_event name) (Widget.name w) + +(* Adds as callback for widget on event *) +let bind w name f = + remove w name; + Hashtbl.add (get_event name) (Widget.name w) f + +(* Sends event to all widgets *) +let broadcast name = + Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" + +(* Sends event to widget *) +let send name w = + Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) + (Widget.name w) + +(* Remove all callbacks associated to widget *) +let remove_callbacks w = + Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events + +let _ = + add_destroy_hook remove_callbacks diff --git a/frx/frx_synth.mli b/frx/frx_synth.mli new file mode 100644 index 0000000..e5a96aa --- /dev/null +++ b/frx/frx_synth.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Synthetic events *) +open Camltk +open Widget + + +val send : string -> widget -> unit + (* [send event_name widget] *) + +val broadcast : string -> unit + (* [broadcase event_name] *) + +val bind : widget -> string -> (widget -> unit) -> unit + (* [bind event_name callback] *) + +val remove : widget -> string -> unit + (* [remove widget event_name] *) diff --git a/frx/frx_text.ml b/frx/frx_text.ml new file mode 100644 index 0000000..a9ca17a --- /dev/null +++ b/frx/frx_text.ml @@ -0,0 +1,228 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +let version = "$Id$" + +(* + * convert an integer to an absolute index +*) +let abs_index n = + TextIndex (LineChar(0,0), [CharOffset n]) + +let insertMark = + TextIndex(Mark "insert", []) + +let currentMark = + TextIndex(Mark "current", []) + +let textEnd = + TextIndex(End, []) + +let textBegin = + TextIndex (LineChar(0,0), []) + +(* + * Link a scrollbar and a text widget +*) +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + + +(* + * Tk 4.0 has navigation in Text widgets, sometimes using scrolling + * sometimes using the insertion mark. It is a pain to add more + * compatible bindings. We do our own. + *) +let page_up tx = Text.yview tx (ScrollPage (-1)) +and page_down tx = Text.yview tx (ScrollPage 1) +and line_up tx = Text.yview tx (ScrollUnit (-1)) +and line_down tx = Text.yview tx (ScrollUnit 1) +and top tx = Text.yview_index tx textBegin +and bottom tx = Text.yview_index tx textEnd + +let navigation_keys tx = + let tags = bindtags_get tx in + match tags with + (WidgetBindings t)::l when t = tx -> + bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) + | _ -> () + +let new_scrollable_text top options navigation = + let f = Frame.create top [] in + let tx = Text.create f options + and sb = Scrollbar.create f [] in + scroll_link sb tx; + (* IN THIS ORDER -- RESIZING *) + pack [sb] [Side Side_Right; Fill Fill_Y]; + pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; + if navigation then navigation_keys tx; + f, tx + +(* + * Searching + *) +let patternv = Frx_misc.autodef Textvariable.create +and casev = Frx_misc.autodef Textvariable.create + +let topsearch t = + (* The user interface *) + let top = Toplevel.create t [Class "TextSearch"] in + Wm.title_set top "Text search"; + let f = Frame.create_named top "fpattern" [] in + let m = Label.create_named f "search" [Text "Search pattern"] + and e = Entry.create_named f "pattern" + [Relief Sunken; TextVariable (patternv()) ] in + let hgroup = Frame.create top [] + and bgroup = Frame.create top [] in + let fdir = Frame.create hgroup [] + and fmisc = Frame.create hgroup [] in + let direction = Textvariable.create_temporary fdir + and exactv = Textvariable.create_temporary fdir + in + let forw = Radiobutton.create_named fdir "forward" + [Text "Forward"; Variable direction; Value "f"] + and backw = Radiobutton.create_named fdir "backward" + [Text "Backward"; Variable direction; Value "b"] + and exact = Checkbutton.create_named fmisc "exact" + [Text "Exact match"; Variable exactv] + and case = Checkbutton.create_named fmisc "case" + [Text "Fold Case"; Variable (casev())] + and searchb = Button.create_named bgroup "search" [Text "Search"] + and contb = Button.create_named bgroup "continue" [Text "Continue"] + and dismissb = Button.create_named bgroup "dismiss" + [Text "Dismiss"; + Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in + + Radiobutton.invoke forw; + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + pack [forw; backw] [Anchor W]; + pack [exact; case] [Anchor W]; + pack [fdir; fmisc] [Side Side_Left; Anchor Center]; + pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; + pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; + + let current_index = ref textBegin in + + let search cont = fun () -> + let opts = ref [] in + if Textvariable.get direction = "f" then + opts := Forwards :: !opts + else opts := Backwards :: !opts ; + if Textvariable.get exactv = "1" then + opts := Exact :: !opts; + if Textvariable.get (casev()) = "1" then + opts := Nocase :: !opts; + try + let forward = Textvariable.get direction = "f" in + let i = Text.search t !opts (Entry.get e) + (if cont then !current_index + else if forward then textBegin + else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) + (if forward then textEnd + else textBegin) in + let found = TextIndex (i, []) in + current_index := + TextIndex(i, [CharOffset (if forward then 1 else (-1))]); + Text.tag_delete t ["search"]; + Text.tag_add t "search" found (TextIndex (i, [WordEnd])); + Text.tag_configure t "search" + [Relief Raised; BorderWidth (Pixels 1); + Background Red]; + Text.see t found + with + Invalid_argument _ -> Bell.ring() in + + bind e [[], KeyPressDetail "Return"] + (BindSet ([], fun _ -> search false ())); + Button.configure searchb [Command (search false)]; + Button.configure contb [Command (search true)]; + Tkwait.visibility top; + Focus.set e + +let addsearch tx = + let tags = bindtags_get tx in + match tags with + (WidgetBindings t)::l when t = tx -> + bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) + | _ -> () + +(* We use Mod1 instead of Meta or Alt *) +let init () = + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "BackSpace"]; + [[], KeyPressDetail "Delete"]; + [[], KeyPressDetail "Prior"]; + [[], KeyPressDetail "b"]; + [[Mod1], KeyPressDetail "v"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "space"]; + [[], KeyPressDetail "Next"]; + [[Control], KeyPressDetail "v"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Up"]; + [[Mod1], KeyPressDetail "z"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Down"]; + [[Control], KeyPressDetail "z"] + ]; + + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> top ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Home"]; + [[Mod1], KeyPressDetail "less"] + ]; + + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> bottom ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "End"]; + [[Mod1], KeyPressDetail "greater"] + ]; + + List.iter (function ev -> + tag_bind "SEARCH" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> topsearch ei.ev_Widget; break())))) + [ + [[Control], KeyPressDetail "s"] + ] diff --git a/frx/frx_text.mli b/frx/frx_text.mli new file mode 100644 index 0000000..97783fa --- /dev/null +++ b/frx/frx_text.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk + +val abs_index : int -> textIndex + (* [abs_index offs] returns the corresponding TextIndex *) + +val insertMark : textIndex +val currentMark : textIndex +val textEnd : textIndex +val textBegin : textIndex + (* shortcuts for various positions in a text widget *) + +val scroll_link : Widget.widget -> Widget.widget -> unit + (* [scroll_link scrollbar text] links a scrollbar and a text widget + as expected + *) + +val new_scrollable_text : + Widget.widget -> options list -> bool -> Widget.widget * Widget.widget + (* [new_scrollable_text parent opts nav_keys] makes a scrollable text + widget with optional navigation keys. Returns frame and text widget. + *) +val addsearch : Widget.widget -> unit + (* [addsearch textw] adds a search dialog bound on [Control-s] + on the text widget + *) + +val navigation_keys : Widget.widget -> unit + (* [navigation_keys textw] adds common navigations functions to [textw] *) + +val init : unit -> unit + (* [init ()] must be called before any of the above features is used *) diff --git a/frx/frx_toplevel.mli b/frx/frx_toplevel.mli new file mode 100644 index 0000000..628cde2 --- /dev/null +++ b/frx/frx_toplevel.mli @@ -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. *) +(* *) +(***********************************************************************) +open Widget +val make_visible : Widget -> unit diff --git a/frx/frx_widget.ml b/frx/frx_widget.ml new file mode 100644 index 0000000..9045134 --- /dev/null +++ b/frx/frx_widget.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Widget + +let version = "$Id$" +(* Make a window (toplevel widget) resizeable *) +let resizeable t = + update_idletasks(); (* wait until layout is computed *) + Wm.minsize_set t (Winfo.width t) (Winfo.height t) diff --git a/frx/frx_widget.mli b/frx/frx_widget.mli new file mode 100644 index 0000000..f856664 --- /dev/null +++ b/frx/frx_widget.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Camltk +open Widget +val resizeable : widget -> unit diff --git a/frx/frxlib.mllib b/frx/frxlib.mllib new file mode 100644 index 0000000..3641ae5 --- /dev/null +++ b/frx/frxlib.mllib @@ -0,0 +1,4 @@ +Frx_misc Frx_widget Frx_font Frx_entry Frx_text +Frx_listbox Frx_req Frx_fillbox Frx_focus +Frx_dialog Frx_mem Frx_rpc Frx_synth Frx_selection +Frx_after Frx_fit Frx_ctext Frx_color diff --git a/jpf/Makefile b/jpf/Makefile new file mode 100644 index 0000000..4ba354d --- /dev/null +++ b/jpf/Makefile @@ -0,0 +1,104 @@ +####################################################################### +# # +# 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 + +COMPFLAGS=-I ../labltk -I ../support + +OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo + +OBJSX = $(OBJS:.cmo=.cmx) + +all: jpflib.cma + +opt: jpflib.cmxa + +test: balloontest + +testopt: balloontest.opt + +jpflib.cma: $(OBJS) + $(CAMLLIBR) -o jpflib.cma $(OBJS) + +jpflib.cmxa: $(OBJSX) + $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) + +ifeq ($(USE_FINDLIB),yes) +install: + ocamlfind install labltk -add \ + $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma +installopt: + ocamlfind install labltk -add \ + jpflib.cmxa jpflib.$(A) $(OBJS:.cmo=.cmx) + cd $(INSTALLDIR); $(RANLIB) jpflib.$(A) +else +install: + cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) + +installopt: + cp jpflib.cmxa jpflib.$(A) $(OBJS:.cmo=.cmx) $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) jpflib.$(A) +endif + +clean: + rm -f *.cm* *.$(O) *.$(A) *~ *test + +$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma + +$(OBJSX): ../lib/$(LIBNAME).cmxa + +### Tests + +balloontest: balloontest.cmo + $(CAMLC) -o balloontest -I ../support -I ../lib \ + -custom $(LIBNAME).cma jpflib.cma balloontest.cmo + +balloontest.opt: balloontest.cmx + $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \ + $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx + +balloontest.cmo : balloon.cmo jpflib.cma + +balloontest.cmx : balloon.cmx jpflib.cmxa + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +depend: + mv Makefile Makefile.bak + (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ + $(CAMLDEP) *.mli *.ml) > Makefile + + +### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED +### DO NOT DELETE THIS LINE +balloon.cmo: balloon.cmi +balloon.cmx: balloon.cmi +fileselect.cmo: fileselect.cmi +fileselect.cmx: fileselect.cmi +jpf_font.cmo: shell.cmi jpf_font.cmi +jpf_font.cmx: shell.cmx jpf_font.cmi +shell.cmo: shell.cmi +shell.cmx: shell.cmi diff --git a/jpf/Makefile.nt b/jpf/Makefile.nt new file mode 100644 index 0000000..74203f0 --- /dev/null +++ b/jpf/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/jpf/README b/jpf/README new file mode 100644 index 0000000..275c2d7 --- /dev/null +++ b/jpf/README @@ -0,0 +1,2 @@ +This is Jun Furuse's widget set library, Jpf. +It uses LablTk API. diff --git a/jpf/balloon.ml b/jpf/balloon.ml new file mode 100644 index 0000000..e880f27 --- /dev/null +++ b/jpf/balloon.ml @@ -0,0 +1,102 @@ +(***********************************************************************) +(* *) +(* 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 + +(* easy balloon help facility *) + +open Tk +open Widget +open Protocol +open Support + +(* switch -- if you do not want balloons, set false *) +let flag = ref true +let debug = ref false + +(* We assume we have at most one popup label at a time *) +let topw = ref default_toplevel +and popupw = ref (Obj.magic dummy : message widget) + +let configure_cursor w cursor = + (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *) + Protocol.tkCommand [| TkToken (name w); + TkToken "configure"; + TkToken "-cursor"; + TkToken cursor |] + +let put ~on: w ~ms: millisec mesg = + let t = ref None in + let cursor = ref "" in + + let reset () = + begin + match !t with + Some t -> Timer.remove t + | _ -> () + end; + (* if there is a popup label, unmap it *) + if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then + begin + Wm.withdraw !topw; + if Winfo.exists w then configure_cursor w !cursor + end + and set ev = + if !flag then + t := Some (Timer.add ~ms: millisec ~callback: (fun () -> + t := None; + if !debug then + prerr_endline ("Balloon: " ^ Widget.name w); + update_idletasks(); + Message.configure !popupw ~text: mesg; + raise_window !topw; + Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *) + ("+"^(string_of_int (ev.ev_RootX + 9))^ + "+"^(string_of_int (ev.ev_RootY + 8))); + Wm.deiconify !topw; + cursor := cget w `Cursor; + configure_cursor w "hand2")) + in + + List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy]; + [`KeyPress]; [`KeyRelease]] + ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ())); + List.iter [[`Enter]; [`Motion]] ~f: + begin fun events -> + bind w ~events ~extend:true ~fields:[`RootX; `RootY] + ~action:(fun ev -> reset (); set ev) + end + +let init () = + let t = Hashtbl.create 101 in + Protocol.add_destroy_hook (fun w -> + Hashtbl.remove t w); + topw := Toplevel.create default_toplevel; + Wm.overrideredirect_set !topw true; + Wm.withdraw !topw; + popupw := Message.create !topw ~name: "balloon" + ~background: (`Color "yellow") ~aspect: 300; + pack [!popupw]; + bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action: + begin fun w -> + try Hashtbl.find t w.ev_Widget + with Not_found -> + Hashtbl.add t w.ev_Widget (); + let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in + if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x + end diff --git a/jpf/balloon.mli b/jpf/balloon.mli new file mode 100644 index 0000000..f3e6526 --- /dev/null +++ b/jpf/balloon.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* easy balloon help facility *) +open Widget + +val flag : bool ref +val init : unit -> unit +val put : on: 'a widget -> ms: int -> string -> unit diff --git a/jpf/balloontest.ml b/jpf/balloontest.ml new file mode 100644 index 0000000..236f617 --- /dev/null +++ b/jpf/balloontest.ml @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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 Tk +open Widget +open Balloon +open Protocol + +let _ = + let t = openTk () in + Balloon.init (); + let b = Button.create t ~text: "hello" in + Button.configure b ~command: (fun () -> destroy b); + pack [b]; + Balloon.put ~on: b ~ms: 1000 "Balloon"; + Printexc.catch mainLoop () diff --git a/jpf/fileselect.ml b/jpf/fileselect.ml new file mode 100644 index 0000000..0c51f4d --- /dev/null +++ b/jpf/fileselect.ml @@ -0,0 +1,367 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* file selection box *) + +(* This file selecter works only under the OS with the full unix support. + For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) + +open StdLabels +open UnixLabels +open Str +open Filename + +open Tk +open Widget + +exception Not_selected + +(********************************************************** Search directory *) +(* Default is curdir *) +let global_dir = ref (getcwd ()) + +(***************************************************** Some widgets creation *) + +(* from frx_listbox.ml *) +let scroll_link sb lb = + Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb); + Scrollbar.configure sb ~command: (Listbox.yview lb) + +(* focus when enter binding *) +let bind_enter_focus w = + bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);; + +let myentry_create p ~variable = + let w = Entry.create p ~relief: `Sunken ~textvariable: variable in + bind_enter_focus w; w + +(************************************************************* Subshell call *) + +let subshell cmd = + let r,w = pipe () in + match fork () with + 0 -> close r; dup2 w stdout; + execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |] + | id -> + close w; + let rc = in_channel_of_descr r 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 + close_in rc; (* because of finalize_channel *) + let _ = waitpid ~mode:[] id in answer + +(***************************************************************** Path name *) + +(* find directory name which doesn't contain "?*[" *) +let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)" + +let parse_filter src = + (* replace // by / *) + let s = global_replace (regexp "/+") "/" src in + (* replace /./ by / *) + let s = global_replace (regexp "/\\./") "/" s in + (* replace ????/../ by "" *) + let s = global_replace + (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") + "" + s in + (* replace ????/..$ by "" *) + let s = global_replace + (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") + "" + s in + (* replace ^/../../ by / *) + let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in + if string_match dirget s 0 then + let dirs = matched_group 1 s + and ptrn = matched_group 2 s + in + dirs, ptrn + else "", s + +let ls dir pattern = + subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") + +(*************************************************************** File System *) + +let get_files_in_directory dir = + let dirh = opendir dir in + let rec get_them l = + match + try Some(Unix.readdir dirh) with _ -> None + with + | None -> + Unix.closedir dirh; l + | Some x -> + get_them (x::l) + in + List.sort ~cmp:compare (get_them []) + +let rec get_directories_in_files path = + List.filter + ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false) + +let remove_directories path = + List.filter + ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false) + +(************************* a nice interface to listbox - from frx_listbox.ml *) + +let add_completion lb action = + let prefx = ref "" (* current match prefix *) + and maxi = ref 0 (* maximum index (doesn'y matter actually) *) + and current = ref 0 (* current position *) + and lastevent = ref 0 in + + let rec move_forward () = + if Listbox.get lb ~index:(`Num !current) < !prefx then + if !current < !maxi then begin incr current; move_forward() end + + and recenter () = + let element = `Num !current in + (* Clean the selection *) + Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; + (* Set it to our unique element *) + Listbox.selection_set lb ~first:element ~last:element; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + Listbox.activate lb ~index:element; + Listbox.selection_anchor lb ~index:element; + Listbox.see lb ~index:element in + + let complete time s = + if time - !lastevent < 500 then (* sorry, hard coded limit *) + prefx := !prefx ^ s + else begin (* reset *) + current := 0; + prefx := s + end; + lastevent := time; + move_forward(); + recenter() in + + + bind lb ~events:[`KeyPress] ~fields:[`Char; `Time] + (* consider only keys producing characters. The callback is called + if you press Shift. *) + ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char); + (* Key specific bindings override KeyPress *) + bind lb ~events:[`KeyPressDetail "Return"] ~action; + (* Finally, we have to set focus, otherwise events dont get through *) + Focus.set lb; + recenter() (* so that first item is selected *); + (* returns init_completion function *) + (fun lb -> + prefx := ""; + maxi := Listbox.size lb - 1; + current := 0) + +(****************************************************************** Creation *) + +let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = + (* Ah ! Now I regret about the names of the widgets... *) + + let current_pattern = ref "" + and current_dir = ref "" in + + (* init_completions *) + let filter_init_completion = ref (fun _ -> ()) + and directory_init_completion = ref (fun _ -> ()) in + + let tl = Toplevel.create default_toplevel in + Focus.set tl; + Wm.title_set tl title; + + let filter_var = Textvariable.create ~on:tl () (* new_temporary *) + and selection_var = Textvariable.create ~on:tl () + and sync_var = Textvariable.create ~on:tl () in + + let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in + let frm = Frame.create frm' ~borderwidth: 8 in + let fl = Label.create frm ~text: "Filter" in + let df = Frame.create frm in + let dfl = Frame.create df in + let dfll = Label.create dfl ~text: "Directories" in + let dflf = Frame.create dfl in + let directory_listbox = Listbox.create dflf ~relief: `Sunken + and directory_scrollbar = Scrollbar.create dflf in + scroll_link directory_scrollbar directory_listbox; + let dfr = Frame.create df in + let dfrl = Label.create dfr ~text: "Files" in + let dfrf = Frame.create dfr in + let filter_listbox = Listbox.create dfrf ~relief: `Sunken in + let filter_scrollbar = Scrollbar.create dfrf in + scroll_link filter_scrollbar filter_listbox; + let sl = Label.create frm ~text: "Selection" in + let filter_entry = myentry_create frm ~variable: filter_var in + let selection_entry = myentry_create frm ~variable: selection_var + in + let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in + let cfrm = Frame.create cfrm' ~borderwidth: 8 in + let dumf = Frame.create cfrm in + let dumf2 = Frame.create cfrm in + + let configure filter = + (* OLDER let curdir = getcwd () in *) +(* Printf.eprintf "CURDIR %s\n" curdir; *) + let filter = + if string_match (regexp "^/.*") filter 0 then filter + else + if filter = "" then !global_dir ^ "/*" + else !global_dir ^ "/" ^ filter in +(* Printf.eprintf "FILTER %s\n" filter; *) + let dirname, patternname = parse_filter filter in +(* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *) + current_dir := dirname; + global_dir := dirname; + let patternname = if patternname = "" then "*" else patternname in + current_pattern := patternname; + let filter = dirname ^ patternname in +(* Printf.eprintf "FILTER : %s\n\n" filter; *) +(* flush Pervasives.stderr; *) + try + let directories = get_directories_in_files dirname + (get_files_in_directory dirname) in + (* get matched file by subshell call. *) + let matched_files = remove_directories dirname (ls dirname patternname) + in + Textvariable.set filter_var filter; + Textvariable.set selection_var (dirname ^ deffile); + Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; + Listbox.insert directory_listbox ~index:`End ~texts:directories; + Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; + Listbox.insert filter_listbox ~index:`End ~texts:matched_files; + !directory_init_completion directory_listbox; + !filter_init_completion filter_listbox + with + Unix_error (ENOENT,_,_) -> + (* Directory is not found (maybe) *) + Bell.ring () + in + + let selected_files = ref [] in (* used for synchronous mode *) + let activate l () = + Grab.release tl; + destroy tl; + if sync then + begin + selected_files := l; + Textvariable.set sync_var "1" + end + else + begin + proc l; + break () + end + in + + (* and buttons *) + let okb = Button.create cfrm ~text: "OK" ~command: + begin fun () -> + let files = + List.map (Listbox.curselection filter_listbox) + ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) + in + let files = if files = [] then [Textvariable.get selection_var] + else files in + activate files () + end + in + let flb = Button.create cfrm ~text: "Filter" + ~command: (fun () -> configure (Textvariable.get filter_var)) in + let ccb = Button.create cfrm ~text: "Cancel" + ~command: (fun () -> activate [] ()) in + + (* binding *) + bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true + ~action:(fun _ -> activate [Textvariable.get selection_var] ()); + bind filter_entry ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> configure (Textvariable.get filter_var)); + + let action _ = + let files = + List.map (Listbox.curselection filter_listbox) + ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) + in + activate files () + in + bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~breakable:true ~action; + if multi then Listbox.configure filter_listbox ~selectmode: `Multiple; + filter_init_completion := add_completion filter_listbox action; + + let action _ = + try + configure (!current_dir ^ ((function + [x] -> Listbox.get directory_listbox ~index:x + | _ -> (* you must choose at least one directory. *) + Bell.ring (); raise Not_selected) + (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) + with _ -> () in + bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~breakable:true ~action; + Listbox.configure directory_listbox ~selectmode: `Browse; + directory_init_completion := add_completion directory_listbox action; + + pack [frm'; frm] ~fill: `X; + (* filter *) + pack [fl] ~side: `Top ~anchor: `W; + pack [filter_entry] ~side: `Top ~fill: `X; + (* directory + files *) + pack [df] ~side: `Top ~fill: `X ~ipadx: 8; + (* directory *) + pack [dfl] ~side: `Left; + pack [dfll] ~side: `Top ~anchor: `W; + pack [dflf] ~side: `Top; + pack [coe directory_listbox; coe directory_scrollbar] + ~side: `Left ~fill: `Y; + (* files *) + pack [dfr] ~side: `Right; + pack [dfrl] ~side: `Top ~anchor: `W; + pack [dfrf] ~side: `Top; + pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; + (* selection *) + pack [sl] ~side: `Top ~anchor: `W; + pack [selection_entry] ~side: `Top ~fill: `X; + + (* create OK, Filter and Cancel buttons *) + pack [cfrm'] ~fill: `X; + pack [cfrm] ~fill: `X; + pack [okb] ~side: `Left; + pack [dumf] ~side: `Left ~expand: true; + pack [flb] ~side: `Left; + pack [dumf2] ~side: `Left ~expand: true; + pack [ccb] ~side: `Left; + + configure deffilter; + + Tkwait.visibility tl; + Grab.set tl; + + if sync then + begin + Tkwait.variable sync_var; + proc !selected_files + end; + () diff --git a/jpf/fileselect.mli b/jpf/fileselect.mli new file mode 100644 index 0000000..42f7d34 --- /dev/null +++ b/jpf/fileselect.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* This file selecter works only under the OS with the full unix support. + For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) + +open Support + +val f : + title:string -> + action:(string list -> unit) -> + filter:string -> file:string -> multi:bool -> sync:bool -> unit + +(* action + [] means canceled + if multi select is false, then the list is null or a singleton *) + +(* multi select + if true then more than one file are selectable *) + +(* sync it + if true then in synchronous mode *) diff --git a/jpf/jpf_font.ml b/jpf/jpf_font.ml new file mode 100644 index 0000000..ad1a7b7 --- /dev/null +++ b/jpf/jpf_font.ml @@ -0,0 +1,218 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* find font information *) + +let debug = ref false +let log s = + if !debug then try prerr_endline s with _ -> () + +type ('s, 'i) xlfd = { + (* some of them are currently not interesting for me *) + mutable foundry: 's; + mutable family: 's; + mutable weight: 's; + mutable slant: 's; + mutable setWidth: 's; + mutable addStyle: 's; + mutable pixelSize: 'i; + mutable pointSize: 'i; + mutable resolutionX: 'i; + mutable resolutionY: 'i; + mutable spacing: 's; + mutable averageWidth: 'i; + mutable registry: 's; + mutable encoding: 's + } + +let copy xlfd = {xlfd with foundry= xlfd.foundry} + +let string_of_xlfd s i xlfd = + let foundry= s xlfd.foundry + and family= s xlfd.family + and weight= s xlfd.weight + and slant= s xlfd.slant + and setWidth = s xlfd.setWidth + and addStyle = s xlfd.addStyle + and pixelSize= i xlfd.pixelSize + and pointSize = i xlfd.pointSize + and resolutionX = i xlfd.resolutionX + and resolutionY = i xlfd.resolutionY + and spacing= s xlfd.spacing + and averageWidth = i xlfd.averageWidth + and registry= s xlfd.registry + and encoding = s xlfd.encoding in + + "-"^foundry^ + "-"^family^ + "-"^weight^ + "-"^slant^ + "-"^setWidth ^ + "-"^addStyle ^ + "-"^pixelSize^ + "-"^pointSize ^ + "-"^resolutionX ^ + "-"^resolutionY ^ + "-"^spacing^ + "-"^averageWidth ^ + "-"^registry^ + "-"^encoding + +exception Parse_Xlfd_Failure of string + +let parse_xlfd xlfd_string = + (* this must not be a pattern *) + let split_str char_sep str = + let len = String.length str in + let rec split beg cur = + if cur >= len then [String.sub str beg (len - beg)] + else if char_sep (String.get str cur) + then + let nextw = succ cur in + (String.sub str beg (cur - beg)) + ::(split nextw nextw) + else split beg (succ cur) in + split 0 0 + in + match split_str (function '-' -> true | _ -> false) xlfd_string with + | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize; + pointSize; resolutionX; resolutionY; spacing; averageWidth; + registry; encoding ] -> + { foundry= foundry; + family= family; + weight= weight; + slant= slant; + setWidth= setWidth; + addStyle= addStyle; + pixelSize= int_of_string pixelSize; + pointSize= int_of_string pointSize; + resolutionX= int_of_string resolutionX; + resolutionY= int_of_string resolutionY; + spacing= spacing; + averageWidth= int_of_string averageWidth; + registry= registry; + encoding= encoding; + } + | _ -> raise (Parse_Xlfd_Failure xlfd_string) + +type valid_xlfd = (string, int) xlfd + +let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int + +type pattern = (string option, int option) xlfd + +let empty_pattern = + { foundry= None; + family= None; + weight= None; + slant= None; + setWidth= None; + addStyle= None; + pixelSize= None; + pointSize= None; + resolutionX= None; + resolutionY= None; + spacing= None; + averageWidth= None; + registry= None; + encoding= None; + } + +let string_of_pattern = + let pat f = function + Some x -> f x + | None -> "*" + in + let pat_string = pat (fun x -> x) in + let pat_int = pat string_of_int in + string_of_xlfd pat_string pat_int + +let is_vector_font xlfd = + (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) || + xlfd.spacing <> "c" + +let list_fonts dispname pattern = + let dispopt = match dispname with + None -> "" + | Some x -> "-display " ^ x + in + let result = List.map parse_xlfd + (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) + in + if result = [] then raise Not_found + else result + +let available_pixel_size_aux dispname pattern = + (* return available pixel size without font resizing *) + (* to obtain good result, *) + (* the pattern should contain as many information as possible *) + let pattern = copy pattern in + pattern.pixelSize <- None; + let xlfds = list_fonts dispname pattern in + let pxszs = Hashtbl.create 107 in + List.iter (fun xlfd -> + Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; + pxszs + +let extract_size_font_hash tbl = + let keys = ref [] in + Hashtbl.iter (fun k _ -> + if not (List.mem k !keys) then keys := k :: !keys) tbl; + List.sort (fun (k1,_) (k2,_) -> compare k1 k2) + (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) + +let available_pixel_size dispname pattern = + let pxszs = available_pixel_size_aux dispname pattern in + extract_size_font_hash pxszs + +let nearest_pixel_size dispname vector_ok pattern = + (* find the font with the nearest pixel size *) + log ("\n*** "^string_of_pattern pattern); + let pxlsz = + match pattern.pixelSize with + None -> raise (Failure "invalid pixelSize pattern") + | Some x -> x + in + let tbl = available_pixel_size_aux dispname pattern in + let newtbl = Hashtbl.create 107 in + Hashtbl.iter (fun s xlfd -> + if vector_ok then + if s = 0 then begin + if is_vector_font xlfd then begin + log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); + xlfd.pixelSize <- pxlsz; + Hashtbl.add newtbl pxlsz xlfd + end + end else Hashtbl.add newtbl s xlfd + else if not (is_vector_font xlfd) && s <> 0 then + Hashtbl.add newtbl s xlfd) tbl; + + let size_font_table = extract_size_font_hash newtbl in + + let diff = ref 10000 in + let min = ref None in + List.iter (fun (s,xlfds) -> + let d = abs(s - pxlsz) in + if d < !diff then begin + min := Some (s,xlfds); + diff := d + end) size_font_table; + (* if it contains more than one font, just return the first *) + match !min with + | None -> raise Not_found + | Some(s, xlfds) -> + log (Printf.sprintf "Size %d is selected" s); + List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds; + List.hd xlfds diff --git a/jpf/jpf_font.mli b/jpf/jpf_font.mli new file mode 100644 index 0000000..f3045a9 --- /dev/null +++ b/jpf/jpf_font.mli @@ -0,0 +1,54 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val debug : bool ref + +type ('a, 'b) xlfd = + { mutable foundry: 'a; + mutable family: 'a; + mutable weight: 'a; + mutable slant: 'a; + mutable setWidth: 'a; + mutable addStyle: 'a; + mutable pixelSize: 'b; + mutable pointSize: 'b; + mutable resolutionX: 'b; + mutable resolutionY: 'b; + mutable spacing: 'a; + mutable averageWidth: 'b; + mutable registry: 'a; + mutable encoding: 'a } + +exception Parse_Xlfd_Failure of string + +type valid_xlfd = (string, int) xlfd +type pattern = (string option, int option) xlfd + +val empty_pattern : pattern + +val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd + +val string_of_valid_xlfd : valid_xlfd -> string +val string_of_pattern : pattern -> string + +val is_vector_font : valid_xlfd -> bool + +val list_fonts : string option -> pattern -> valid_xlfd list + +val available_pixel_size : + string option -> pattern -> (int * valid_xlfd list) list + +val nearest_pixel_size : + string option -> bool -> pattern -> valid_xlfd diff --git a/jpf/jpflib.mllib b/jpf/jpflib.mllib new file mode 100644 index 0000000..6a04d14 --- /dev/null +++ b/jpf/jpflib.mllib @@ -0,0 +1 @@ +Fileselect Balloon Shell Jpf_font diff --git a/jpf/shell.ml b/jpf/shell.ml new file mode 100644 index 0000000..0d566e0 --- /dev/null +++ b/jpf/shell.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +open Unix + +(************************************************************* Subshell call *) + +let subshell cmd = + let r,w = pipe () in + match fork () with + 0 -> close r; dup2 w stdout; + close stderr; + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + | id -> + close w; + let rc = in_channel_of_descr r in + let rec it () = try + let x = input_line rc in x:: it () + with _ -> [] + in + let answer = it() in + close_in rc; (* because of finalize_channel *) + let _ = waitpid [] id in answer diff --git a/jpf/shell.mli b/jpf/shell.mli new file mode 100644 index 0000000..7c7dd8e --- /dev/null +++ b/jpf/shell.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val subshell : string -> string list diff --git a/labl.gif b/labl.gif new file mode 100644 index 0000000..d0a29fa Binary files /dev/null and b/labl.gif differ diff --git a/labltk/.gitignore b/labltk/.gitignore new file mode 100644 index 0000000..81bd183 --- /dev/null +++ b/labltk/.gitignore @@ -0,0 +1,4 @@ +*.ml +*.mli +labltktop +labltk diff --git a/labltk/Makefile b/labltk/Makefile new file mode 100644 index 0000000..8fb58db --- /dev/null +++ b/labltk/Makefile @@ -0,0 +1,67 @@ +####################################################################### +# # +# 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: labltkobjs + +opt: labltkobjsx + +include ./modules + +LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo +LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) + +labltkobjs: $(LABLTKOBJS) + +labltkobjsx: $(LABLTKOBJSX) + +ifeq ($(USE_FINDLIB),yes) +install: + ocamlfind install labltk -add \ + $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) +installopt: + ocamlfind install labltk -add $(LABLTKOBJSX) +else +install: + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/*.cmi + +installopt: + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LABLTKOBJSX) $(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/labltk/Makefile.gen b/labltk/Makefile.gen new file mode 100644 index 0000000..35bc34d --- /dev/null +++ b/labltk/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/labltk/Makefile.gen.nt b/labltk/Makefile.gen.nt new file mode 100644 index 0000000..4feb527 --- /dev/null +++ b/labltk/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/labltk/Makefile.nt b/labltk/Makefile.nt new file mode 100644 index 0000000..74203f0 --- /dev/null +++ b/labltk/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/labltk/byte.itarget b/labltk/byte.itarget new file mode 100644 index 0000000..1f061ac --- /dev/null +++ b/labltk/byte.itarget @@ -0,0 +1,8 @@ +place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo +scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo +message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo +option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo +radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo +winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo + +tk.cmo labltk.cmo diff --git a/labltk/modules b/labltk/modules new file mode 100644 index 0000000..6298817 --- /dev/null +++ b/labltk/modules @@ -0,0 +1,77 @@ +WIDGETOBJS= bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo +bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml + +bell.cmo : bell.ml +bell.cmi : bell.mli +scale.cmo : scale.ml +scale.cmi : scale.mli +winfo.cmo : winfo.ml +winfo.cmi : winfo.mli +scrollbar.cmo : scrollbar.ml +scrollbar.cmi : scrollbar.mli +entry.cmo : entry.ml +entry.cmi : entry.mli +listbox.cmo : listbox.ml +listbox.cmi : listbox.mli +wm.cmo : wm.ml +wm.cmi : wm.mli +tkwait.cmo : tkwait.ml +tkwait.cmi : tkwait.mli +grab.cmo : grab.ml +grab.cmi : grab.mli +font.cmo : font.ml +font.cmi : font.mli +canvas.cmo : canvas.ml +canvas.cmi : canvas.mli +image.cmo : image.ml +image.cmi : image.mli +clipboard.cmo : clipboard.ml +clipboard.cmi : clipboard.mli +label.cmo : label.ml +label.cmi : label.mli +message.cmo : message.ml +message.cmi : message.mli +text.cmo : text.ml +text.cmi : text.mli +imagephoto.cmo : imagephoto.ml +imagephoto.cmi : imagephoto.mli +option.cmo : option.ml +option.cmi : option.mli +frame.cmo : frame.ml +frame.cmi : frame.mli +selection.cmo : selection.ml +selection.cmi : selection.mli +dialog.cmo : dialog.ml +dialog.cmi : dialog.mli +place.cmo : place.ml +place.cmi : place.mli +pixmap.cmo : pixmap.ml +pixmap.cmi : pixmap.mli +menubutton.cmo : menubutton.ml +menubutton.cmi : menubutton.mli +radiobutton.cmo : radiobutton.ml +radiobutton.cmi : radiobutton.mli +focus.cmo : focus.ml +focus.cmi : focus.mli +pack.cmo : pack.ml +pack.cmi : pack.mli +imagebitmap.cmo : imagebitmap.ml +imagebitmap.cmi : imagebitmap.mli +encoding.cmo : encoding.ml +encoding.cmi : encoding.mli +optionmenu.cmo : optionmenu.ml +optionmenu.cmi : optionmenu.mli +checkbutton.cmo : checkbutton.ml +checkbutton.cmi : checkbutton.mli +tkvars.cmo : tkvars.ml +tkvars.cmi : tkvars.mli +palette.cmo : palette.ml +palette.cmi : palette.mli +menu.cmo : menu.ml +menu.cmi : menu.mli +button.cmo : button.ml +button.cmi : button.mli +toplevel.cmo : toplevel.ml +toplevel.cmi : toplevel.mli +grid.cmo : grid.ml +grid.cmi : grid.mli diff --git a/labltk/native.itarget b/labltk/native.itarget new file mode 100644 index 0000000..4bdc92c --- /dev/null +++ b/labltk/native.itarget @@ -0,0 +1,6 @@ +place.cmx wm.cmx imagephoto.cmx canvas.cmx button.cmx text.cmx label.cmx +scrollbar.cmx image.cmx encoding.cmx pixmap.cmx palette.cmx font.cmx +message.cmx menu.cmx entry.cmx listbox.cmx focus.cmx menubutton.cmx pack.cmx +option.cmx toplevel.cmx frame.cmx dialog.cmx imagebitmap.cmx clipboard.cmx +radiobutton.cmx tkwait.cmx grab.cmx selection.cmx scale.cmx optionmenu.cmx +winfo.cmx grid.cmx checkbutton.cmx bell.cmx tkvars.cmx diff --git a/lib/.gitignore b/lib/.gitignore new file mode 100644 index 0000000..005295f --- /dev/null +++ b/lib/.gitignore @@ -0,0 +1,7 @@ +labltktop +labltk +mltktop +mltk +.depend +*.ml +*.mli diff --git a/lib/Makefile b/lib/Makefile new file mode 100644 index 0000000..db46b7f --- /dev/null +++ b/lib/Makefile @@ -0,0 +1,117 @@ +####################################################################### +# # +# 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 + +all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) + +opt: $(LIBNAME).cmxa + +clean: + rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A) *$(EXT_DLL) + +superclean: + - if test -f tk.cmo; then \ + echo We have changes... Now lib directory has no .cmo files; \ + rm -f *.cm* *.$(O); \ + fi + +include ../labltk/modules +LABLTKOBJS=tk.cmo $(WIDGETOBJS) + +include ../camltk/modules +CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo + +SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ + ../support/widget.cmo ../support/protocol.cmo \ + ../support/textvariable.cmo ../support/timer.cmo \ + ../support/fileevent.cmo ../support/camltkwrap.cmo + +TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) + +TOPLEVELLIBS=ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma + +TOPLEVELSTART=topstart.cmo + +TOPDEPS = $(TOPLEVELLIBS) $(TOPLEVELSTART) + +$(LIBNAME).cma: $(SUPPORT) ../Widgets.src + $(MAKE) superclean + cd ../labltk; $(MAKE) + cd ../camltk; $(MAKE) + $(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \ + -I ../labltk -I ../camltk $(TKOBJS) \ + -cclib "\"$(TK_LINK)\"" + +$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src + $(MAKE) superclean + cd ../labltk; $(MAKE) opt + cd ../camltk; $(MAKE) opt + $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \ + -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ + -cclib "\"$(TK_LINK)\"" + +$(LIBNAME)top$(EXE) : $(LIBNAME).cma ../support/lib$(LIBNAME).$(A) + $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ + $(TOPLEVELLIBS) \ + -I +compiler-libs unix.cma \ + -I ../labltk -I ../camltk $(LIBNAME).cma \ + str.cma \ + $(TOPLEVELSTART) + +$(LIBNAME): Makefile + @echo Generate $@ + @echo "#!/bin/sh" > $@ + @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@ + +install-script: $(LIBNAME) + cp $(LIBNAME) $(INSTALLBINDIR) + chmod 755 $(INSTALLBINDIR)/$(LIBNAME) + +install-batch: + cp labltk.bat $(INSTALLBINDIR) + +ifeq ($USE_FINDLIB,yes) +install: + ocamlfind install labltk -add $(LIBNAME).cma $(LIBNAME)top$(EXE) + chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) + @case x$(TOOLCHAIN) in \ + xmingw|xmsvc) $(MAKE) install-batch ;; \ + *) $(MAKE) install-script ;; \ + esac + +installopt: + ocamlfind install labltk -add $(LIBNAME).cmxa $(LIBNAME).$(A) + cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) +else +install: + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/$(LIBNAME).cma + chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) + @if test -d $(INSTALLBINDIR); then : ; else mkdir $(INSTALLBINDIR); fi + @case x$(TOOLCHAIN) in \ + xmingw|xmsvc) $(MAKE) install-batch ;; \ + *) $(MAKE) install-script ;; \ + esac + +installopt: + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) + chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa + chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A) +endif \ No newline at end of file diff --git a/lib/Makefile.nt b/lib/Makefile.nt new file mode 100644 index 0000000..74203f0 --- /dev/null +++ b/lib/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/lib/labltk.bat b/lib/labltk.bat new file mode 100755 index 0000000..8020faf --- /dev/null +++ b/lib/labltk.bat @@ -0,0 +1 @@ +@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/support/.depend b/support/.depend new file mode 100644 index 0000000..a7fc006 --- /dev/null +++ b/support/.depend @@ -0,0 +1,27 @@ +camltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi +protocol.cmi: widget.cmi +textvariable.cmi: widget.cmi protocol.cmi +tkthread.cmi: widget.cmi +widget.cmi: rawwidget.cmi +camltkwrap.cmo: timer.cmi textvariable.cmi rawwidget.cmi protocol.cmi \ + fileevent.cmi camltkwrap.cmi +camltkwrap.cmx: timer.cmx textvariable.cmx rawwidget.cmx protocol.cmx \ + fileevent.cmx camltkwrap.cmi +fileevent.cmo: support.cmi protocol.cmi fileevent.cmi +fileevent.cmx: support.cmx protocol.cmx fileevent.cmi +protocol.cmo: widget.cmi support.cmi protocol.cmi +protocol.cmx: widget.cmx support.cmx protocol.cmi +rawwidget.cmo: support.cmi rawwidget.cmi +rawwidget.cmx: support.cmx rawwidget.cmi +slave.cmo: widget.cmi +slave.cmx: widget.cmx +support.cmo: support.cmi +support.cmx: support.cmi +textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi +textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi +timer.cmo: support.cmi protocol.cmi timer.cmi +timer.cmx: support.cmx protocol.cmx timer.cmi +tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi +tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi +widget.cmo: rawwidget.cmi widget.cmi +widget.cmx: rawwidget.cmx widget.cmi diff --git a/support/META b/support/META new file mode 100644 index 0000000..195448a --- /dev/null +++ b/support/META @@ -0,0 +1,9 @@ +# Specifications for the "labltk" library: +requires = "" +version = "8.06.0" +description = "The Tk windowing toolkit" +browse_interfaces = " Frx_after Frx_color Frx_ctext Frx_dialog Frx_entry Frx_fillbox Frx_fit Frx_focus Frx_font Frx_listbox Frx_mem Frx_misc Frx_req Frx_rpc Frx_selection Frx_synth Frx_text Frx_widget Balloon Fileselect Jpf_font Shell Bell Button Camltk Camltkwrap Canvas CBell CButton CCanvas CCheckbutton CClipboard CDialog CEncoding CEntry CFocus CFont CFrame CGrab CGrid Checkbutton CImage CImagebitmap CImagephoto CLabel Clipboard CListbox CMenu CMenubutton CMessage COption COptionmenu CPack CPalette CPixmap CPlace CRadiobutton CResource CScale CScrollbar CSelection CText CTk CTkvars CTkwait CToplevel CWinfo CWm Dialog Encoding Entry Fileevent Focus Font Frame Grab Grid Image Imagebitmap Imagephoto Label Labltk Listbox Menu Menubutton Message Option Optionmenu Pack Palette Pixmap Place Protocol Radiobutton Rawwidget Scale Scrollbar Selection Support Text Textvariable Timer Tk Tkvars Tkwait Toplevel Widget Winfo Wm Tkanim " +archive(byte) = "labltk.cma" +archive(native) = "labltk.cmxa" +linkopts = "" + diff --git a/support/Makefile b/support/Makefile new file mode 100644 index 0000000..9d88d02 --- /dev/null +++ b/support/Makefile @@ -0,0 +1,103 @@ +####################################################################### +# # +# 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 Makefile.common + +all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ + textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ + tkthread.cmo lib$(LIBNAME).$(A) + +opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ + textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ + tkthread.cmx lib$(LIBNAME).$(A) + +COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \ + cltkFile.$(O) cltkMain.$(O) cltkMisc.$(O) cltkTimer.$(O) \ + cltkVar.$(O) cltkWait.$(O) cltkImg.$(O) + +CCFLAGS=-I$(LIBDIR)/caml $(TK_DEFS) $(SHAREDCCCOMPOPTS) + +COMPFLAGS= +THFLAGS=-I +threads -I vmthreads +TKLDOPTS=$(TK_LINK:%=-ldopt "%") + +lib$(LIBNAME).$(A): $(COBJS) + $(MKLIB) -o $(LIBNAME) $(COBJS) $(TKLDOPTS) + +PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ + rawwidget.mli widget.mli +PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.mli tkthread.cmi tkthread.cmo + +ifeq ($(USE_FINDLIB),yes) +install: + ocamlfind install labltk META $(PUB) lib$(LIBNAME).$(A) \ + -optional dll$(LIBNAME)$(EXT_DLL) + $(RANLIB) lib$(LIBNAME).$(A) + +installopt: + ocamlfind install labltk -add \ + $(PUBMLI:.mli=.cmx) -optional tkthread.cmx tkthread.$(O) +else +install: + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(PUB) lib$(LIBNAME).$(A) $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).$(A) + cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).$(A) + if test -f dll$(LIBNAME)$(EXT_DLL); then \ + cp dll$(LIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi + +installopt: + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) + if test -f tkthread.$(O); then \ + cp tkthread.cmx tkthread.$(O) $(INSTALLDIR); \ + chmod 644 $(INSTALLDIR)/tkthread.cmx $(INSTALLDIR)/tkthread.$(O); \ + fi +endif + +clean: + rm -f *.cm* *.o *.a *.so *.obj *.lib *.dll *.exp + +.SUFFIXES: +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mlp .c .$(O) + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.c.$(O): + $(CC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< + +tkthread.cmi: tkthread.mli + $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< +tkthread.cmo: tkthread.ml + $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< +tkthread.cmx: tkthread.ml + if test -f $(LIBDIR)/systhreads/threads.cmxa; then \ + $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \ + fi + +depend: + $(CAMLDEP) *.mli *.ml > .depend + +$(COBJS): camltk.h + +include .depend diff --git a/support/Makefile.common b/support/Makefile.common new file mode 100644 index 0000000..d24d591 --- /dev/null +++ b/support/Makefile.common @@ -0,0 +1,37 @@ +####################################################################### +# # +# 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. # +# # +####################################################################### + +LIBNAME=labltk + +include ../config/Makefile + +## Tools from the OCaml distribution + +CAMLRUN=$(BINDIR)/ocamlrun +CAMLC=$(BINDIR)/ocamlc$(OPT) +CAMLOPT=$(BINDIR)/ocamlopt$(OPT) +CAMLCB=$(BINDIR)/ocamlc +CAMLOPTB=$(BINDIR)/ocamlopt +CAMLCOMP=$(CAMLC) -c -warn-error A-3 +CAMLYACC=$(BINDIR)/ocamlyacc -v +CAMLLEX=$(BINDIR)/ocamllex +CAMLLIBR=$(CAMLC) -a +CAMLDEP=$(BINDIR)/ocamldep +COMPFLAGS=-g +LINKFLAGS= +CAMLOPTLIBR=$(CAMLOPT) -a +MKLIB=$(BINDIR)/ocamlmklib +CAMLRUNGEN=$(BINDIR)/ocamlrun diff --git a/support/Makefile.nt b/support/Makefile.nt new file mode 100644 index 0000000..74203f0 --- /dev/null +++ b/support/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/support/byte.itarget b/support/byte.itarget new file mode 100644 index 0000000..6f31e01 --- /dev/null +++ b/support/byte.itarget @@ -0,0 +1,3 @@ +support.cmo rawwidget.cmo widget.cmo protocol.cmo +textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo +tkthread.cmo diff --git a/support/camltk.h b/support/camltk.h new file mode 100644 index 0000000..2c92f90 --- /dev/null +++ b/support/camltk.h @@ -0,0 +1,68 @@ +/*************************************************************************/ +/* */ +/* OCaml LablTk library */ +/* */ +/* Francois Rouaix, Francois Pessaux and 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$ */ + +#if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT) +#define CAMLTKextern CAMLexport +#else +#define CAMLTKextern CAMLextern +#endif + +/* compatibility with earlier versions of Tcl/Tk */ +#ifndef CONST84 +#define CONST84 +#endif + +/*Tcl_GetResult(), Tcl_GetStringResult(), Tcl_SetResult(), */ + /*Tcl_SetStringResult(), Tcl_GetErrorLine() */ + +/* if Tcl_GetStringResult is not defined, we use interp->result */ +/*#ifndef Tcl_GetStringResult*/ +/*# define Tcl_GetStringResult(interp) (interp->result)*/ +/*#endif*/ + +/* cltkMisc.c */ +/* copy an OCaml string to the C heap. Must be deallocated with stat_free */ +extern char *string_to_c(value s); + +/* cltkUtf.c */ +extern value tcl_string_to_caml( const char * ); +extern char * caml_string_to_tcl( value ); + +/* cltkEval.c */ +CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ +extern value copy_string_list(int argc, char **argv); + +/* cltkCaml.c */ +/* pointers to OCaml values */ +extern value *tkerror_exn; +extern value *handler_code; +extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, + int argc, CONST84 char *argv[]); +CAMLTKextern void tk_error(const char * errmsg) Noreturn; + +/* cltkMain.c */ +extern int signal_events; +extern void invoke_pending_caml_signals(ClientData clientdata); +extern Tk_Window cltk_mainWindow; +extern int cltk_slave_mode; + +/* check that initialisations took place */ +#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") + +#define RCNAME ".camltkrc" +#define CAMLCB "camlcb" diff --git a/support/camltkwrap.ml b/support/camltkwrap.ml new file mode 100644 index 0000000..635349a --- /dev/null +++ b/support/camltkwrap.ml @@ -0,0 +1,77 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +module Widget = struct + include Rawwidget + type widget = raw_any raw_widget + + let default_toplevel = coe default_toplevel +end + +module Protocol = struct + open Widget + include Protocol + + let opentk () = coe (opentk ()) + let opentk_with_args args = coe (opentk_with_args args) + let openTk ?display ?clas () = coe (openTk ?display ?clas ()) + + let cCAMLtoTKwidget table w = + Widget.check_class w table; (* we need run time type check of widgets *) + TkToken (Widget.name w) + + (* backward compatibility *) + let openTkClass s = coe (openTkClass s) + let openTkDisplayClass disp c = coe (openTkDisplayClass disp c) +end + +module Textvariable = struct + open Textvariable + type textVariable = Textvariable.textVariable + let create = create + let set = set + let get = get + let name = name + let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable + let handle tv cbk = handle tv ~callback:cbk + let coerce = coerce + + (*-*) + let free = free + + (* backward compatibility *) + let create_temporary w = create ~on: w () +end + +module Fileevent = struct + open Fileevent + let add_fileinput fd callback = add_fileinput ~fd ~callback + let remove_fileinput fd = remove_fileinput ~fd + let add_fileoutput fd callback = add_fileoutput ~fd ~callback + let remove_fileoutput fd = remove_fileoutput ~fd +end + +module Timer = struct + open Timer + type t = Timer.t + let add ms callback = add ~ms ~callback + let set ms callback = set ~ms ~callback + let remove = remove +end + +(* +Not compiled in support +module Tkwait = Tkwait +*) diff --git a/support/camltkwrap.mli b/support/camltkwrap.mli new file mode 100644 index 0000000..4fc7e3c --- /dev/null +++ b/support/camltkwrap.mli @@ -0,0 +1,251 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +module Widget : sig + type widget = Widget.any Widget.widget + (* widget is an abstract type *) + + val default_toplevel : widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + + val atom : parent: widget -> name: string -> widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + + val name : widget -> string + (* [name w] returns the name (tk "path") of a widget *) + + (*--*) + (* The following functions are used internally. + There is normally no need for them in users programs + *) + + val known_class : widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + + val dummy : widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + + val new_atom : parent: widget -> ?name: string -> string -> widget + (* incompatible with the classic camltk *) + + val get_atom : string -> widget + (* [get_atom path] returns the widget with Tk path [path] *) + + val remove : widget -> unit + (* [remove w] removes widget from the internal tables *) + + (* Subtypes tables *) + val widget_any_table : string list + val widget_button_table : string list + val widget_canvas_table : string list + val widget_checkbutton_table : string list + val widget_entry_table : string list + val widget_frame_table : string list + val widget_label_table : string list + val widget_listbox_table : string list + val widget_menu_table : string list + val widget_menubutton_table : string list + val widget_message_table : string list + val widget_radiobutton_table : string list + val widget_scale_table : string list + val widget_scrollbar_table : string list + val widget_text_table : string list + val widget_toplevel_table : string list + + val chk_sub : string -> 'a list -> 'a -> unit + val check_class : widget -> string list -> unit + (* Widget subtyping *) + + exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) + + (* this function is not used, but introduced for the compatibility + with labltk. useless for camltk users *) + val coe : 'a Widget.widget -> Widget.any Widget.widget +end + +module Protocol : sig + open Widget + + (* Lower level interface *) + exception TkError of string + (* Raised by the communication functions *) + + val debug : bool ref + (* When set to true, displays approximation of intermediate Tcl code *) + + type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + + + (* Misc *) + external splitlist : string -> string list + = "camltk_splitlist" + + val add_destroy_hook : (widget -> unit) -> unit + + + (* Opening, closing, and mainloop *) + val default_display : unit -> string + + val opentk : unit -> widget + (* The basic initialization function. [opentk ()] parses automatically + the command line options and use the tk related options in them + such as "-display localhost:0" to initialize Tk applications. + Consult wish manpage about the supported options. *) + + val keywords : (string * Arg.spec * string) list + (* Command line parsing specification for Arg.parse, which contains + the standard Tcl/Tk command line options such as "-display" and "-name". + These Tk command line options are used by opentk *) + + val opentk_with_args : string list -> widget + (* [opentk_with_args argv] invokes [opentk] with the tk related + command line options given by [argv] to the executable program. *) + + val openTk : ?display:string -> ?clas:string -> unit -> widget + (* [openTk ~display:display ~clas:clas ()] is equivalent to + [opentk ["-display"; display; "-name"; clas]] *) + + (* Legacy opentk functions *) + val openTkClass: string -> widget + (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) + val openTkDisplayClass: string -> string -> widget + (* [openTkDisplayClass disp class] is equivalent to + [opentk ["-display"; disp; "-name"; class]] *) + + val closeTk : unit -> unit + val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] *) + + val mainLoop : unit -> unit + + + (* Direct evaluation of tcl code *) + val tkEval : tkArgs array -> string + + val tkCommand : tkArgs array -> unit + + (* Returning a value from a Tcl callback *) + val tkreturn: string -> unit + + + (* Callbacks: this is private *) + + type cbid = Protocol.cbid + + type callback_buffer = string list + (* Buffer for reading callback arguments *) + + val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t + (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) + val callback_memo_table : (widget, cbid) Hashtbl.t + (* Exported for debug purposes only. Don't use them unless you + know what you are doing *) + val new_function_id : unit -> cbid + val string_of_cbid : cbid -> string + val register_callback : widget -> callback:(callback_buffer -> unit) -> string + (* Callback support *) + val clear_callback : cbid -> unit + (* Remove a given callback from the table *) + val remove_callbacks : widget -> unit + (* Clean up callbacks associated to widget. Must be used only when + the Destroy event is bind by the user and masks the default + Destroy event binding *) + + val cTKtoCAMLwidget : string -> widget + val cCAMLtoTKwidget : string list -> widget -> tkArgs + + val register : string -> callback:(callback_buffer -> unit) -> unit + + (*-*) + val prerr_cbid : cbid -> unit +end + +module Textvariable : sig + open Widget + open Protocol + + type textVariable = Textvariable.textVariable + (* TextVariable is an abstract type *) + + val create : ?on: widget -> unit -> textVariable + (* Allocation of a textVariable with lifetime associated to widget + if a widget is specified *) + val create_temporary : widget -> textVariable + (* for backward compatibility + [create_temporary w] is equivalent to [create ~on:w ()] *) + + val set : textVariable -> string -> unit + (* Setting the val of a textVariable *) + val get : textVariable -> string + (* Reading the val of a textVariable *) + val name : textVariable -> string + (* Its tcl name *) + + val cCAMLtoTKtextVariable : textVariable -> tkArgs + (* Internal conversion function *) + + val handle : textVariable -> (unit -> unit) -> unit + (* Callbacks on variable modifications *) + + val coerce : string -> textVariable + + (*-*) + val free : textVariable -> unit +end + +module Fileevent : sig + open Unix + + val add_fileinput : file_descr -> (unit -> unit) -> unit + val remove_fileinput: file_descr -> unit + val add_fileoutput : file_descr -> (unit -> unit) -> unit + val remove_fileoutput: file_descr -> unit + (* see [tk] module *) +end + +module Timer : sig + type t = Timer.t + + val add : int -> (unit -> unit) -> t + val set : int -> (unit -> unit) -> unit + val remove : t -> unit +end + +(* +Tkwait exists, but is not used in support +module Tkwait : sig + val internal_tracevis : string -> Protocol.cbid -> unit + val internal_tracedestroy : string -> Protocol.cbid -> unit +end +*) diff --git a/support/cltkCaml.c b/support/cltkCaml.c new file mode 100644 index 0000000..9c2928a --- /dev/null +++ b/support/cltkCaml.c @@ -0,0 +1,85 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include +#include +#include "camltk.h" + +value * tkerror_exn = NULL; +value * handler_code = NULL; + +/* The Tcl command for evaluating callback in OCaml */ +int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, + int argc, CONST84 char **argv) +{ + CheckInit(); + + /* Assumes no result */ + Tcl_SetResult(interp, NULL, NULL); + if (argc >= 2) { + int id; + if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) + return TCL_ERROR; + caml_callback2(*handler_code,Val_int(id), + copy_string_list(argc - 2,(char **)&argv[2])); + /* Never fails (OCaml would have raised an exception) */ + /* but result may have been set by callback */ + return TCL_OK; + } + else + return TCL_ERROR; +} + +/* Callbacks are always of type _ -> unit, to simplify storage + * But a callback can nevertheless return something (to Tcl) by + * using the following. TCL_VOLATILE ensures that Tcl will make + * a copy of the string + */ +CAMLprim value camltk_return (value v) +{ + CheckInit(); + + Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); + return Val_unit; +} + +/* Note: caml_raise_with_string WILL copy the error message */ +CAMLprim void tk_error(const char *errmsg) +{ + caml_raise_with_string(*tkerror_exn, errmsg); +} + + +/* The initialisation of the C global variables pointing to OCaml values + must be made accessible from OCaml, so that we are sure that it *always* + takes place during loading of the protocol module + */ + +CAMLprim value camltk_init(value v) +{ + /* Initialize the OCaml pointers */ + if (tkerror_exn == NULL) + tkerror_exn = caml_named_value("tkerror"); + if (handler_code == NULL) + handler_code = caml_named_value("camlcb"); + return Val_unit; +} diff --git a/support/cltkDMain.c b/support/cltkDMain.c new file mode 100644 index 0000000..3edcb34 --- /dev/null +++ b/support/cltkDMain.c @@ -0,0 +1,247 @@ +/*************************************************************************/ +/* */ +/* OCaml LablTk library */ +/* */ +/* Francois Rouaix, Francois Pessaux and 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$ */ + +#include +#include +#include +#include +#include "gc.h" +#include "exec.h" +#include "sys.h" +#include "fail.h" +#include "io.h" +#include "mlvalues.h" +#include "memory.h" +#include "camltk.h" + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + + +/* + * Dealing with signals: when a signal handler is defined in OCaml, + * the actual execution of the signal handler upon reception of the + * signal is delayed until we are sure we are out of the GC. + * If a signal occurs during the MainLoop, we would have to wait + * the next event for the handler to be invoked. + * The following function will invoke a pending signal handler if any, + * and we put in on a regular timer. + */ + +#define SIGNAL_INTERVAL 300 + +int signal_events = 0; /* do we have a pending timer */ + +void invoke_pending_caml_signals (clientdata) + ClientData clientdata; +{ + signal_events = 0; + caml_enter_blocking_section(); /* triggers signal handling */ + /* Rearm timer */ + Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); + signal_events = 1; + caml_leave_blocking_section(); +} +/* The following is taken from byterun/startup.c */ +header_t atom_table[256]; +code_t start_code; +asize_t code_size; + +static void init_atoms() +{ + int i; + for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); +} + +static unsigned long read_size(p) + unsigned char * p; +{ + return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + + ((unsigned long) p[2] << 8) + p[3]; +} + +#define FILE_NOT_FOUND (-1) +#define TRUNCATED_FILE (-2) +#define BAD_MAGIC_NUM (-3) + +static int read_trailer(fd, trail) + int fd; + struct exec_trailer * trail; +{ + char buffer[TRAILER_SIZE]; + + lseek(fd, (long) -TRAILER_SIZE, 2); + if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; + trail->code_size = read_size(buffer); + trail->data_size = read_size(buffer+4); + trail->symbol_size = read_size(buffer+8); + trail->debug_size = read_size(buffer+12); + if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) + return 0; + else + return BAD_MAGIC_NUM; +} + +int attempt_open(name, trail, do_open_script) + char ** name; + struct exec_trailer * trail; + int do_open_script; +{ + char * truename; + int fd; + int err; + char buf [2]; + + truename = searchpath(*name); + if (truename == 0) truename = *name; else *name = truename; + fd = open(truename, O_RDONLY | O_BINARY); + if (fd == -1) return FILE_NOT_FOUND; + if (!do_open_script){ + err = read (fd, buf, 2); + if (err < 2) { close(fd); return TRUNCATED_FILE; } + if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } + } + err = read_trailer(fd, trail); + if (err != 0) { close(fd); return err; } + return fd; +} + + +/* Command for loading the bytecode file */ +int CamlRunCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int fd; + struct exec_trailer trail; + struct longjmp_buffer raise_buf; + struct channel * chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " foo.cmo args\"", (char *) NULL); + return TCL_ERROR; + } + fd = attempt_open(&argv[1], &trail, 1); + + switch(fd) { + case FILE_NOT_FOUND: + fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); + break; + case TRUNCATED_FILE: + case BAD_MAGIC_NUM: + fatal_error_arg( + "Fatal error: the file %s is not a bytecode executable file\n", + argv[1]); + break; + } + + if (sigsetjmp(raise_buf.buf, 1) == 0) { + + external_raise = &raise_buf; + + lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size + + trail.symbol_size + trail.debug_size), 2); + + code_size = trail.code_size; + start_code = (code_t) caml_stat_alloc(code_size); + if (read(fd, (char *) start_code, code_size) != code_size) + fatal_error("Fatal error: truncated bytecode file.\n"); + +#ifdef ARCH_BIG_ENDIAN + fixup_endianness(start_code, code_size); +#endif + + chan = open_descr(fd); + global_data = input_value(chan); + close_channel(chan); + /* Ensure that the globals are in the major heap. */ + oldify(global_data, &global_data); + + sys_init(argv + 1); + interprete(start_code, code_size); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", + String_val(Field(Field(exn_bucket, 0), 0))); + return TCL_ERROR; + } +} + +int CamlInvokeCmd(dummy + + + +/* Now the real Tk stuff */ +Tk_Window cltk_mainWindow; + +#define RCNAME ".camltkrc" +#define CAMLCB "camlcb" + +/* Initialisation of the dynamically loaded module */ +int Caml_Init(interp) + Tcl_Interp *interp; +{ + cltclinterp = interp; + /* Create the camlcallback command */ + Tcl_CreateCommand(cltclinterp, + CAMLCB, CamlCBCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); + + /* This is required by "unknown" and thus autoload */ + Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + /* Our hack for implementing break in callbacks */ + Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); + + /* Load the traditional rc file */ + { + char *home = getenv("HOME"); + if (home != NULL) { + char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2); + f[0]='\0'; + strcat(f, home); + strcat(f, "/"); + strcat(f, RCNAME); + if (0 == access(f,R_OK)) + if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { + caml_stat_free(f); + tk_error(Tcl_GetStringResult(cltclinterp)); + }; + caml_stat_free(f); + } + } + + /* Initialisations from caml_main */ + { + int verbose_init = 0, + percent_free_init = Percent_free_def; + long minor_heap_init = Minor_heap_def, + heap_chunk_init = Heap_chunk_def; + + /* Machine-dependent initialization of the floating-point hardware + so that it behaves as much as possible as specified in IEEE */ + init_ieee_floats(); + init_gc (minor_heap_init, heap_chunk_init, percent_free_init, + verbose_init); + init_stack(); + init_atoms(); + } +} diff --git a/support/cltkEval.c b/support/cltkEval.c new file mode 100644 index 0000000..87291e5 --- /dev/null +++ b/support/cltkEval.c @@ -0,0 +1,243 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include + +#include +#include +#include +#include +#include +#ifdef HAS_UNISTD +#include +#endif +#include "camltk.h" + +/* The Tcl interpretor */ +Tcl_Interp *cltclinterp = NULL; + +/* Copy a list of strings from the C heap to OCaml */ +value copy_string_list(int argc, char **argv) +{ + CAMLparam0(); + CAMLlocal3( res, oldres, str ); + int i; + oldres = Val_unit; + str = Val_unit; + + res = Val_int(0); /* [] */ + for (i = argc-1; i >= 0; i--) { + oldres = res; + str = tcl_string_to_caml(argv[i]); + res = caml_alloc(2, 0); + Field(res, 0) = str; + Field(res, 1) = oldres; + } + CAMLreturn(res); +} + +/* + * Calling Tcl from OCaml + * this version works on an arbitrary Tcl command, + * and does parsing and substitution + */ +CAMLprim value camltk_tcl_eval(value str) +{ + int code; + char *cmd = NULL; + + CheckInit(); + + /* Tcl_Eval may write to its argument, so we take a copy + * If the evaluation raises an OCaml exception, we have a space + * leak + */ + Tcl_ResetResult(cltclinterp); + cmd = caml_string_to_tcl(str); + code = Tcl_Eval(cltclinterp, cmd); + caml_stat_free(cmd); + + switch (code) { + case TCL_OK: + return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp)); + case TCL_ERROR: + tk_error(Tcl_GetStringResult(cltclinterp)); + default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ + tk_error("bad tcl result"); + } +} + +/* + * Calling Tcl from OCaml + * direct call, argument is TkArgs vect + type TkArgs = + TkToken of string + | TkTokenList of TkArgs list (* to be expanded *) + | TkQuote of TkArgs (* mapped to Tcl list *) + * NO PARSING, NO SUBSTITUTION + */ + +/* + * Compute the size of the argument (of type TkArgs). + * TkTokenList must be expanded, + * TkQuote count for one. + */ +int argv_size(value v) +{ + switch (Tag_val(v)) { + case 0: /* TkToken */ + return 1; + case 1: /* TkTokenList */ + { int n = 0; + value l; + for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) + n+=argv_size(Field(l,0)); + return n; + } + case 2: /* TkQuote */ + return 1; + default: + tk_error("argv_size: illegal tag"); + } +} + +/* Fill a preallocated vector arguments, doing expansion and all. + * Assumes Tcl will + * not tamper with our strings + * make copies if strings are "persistent" + */ +int fill_args (char **argv, int where, value v) +{ + value l; + + switch (Tag_val(v)) { + case 0: + argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by caml_stat_free */ + return (where + 1); + case 1: + for (l=Field(v,0); Is_block(l); l=Field(l,1)) + where = fill_args(argv,where,Field(l,0)); + return where; + case 2: + { char **tmpargv; + char *merged; + int i; + int size = argv_size(Field(v,0)); + tmpargv = (char **)caml_stat_alloc((size + 1) * sizeof(char *)); + fill_args(tmpargv,0,Field(v,0)); + tmpargv[size] = NULL; + merged = Tcl_Merge(size,(const char *const*)tmpargv); + for(i = 0; i= 8) + /* info.proc might be a NULL pointer + * We should probably attempt an Obj invocation, but the following quick + * hack is easier. + */ + if (info.proc == NULL) { + Tcl_DString buf; + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, argv[0], -1); + for (i=1; i= 0; i--) + argv[i+1] = argv[i]; + argv[0] = "unknown"; + result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv); + } else { /* ah, it isn't there at all */ + result = TCL_ERROR; + Tcl_AppendResult(cltclinterp, "Unknown command \"", + argv[0], "\"", NULL); + } + } + + /* Free the various things we allocated */ + for(i=0; i< size; i ++){ + caml_stat_free((char *) allocated[i]); + } + caml_stat_free((char *)argv); + caml_stat_free((char *)allocated); + + switch (result) { + case TCL_OK: + return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp)); + case TCL_ERROR: + tk_error(Tcl_GetStringResult(cltclinterp)); + default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ + tk_error("bad tcl result"); + } +} diff --git a/support/cltkEvent.c b/support/cltkEvent.c new file mode 100644 index 0000000..6ab2e6c --- /dev/null +++ b/support/cltkEvent.c @@ -0,0 +1,54 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include "camltk.h" + +CAMLprim value camltk_tk_mainloop(value unit) +{ + CheckInit(); + + if (cltk_slave_mode) return Val_unit; + + if (!signal_events) { + /* Initialise signal handling */ + signal_events = 1; + Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); + } + Tk_MainLoop(); + return Val_unit; +} + +/* Note: this HAS to be reported "as-is" in ML source */ +static int event_flag_table[] = { + TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, + TK_ALL_EVENTS +}; + +CAMLprim value camltk_dooneevent(value flags) +{ + int ret; + + CheckInit(); + + ret = Tk_DoOneEvent(caml_convert_flag_list(flags, event_flag_table)); + return Val_int(ret); +} diff --git a/support/cltkFile.c b/support/cltkFile.c new file mode 100644 index 0000000..47b1bcf --- /dev/null +++ b/support/cltkFile.c @@ -0,0 +1,154 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#ifdef _WIN32 +#include +#include +#include +#endif +#include +#include +#include +#include +#include "camltk.h" + +/* + * File descriptor callbacks + */ + +void FileProc(ClientData clientdata, int mask) +{ + caml_callback2(*handler_code,Val_int(clientdata),Val_int(0)); +} + +/* Map Unix.file_descr values to Tcl file handles */ + +#ifndef _WIN32 + +/* Under Unix, we use file handlers */ + +/* Map Unix.file_descr values to Tcl file handles (for tcl 7) + or Unix file descriptors (for tcl 8). */ + +#if (TCL_MAJOR_VERSION < 8) +static Tcl_File tcl_filehandle(value fd) +{ + return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); +} +#else +#define tcl_filehandle(fd) Int_val(fd) +#define Tcl_File int +#endif + +CAMLprim value camltk_add_file_input(value fd, value cbid) +{ + CheckInit(); + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, + FileProc, (ClientData)(Long_val(cbid))); + return Val_unit; +} + +/* We have to free the Tcl handle when we are finished using it (Tcl + * asks us to, and moreover it is probably dangerous to keep the same + * handle over two allocations of the same fd by the kernel). + * But we don't know when we are finished with the fd, so we free it + * in rem_file (it doesn't close the fd anyway). For fds for which we + * repeatedly add/rem, this will cause some overhead. + */ +CAMLprim value camltk_rem_file_input(value fd, value cbid) +{ + Tcl_File fh = tcl_filehandle(fd); + Tcl_DeleteFileHandler(fh); +#if (TCL_MAJOR_VERSION < 8) + Tcl_FreeFile(fh); +#endif + return Val_unit; +} + +CAMLprim value camltk_add_file_output(value fd, value cbid) +{ + CheckInit(); + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, + FileProc, (ClientData) (Long_val(cbid))); + return Val_unit; +} + +CAMLprim value camltk_rem_file_output(value fd, value cbid) +{ + Tcl_File fh = tcl_filehandle(fd); + Tcl_DeleteFileHandler(fh); +#if (TCL_MAJOR_VERSION < 8) + Tcl_FreeFile(fh); +#endif + return Val_unit; +} + +#else + +/* Under Win32, we go through the generic channel abstraction */ + +#define Handle_val(v) (*((HANDLE *) Data_custom_val(v))) + +/* Map Unix.file_descr values to Tcl channels */ + +static Tcl_Channel tcl_channel(value fd, int flags) +{ + HANDLE h = Handle_val(fd); + int optval, optsize; + + optsize = sizeof(optval); + if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, + (char *)&optval, &optsize) == 0) + return Tcl_MakeTcpClientChannel((ClientData) h); + else + return Tcl_MakeFileChannel((ClientData) h, flags); +} + +CAMLprim value camltk_add_file_input(value fd, value cbid) +{ + CheckInit(); + Tcl_CreateChannelHandler(tcl_channel(fd, TCL_READABLE), + TCL_READABLE, + FileProc, (ClientData) (Int_val(cbid))); + return Val_unit; +} + +CAMLprim value camltk_rem_file_input(value fd, value cbid) +{ + Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_READABLE), + FileProc, (ClientData) (Int_val(cbid))); + return Val_unit; +} + +CAMLprim value camltk_add_file_output(value fd, value cbid) +{ + CheckInit(); + Tcl_CreateChannelHandler(tcl_channel(fd, TCL_WRITABLE), + TCL_WRITABLE, + FileProc, (ClientData) (Int_val(cbid))); + return Val_unit; +} + +CAMLprim value camltk_rem_file_output(value fd, value cbid) +{ + Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_WRITABLE), + FileProc, (ClientData) (Int_val(cbid))); + return Val_unit; +} + +#endif diff --git a/support/cltkImg.c b/support/cltkImg.c new file mode 100644 index 0000000..e0f2291 --- /dev/null +++ b/support/cltkImg.c @@ -0,0 +1,120 @@ +/***********************************************************************/ +/* */ +/* 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 +#include +#include +#include +#include +#include +#include "camltk.h" + +/* + * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo + * image, and put it back in some (possibly other) image. + * TODO: other blits + * We use the same format of "internal" pixmap data as in Tk, that is + * 24 bits per pixel + */ + +CAMLprim value camltk_getimgdata (value imgname) /* ML */ +{ + CAMLparam1(imgname); + CAMLlocal1(res); + Tk_PhotoHandle ph; + Tk_PhotoImageBlock pib; + int code,size; + +#if (TK_MAJOR_VERSION < 8) + if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) + tk_error("no such image"); +#else + if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) + tk_error("no such image"); +#endif + + code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */ + (void) code; + size = pib.width * pib.height * pib.pixelSize; + res = caml_alloc_string(size); + + /* no holes, default format ? */ + if ((pib.pixelSize == 3) && + (pib.pitch == (pib.width * pib.pixelSize)) && + (pib.offset[0] == 0) && + (pib.offset[1] == 1) && + (pib.offset[2] == 2)) { + memcpy(pib.pixelPtr, String_val(res),size); + CAMLreturn(res); + } else { + int y; /* varies from 0 to height - 1 */ + int yoffs = 0; /* byte offset of line in src */ + int yidx = 0; /* byte offset of line in dst */ + for (y=0; y= 5 || TK_MAJOR_VERSION > 8) + NULL, +#endif +ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h) +#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) + , TK_PHOTO_COMPOSITE_SET +#endif + ); + return Val_int(0); +} + +CAMLprim value camltk_setimgdata_bytecode(argv,argn) + value *argv; + int argn; +{ + return camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], + argv[4], argv[5]); +} diff --git a/support/cltkMain.c b/support/cltkMain.c new file mode 100644 index 0000000..9d65e11 --- /dev/null +++ b/support/cltkMain.c @@ -0,0 +1,181 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef HAS_UNISTD +#include /* for R_OK */ +#endif +#include "camltk.h" + +#ifndef R_OK +#define R_OK 4 +#endif + +/* + * Dealing with signals: when a signal handler is defined in OCaml, + * the actual execution of the signal handler upon reception of the + * signal is delayed until we are sure we are out of the GC. + * If a signal occurs during the MainLoop, we would have to wait + * the next event for the handler to be invoked. + * The following function will invoke a pending signal handler if any, + * and we put in on a regular timer. + */ + +#define SIGNAL_INTERVAL 300 + +int signal_events = 0; /* do we have a pending timer */ + +void invoke_pending_caml_signals (ClientData clientdata) +{ + signal_events = 0; + caml_enter_blocking_section(); /* triggers signal handling */ + /* Rearm timer */ + Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); + signal_events = 1; + caml_leave_blocking_section(); +} + +/* Now the real Tk stuff */ + +Tk_Window cltk_mainWindow; + + +/* In slave mode, the interpreter *already* exists */ +int cltk_slave_mode = 0; + +/* Initialisation, based on tkMain.c */ +CAMLprim value camltk_opentk(value argv) +{ + CAMLparam1(argv); + CAMLlocal1(tmp); + char *argv0; + + /* argv must contain argv[0], the application command name */ + tmp = Val_unit; + + if ( argv == Val_int(0) ){ + caml_failwith("camltk_opentk: argv is empty"); + } + argv0 = String_val( Field( argv, 0 ) ); + + if (!cltk_slave_mode) { + /* Create an interpreter, dies if error */ +#if TCL_MAJOR_VERSION >= 8 + Tcl_FindExecutable(String_val(argv0)); +#endif + cltclinterp = Tcl_CreateInterp(); + { + /* Register cltclinterp for use in other related extensions */ + value *interp = caml_named_value("cltclinterp"); + if (interp != NULL) + Store_field(*interp,0,caml_copy_nativeint((intnat)cltclinterp)); + } + + if (Tcl_Init(cltclinterp) != TCL_OK) + tk_error(Tcl_GetStringResult(cltclinterp)); + Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); + + { /* Sets argv */ + int argc = 0; + + tmp = Field(argv, 1); /* starts from argv[1] */ + while ( tmp != Val_int(0) ) { + argc++; + tmp = Field(tmp, 1); + } + + if( argc != 0 ){ + int i; + char *args; + char **tkargv; + char argcstr[256]; /* string of argc */ + + tkargv = (char**)caml_stat_alloc(sizeof( char* ) * argc ); + tmp = Field(argv, 1); /* starts from argv[1] */ + i = 0; + + while ( tmp != Val_int(0) ) { + tkargv[i] = String_val(Field(tmp, 0)); + tmp = Field(tmp, 1); + i++; + } + + sprintf( argcstr, "%d", argc ); + Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); + args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */ + Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); + Tcl_Free(args); + caml_stat_free( tkargv ); + } + } + if (Tk_Init(cltclinterp) != TCL_OK) + tk_error(Tcl_GetStringResult(cltclinterp)); + + /* Retrieve the main window */ + cltk_mainWindow = Tk_MainWindow(cltclinterp); + + if (NULL == cltk_mainWindow) + tk_error(Tcl_GetStringResult(cltclinterp)); + + Tk_GeometryRequest(cltk_mainWindow,200,200); + } + + /* Create the camlcallback command */ + Tcl_CreateCommand(cltclinterp, + CAMLCB, CamlCBCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); + + /* This is required by "unknown" and thus autoload */ + Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + /* Our hack for implementing break in callbacks */ + Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); + + /* Load the traditional rc file */ + { + char *home = getenv("HOME"); + if (home != NULL) { + char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2); + f[0]='\0'; + strcat(f, home); + strcat(f, "/"); + strcat(f, RCNAME); + if (0 == access(f,R_OK)) + if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { + caml_stat_free(f); + tk_error(Tcl_GetStringResult(cltclinterp)); + }; + caml_stat_free(f); + } + } + + CAMLreturn(Val_unit); +} + +CAMLprim value camltk_finalize(value unit) /* ML */ +{ + Tcl_Finalize(); + return Val_unit; +} diff --git a/support/cltkMisc.c b/support/cltkMisc.c new file mode 100644 index 0000000..8d6b5f2 --- /dev/null +++ b/support/cltkMisc.c @@ -0,0 +1,62 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include +#include "camltk.h" + +/* Parsing results */ +CAMLprim value camltk_splitlist (value v) +{ + int argc; + char **argv; + int result; + char *utf; + + CheckInit(); + + utf = caml_string_to_tcl(v); + /* argv is allocated by Tcl, to be freed by us */ + result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv); + switch(result) { + case TCL_OK: + { value res = copy_string_list(argc,argv); + Tcl_Free((char *)argv); /* only one large block was allocated */ + /* argv points into utf: utf must be freed after argv are freed */ + caml_stat_free( utf ); + return res; + } + case TCL_ERROR: + default: + caml_stat_free( utf ); + tk_error(Tcl_GetStringResult(cltclinterp)); + } +} + +/* Copy an OCaml string to the C heap. Should deallocate with caml_stat_free */ +char *string_to_c(value s) +{ + int l = caml_string_length(s); + char *res = caml_stat_alloc(l + 1); + memmove (res, String_val (s), l); + res[l] = '\0'; + return res; +} diff --git a/support/cltkTimer.c b/support/cltkTimer.c new file mode 100644 index 0000000..2022d78 --- /dev/null +++ b/support/cltkTimer.c @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include "camltk.h" + + +/* Basically the same thing as FileProc */ +void TimerProc (ClientData clientdata) +{ + caml_callback2(*handler_code,Val_long(clientdata),Val_int(0)); +} + +CAMLprim value camltk_add_timer(value milli, value cbid) +{ + CheckInit(); + /* look at tkEvent.c , Tk_Token is an int */ + return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, + (ClientData) (Long_val(cbid))))); +} + +CAMLprim value camltk_rem_timer(value token) +{ + Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token)); + return Val_unit; +} diff --git a/support/cltkUtf.c b/support/cltkUtf.c new file mode 100644 index 0000000..d4f86c1 --- /dev/null +++ b/support/cltkUtf.c @@ -0,0 +1,89 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include + +#include +#include +#include +#include +#include +#ifdef HAS_UNISTD +#include +#endif +#include "camltk.h" + +#if (TCL_MAJOR_VERSION > 8 || \ + (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */ +# define UTFCONVERSION +#endif + +#ifdef UTFCONVERSION + +char *external_to_utf( const char *str ){ + char *res; + Tcl_DString dstr; + int length; + + Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr); + length = Tcl_DStringLength(&dstr); + res = caml_stat_alloc(length + 1); + memmove( res, Tcl_DStringValue(&dstr), length+1); + Tcl_DStringFree(&dstr); + + return res; +} + +char *utf_to_external( const char *str ){ + char *res; + Tcl_DString dstr; + int length; + + Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr); + length = Tcl_DStringLength(&dstr); + res = caml_stat_alloc(length + 1); + memmove( res, Tcl_DStringValue(&dstr), length+1); + Tcl_DStringFree(&dstr); + + return res; +} + +char *caml_string_to_tcl( value s ) +{ + return external_to_utf( String_val(s) ); +} + +value tcl_string_to_caml( const char *s ) +{ + CAMLparam0(); + CAMLlocal1(res); + char *str; + + str = utf_to_external( s ); + res = caml_copy_string(str); + caml_stat_free(str); + CAMLreturn(res); +} + +#else + +char *caml_string_to_tcl(value s){ return string_to_c(s); } +value tcl_string_to_caml(char *s){ return caml_copy_string(s); } + +#endif diff --git a/support/cltkVar.c b/support/cltkVar.c new file mode 100644 index 0000000..09276fe --- /dev/null +++ b/support/cltkVar.c @@ -0,0 +1,128 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +/* Alternative to tkwait variable */ +#include +#include +#include +#include +#include +#include +#include +#include "camltk.h" + +CAMLprim value camltk_getvar(value var) +{ + char *s; + char *stable_var = NULL; + CheckInit(); + + stable_var = string_to_c(var); + s = (char *)Tcl_GetVar(cltclinterp,stable_var, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + caml_stat_free(stable_var); + + if (s == NULL) + tk_error(Tcl_GetStringResult(cltclinterp)); + else + return(tcl_string_to_caml(s)); +} + +CAMLprim value camltk_setvar(value var, value contents) +{ + char *s; + char *stable_var = NULL; + char *utf_contents; + CheckInit(); + + /* SetVar makes a copy of the contents. */ + /* In case we have write traces in OCaml, it's better to make sure that + var doesn't move... */ + stable_var = string_to_c(var); + utf_contents = caml_string_to_tcl(contents); + s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + caml_stat_free(stable_var); + if( s == utf_contents ){ + tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); + } + caml_stat_free(utf_contents); + + if (s == NULL) + tk_error(Tcl_GetStringResult(cltclinterp)); + else + return(Val_unit); +} + + +/* The appropriate type is +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *part1, char *part2, int flags)); + */ +static char * tracevar(clientdata, interp, name1, name2, flags) + ClientData clientdata; + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + Tcl_UntraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, clientdata); + caml_callback2(*handler_code,Val_int(clientdata),Val_unit); + return (char *)NULL; +} + +/* Sets up a callback upon modification of a variable */ +CAMLprim value camltk_trace_var(value var, value cbid) +{ + char *cvar = NULL; + + CheckInit(); + /* Make a copy of var, since Tcl will modify it in place, and we + * don't trust that much what it will do here + */ + cvar = string_to_c(var); + if (Tcl_TraceVar(cltclinterp, cvar, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, + (ClientData) (Long_val(cbid))) + != TCL_OK) { + caml_stat_free(cvar); + tk_error(Tcl_GetStringResult(cltclinterp)); + }; + caml_stat_free(cvar); + return Val_unit; +} + +CAMLprim value camltk_untrace_var(value var, value cbid) +{ + char *cvar = NULL; + + CheckInit(); + /* Make a copy of var, since Tcl will modify it in place, and we + * don't trust that much what it will do here + */ + cvar = string_to_c(var); + Tcl_UntraceVar(cltclinterp, cvar, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, + (ClientData) (Long_val(cbid))); + caml_stat_free(cvar); + return Val_unit; +} diff --git a/support/cltkWait.c b/support/cltkWait.c new file mode 100644 index 0000000..1258bd8 --- /dev/null +++ b/support/cltkWait.c @@ -0,0 +1,102 @@ +/***********************************************************************/ +/* */ +/* 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$ */ + +#include +#include +#include +#include +#include +#include "camltk.h" + +/* The following are replacements for + tkwait visibility + tkwait window + in the case where we use threads (tkwait internally calls an event loop, + and thus prevents thread scheduling from taking place). + + Instead, one should set up a callback, wait for a signal, and signal + from inside the callback +*/ + +static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +/* For the other handlers, we need a bit more data */ +struct WinCBData { + int cbid; + Tk_Window win; +}; + +static void WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; /* Information about event (not used). */ +{ + struct WinCBData *vis = clientData; + value cbid = Val_int(vis->cbid); + + Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, + WaitVisibilityProc, clientData); + + caml_stat_free((char *)vis); + caml_callback2(*handler_code,cbid,Val_int(0)); +} + +/* Sets up a callback upon Visibility of a window */ +CAMLprim value camltk_wait_vis(value win, value cbid) +{ + struct WinCBData *vis = + (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData)); + vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); + if (vis -> win == NULL) { + caml_stat_free((char *)vis); + tk_error(Tcl_GetStringResult(cltclinterp)); + }; + vis->cbid = Int_val(cbid); + Tk_CreateEventHandler(vis->win, VisibilityChangeMask, + WaitVisibilityProc, (ClientData) vis); + return Val_unit; +} + +static void WaitWindowProc(ClientData clientData, XEvent *eventPtr) +{ + if (eventPtr->type == DestroyNotify) { + struct WinCBData *vis = clientData; + value cbid = Val_int(vis->cbid); + caml_stat_free((char *)clientData); + /* The handler is destroyed by Tk itself */ + caml_callback2(*handler_code,cbid,Val_int(0)); + } +} + +/* Sets up a callback upon window destruction */ +CAMLprim value camltk_wait_des(value win, value cbid) +{ + struct WinCBData *vis = + (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData)); + vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); + if (vis -> win == NULL) { + caml_stat_free((char *)vis); + tk_error(Tcl_GetStringResult(cltclinterp)); + }; + vis->cbid = Int_val(cbid); + Tk_CreateEventHandler(vis->win, StructureNotifyMask, + WaitWindowProc, (ClientData) vis); + return Val_unit; +} diff --git a/support/fileevent.ml b/support/fileevent.ml new file mode 100644 index 0000000..7285a47 --- /dev/null +++ b/support/fileevent.ml @@ -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 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 Unix +open Protocol + +external add_file_input : file_descr -> cbid -> unit + = "camltk_add_file_input" +external rem_file_input : file_descr -> cbid -> unit + = "camltk_rem_file_input" +external add_file_output : file_descr -> cbid -> unit + = "camltk_add_file_output" +external rem_file_output : file_descr -> cbid -> unit + = "camltk_rem_file_output" + +(* File input handlers *) + +let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) + +let add_fileinput ~fd ~callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table id (fun _ -> f()); + Hashtbl.add fd_table (fd, 'r') id; + if !Protocol.debug then begin + Protocol.prerr_cbid id; prerr_endline " for fileinput" + end; + add_file_input fd id + +let remove_fileinput ~fd = + try + let id = Hashtbl.find fd_table (fd, 'r') in + clear_callback id; + Hashtbl.remove fd_table (fd, 'r'); + if !Protocol.debug then begin + prerr_string "clear "; + Protocol.prerr_cbid id; + prerr_endline " for fileinput" + end; + rem_file_input fd id + with + Not_found -> () + +let add_fileoutput ~fd ~callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table id (fun _ -> f()); + Hashtbl.add fd_table (fd, 'w') id; + if !Protocol.debug then begin + Protocol.prerr_cbid id; prerr_endline " for fileoutput" + end; + add_file_output fd id + +let remove_fileoutput ~fd = + try + let id = Hashtbl.find fd_table (fd, 'w') in + clear_callback id; + Hashtbl.remove fd_table (fd, 'w'); + if !Protocol.debug then begin + prerr_string "clear "; + Protocol.prerr_cbid id; + prerr_endline " for fileoutput" + end; + rem_file_output fd id + with + Not_found -> () diff --git a/support/fileevent.mli b/support/fileevent.mli new file mode 100644 index 0000000..f5468ca --- /dev/null +++ b/support/fileevent.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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 Unix + +val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit +val remove_fileinput: fd:file_descr -> unit +val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit +val remove_fileoutput: fd:file_descr -> unit + (* see [tk] module *) diff --git a/support/liblabltk.clib b/support/liblabltk.clib new file mode 100644 index 0000000..0a127dc --- /dev/null +++ b/support/liblabltk.clib @@ -0,0 +1,2 @@ +cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o +cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o diff --git a/support/native.itarget b/support/native.itarget new file mode 100644 index 0000000..2d2ef8d --- /dev/null +++ b/support/native.itarget @@ -0,0 +1,3 @@ +support.cmx rawwidget.cmx widget.cmx protocol.cmx +textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx +tkthread.cmx diff --git a/support/protocol.ml b/support/protocol.ml new file mode 100644 index 0000000..a61905d --- /dev/null +++ b/support/protocol.ml @@ -0,0 +1,274 @@ +(***********************************************************************) +(* *) +(* 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 Widget + +type callback_buffer = string list + (* Buffer for reading callback arguments *) + +type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + +type cbid = int + +external opentk_low : string list -> unit + = "camltk_opentk" +external tcl_eval : string -> string + = "camltk_tcl_eval" +external tk_mainloop : unit -> unit + = "camltk_tk_mainloop" +external tcl_direct_eval : tkArgs array -> string + = "camltk_tcl_direct_eval" +external splitlist : string -> string list + = "camltk_splitlist" +external tkreturn : string -> unit + = "camltk_return" +external callback_init : unit -> unit + = "camltk_init" +external finalizeTk : unit -> unit + = "camltk_finalize" + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] (This is installed at + [install_cleanup ()] *) + +let tcl_command s = ignore (tcl_eval s);; + +type event_flag = + DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS +external do_one_event : event_flag list -> bool = "camltk_dooneevent" + +let do_pending () = while do_one_event [DONT_WAIT] do () done + +exception TkError of string + (* Raised by the communication functions *) +let () = Callback.register_exception "tkerror" (TkError "") + +let cltclinterp = ref Nativeint.zero + (* For use in other extensions *) +let () = Callback.register "cltclinterp" cltclinterp + +(* Debugging support *) +let debug = + ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true + with Not_found -> false) + +(* This is approximative, since we don't quote what needs to be quoted *) +let dump_args args = + let rec print_arg = function + TkToken s -> prerr_string s; prerr_string " " + | TkTokenList l -> List.iter print_arg l + | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " + in + Array.iter print_arg args; + prerr_newline() + +(* + * Evaluating Tcl code + * debugging support should not affect performances... + *) + +let tkEval args = + if !debug then dump_args args; + let res = tcl_direct_eval args in + if !debug then begin + prerr_string "->>"; + prerr_endline res + end; + res + +let tkCommand args = ignore (tkEval args) + +(* + * Callbacks + *) + +(* LablTk only *) +let cCAMLtoTKwidget w = + (* Widget.check_class w table; (* with subtyping, it is redundant *) *) + TkToken (Widget.name w) + +let cTKtoCAMLwidget = function + "" -> raise (Invalid_argument "cTKtoCAMLwidget") + | s -> Widget.get_atom s + +let callback_naming_table = + (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) + +let callback_memo_table = + (Hashtbl.create 401 : (any widget, int) Hashtbl.t) + +let new_function_id = + let counter = ref 0 in + function () -> incr counter; !counter + +let string_of_cbid = string_of_int + +(* Add a new callback, associated to widget w *) +(* The callback should be cleared when w is destroyed *) +let register_callback w ~callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table id f; + if (forget_type w) <> (forget_type Widget.dummy) then + Hashtbl.add callback_memo_table (forget_type w) id; + (string_of_cbid id) + +let clear_callback id = + Hashtbl.remove callback_naming_table id + +(* Clear callbacks associated to a given widget *) +let remove_callbacks w = + let w = forget_type w in + let cb_ids = Hashtbl.find_all callback_memo_table w in + List.iter clear_callback cb_ids; + for i = 1 to List.length cb_ids do + Hashtbl.remove callback_memo_table w + done + +(* Hand-coded callback for destroyed widgets + * This may be extended by the application, or by other layers of Camltk. + * Could use bind + of Tk, but I'd rather give an alternate mechanism so + * that hooks can be set up at load time (i.e. before openTk) + *) +let destroy_hooks = ref [] +let add_destroy_hook f = + destroy_hooks := f :: !destroy_hooks + +let _ = + add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) + +let install_cleanup () = + let call_destroy_hooks = function + [wname] -> + let w = cTKtoCAMLwidget wname in + List.iter (fun f -> f w) !destroy_hooks + | _ -> raise (TkError "bad cleanup callback") in + let fid = new_function_id () in + Hashtbl.add callback_naming_table fid call_destroy_hooks; + (* setup general destroy callback *) + tcl_command ("bind all {camlcb " ^ (string_of_cbid fid) ^" %W}"); + at_exit finalizeTk + +let prerr_cbid id = + prerr_string "camlcb "; prerr_int id + +(* The callback dispatch function *) +let dispatch_callback id args = + if !debug then begin + prerr_cbid id; + List.iter (fun x -> prerr_string " "; prerr_string x) args; + prerr_newline() + end; + (Hashtbl.find callback_naming_table id) args; + if !debug then prerr_endline "<<-" + +let protected_dispatch id args = + try + dispatch_callback id args + with e -> + Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); + flush stderr + +let _ = Callback.register "camlcb" protected_dispatch + +(* Make sure the C variables are initialised *) +let _ = callback_init () + +(* Different version of initialisation functions *) +let default_display_name = ref "" +let default_display () = !default_display_name + +let camltk_argv = ref [] + +(* options for Arg.parse *) +let keywords = [ + "-display", Arg.String (fun s -> + camltk_argv := "-display" :: s :: !camltk_argv), + " : X server to contact (CamlTk)"; + "-colormap", Arg.String (fun s -> + camltk_argv := "-colormap" :: s :: !camltk_argv), + " : colormap to use (CamlTk)"; + "-geometry", Arg.String (fun s -> + camltk_argv := "-geometry" :: s :: !camltk_argv), + " : size and position (CamlTk)"; + "-name", Arg.String (fun s -> + camltk_argv := "-name" :: s :: !camltk_argv), + " : application class (CamlTk)"; + "-sync", Arg.Unit (fun () -> + camltk_argv := "-sync" :: !camltk_argv), + ": sync mode (CamlTk)"; + "-use", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + " : parent window id (CamlTk)"; + "-window", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + " : parent window id (CamlTk)"; + "-visual", Arg.String (fun s -> + camltk_argv := "-visual" :: s :: !camltk_argv), + " : visual to use (CamlTk)" ] + +let opentk_with_args argv (* = [argv1;..;argvn] *) = + (* argv must be command line for wish *) + let argv0 = Sys.argv.(0) in + let rec find_display = function + | "-display" :: s :: xs -> s + | "-colormap" :: s :: xs -> find_display xs + | "-geometry" :: s :: xs -> find_display xs + | "-name" :: s :: xs -> find_display xs + | "-sync" :: xs -> find_display xs + | "-use" :: s :: xs -> find_display xs + | "-window" :: s :: xs -> find_display xs + | "-visual" :: s :: xs -> find_display xs + | "--" :: _ -> "" + | _ :: xs -> find_display xs + | [] -> "" + in + default_display_name := find_display argv; + opentk_low (argv0 :: argv); + install_cleanup(); + Widget.default_toplevel + +let opentk () = opentk_with_args !camltk_argv;; + +let openTkClass s = opentk_with_args ["-name"; s] +let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] + +(*JPF CAMLTK/LABLTK? *) +let openTk ?(display = "") ?(clas = "LablTk") () = + let dispopt = + match display with + | "" -> [] + | _ -> ["-display"; display] + in + opentk_with_args (dispopt @ ["-name"; clas]) + +(* Destroy all widgets, thus cleaning up table and exiting the loop *) +let closeTk () = + tcl_command "destroy ." + +let mainLoop = + tk_mainloop + + +(* [register tclname f] makes [f] available from Tcl with + name [tclname] *) +let register tclname ~callback = + let s = register_callback Widget.default_toplevel ~callback in + tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" + tclname s) diff --git a/support/protocol.mli b/support/protocol.mli new file mode 100644 index 0000000..1ce6718 --- /dev/null +++ b/support/protocol.mli @@ -0,0 +1,124 @@ +(***********************************************************************) +(* *) +(* 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 Widget + +(* Lower level interface *) +exception TkError of string + (* Raised by the communication functions *) + +val debug : bool ref + (* When set to true, displays approximation of intermediate Tcl code *) + +type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + + +(* Misc *) +external splitlist : string -> string list + = "camltk_splitlist" + +val add_destroy_hook : (any widget -> unit) -> unit + + +(* Opening, closing, and mainloop *) +val default_display : unit -> string + +val opentk : unit -> toplevel widget + (* The basic initialization function. *) + +val keywords : (string * Arg.spec * string) list + (* Command line parsing specification for Arg.parse, which contains + the standard Tcl/Tk command line options such as "-display" and "-name". + Add [keywords] to a [Arg.parse] call, then call [opentk]. + Then [opentk] can make use of these command line options + to initiate applications. *) + +val opentk_with_args : string list -> toplevel widget + (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk + applications. [opentk_with_args argv] initializes Tcl/Tk with + the command line options given by [argv] *) + +val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget + (* [openTk ~display:display ~clas:clas ()] is equivalent to + [opentk_with_args ["-display"; display; "-name"; clas]] *) + +(* Legacy opentk functions *) +val openTkClass: string -> toplevel widget + (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) +val openTkDisplayClass: string -> string -> toplevel widget + (* [openTkDisplayClass disp class] is equivalent to + [opentk ["-display"; disp; "-name"; class]] *) + +val closeTk : unit -> unit +val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] *) + +val mainLoop : unit -> unit + (* Start the event loop *) + +type event_flag = + DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS +val do_one_event : event_flag list -> bool + (* Process a single event *) +val do_pending : unit -> unit + (* Process all pending events, without waiting. + This lets you use Tk from the toplevel, for instance. *) + + +(* Direct evaluation of tcl code *) +val tkEval : tkArgs array -> string + +val tkCommand : tkArgs array -> unit + +(* Returning a value from a Tcl callback *) +val tkreturn: string -> unit + + +(* Callbacks: this is private *) + +type cbid + +type callback_buffer = string list + (* Buffer for reading callback arguments *) + +val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t +val callback_memo_table : (any widget, cbid) Hashtbl.t + (* Exported for debug purposes only. Don't use them unless you + know what you are doing *) +val new_function_id : unit -> cbid +val string_of_cbid : cbid -> string +val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string + (* Callback support *) +val clear_callback : cbid -> unit + (* Remove a given callback from the table *) +val remove_callbacks : 'a widget -> unit + (* Clean up callbacks associated to widget. Must be used only when + the Destroy event is bind by the user and masks the default + Destroy event binding *) + +val cTKtoCAMLwidget : string -> any widget +val cCAMLtoTKwidget : 'a widget -> tkArgs + +val register : string -> callback:(callback_buffer -> unit) -> unit + +(*-*) +val prerr_cbid : cbid -> unit diff --git a/support/rawwidget.ml b/support/rawwidget.ml new file mode 100644 index 0000000..48d4a0c --- /dev/null +++ b/support/rawwidget.ml @@ -0,0 +1,176 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* + * Widgets + *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) + +(***************************************************) +(* Widgets *) +(* This 'a raw_widget will be 'a Widget.widget *) +(***************************************************) +type 'a raw_widget = + Untyped of string +| Typed of string * string + +type raw_any (* will be Widget.any *) +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel +and ttk_labelframe + +let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget) +let coe = forget_type + +(* table of widgets *) +let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t) + +let name = function + Untyped s -> s + | Typed (s,_) -> s + +(* Normally all widgets are known *) +(* this is a provision for send commands to external tk processes *) +let known_class = function + Untyped _ -> "unknown" + | Typed (_,c) -> c + +(* This one is always created by opentk *) +let default_toplevel = + let wname = "." in + let w = Typed (wname, "toplevel") in + Hashtbl.add table wname w; + w + +(* Dummy widget to which global callbacks are associated *) +(* also passed around by camltotkoption when no widget in context *) +let dummy = + Untyped "dummy" + +let remove w = + Hashtbl.remove table (name w) + +(* Retype widgets returned from Tk *) +(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) +let get_atom s = + try + Hashtbl.find table s + with + Not_found -> Untyped s + +let naming_scheme = [ + "button", "b"; + "canvas", "ca"; + "checkbutton", "cb"; + "entry", "en"; + "frame", "f"; + "label", "l"; + "listbox", "li"; + "menu", "me"; + "menubutton", "mb"; + "message", "ms"; + "radiobutton", "rb"; + "scale", "sc"; + "scrollbar", "sb"; + "text", "t"; + "toplevel", "top" ] + + +let widget_any_table = List.map fst naming_scheme +(* subtypes *) +let widget_button_table = [ "button" ] +and widget_canvas_table = [ "canvas" ] +and widget_checkbutton_table = [ "checkbutton" ] +and widget_entry_table = [ "entry" ] +and widget_frame_table = [ "frame" ] +and widget_label_table = [ "label" ] +and widget_listbox_table = [ "listbox" ] +and widget_menu_table = [ "menu" ] +and widget_menubutton_table = [ "menubutton" ] +and widget_message_table = [ "message" ] +and widget_radiobutton_table = [ "radiobutton" ] +and widget_scale_table = [ "scale" ] +and widget_scrollbar_table = [ "scrollbar" ] +and widget_text_table = [ "text" ] +and widget_toplevel_table = [ "toplevel" ] +and widget_ttk_labelframe_table = [ "ttk::labelframe" ] + +let new_suffix clas n = + try + (List.assoc clas naming_scheme) ^ (string_of_int n) + with + Not_found -> "w" ^ (string_of_int n) + +(* The function called by generic creation *) +let counter = ref 0 +let new_atom ~parent ?name:nom clas = + let parentpath = name parent in + let path = + match nom with + None -> + incr counter; + if parentpath = "." + then "." ^ (new_suffix clas !counter) + else parentpath ^ "." ^ (new_suffix clas !counter) + | Some name -> + if parentpath = "." + then "." ^ name + else parentpath ^ "." ^ name + in + let w = Typed(path,clas) in + Hashtbl.add table path w; + w + +(* Just create a path. Only to check existence of widgets *) +(* Use with care *) +let atom ~parent ~name:pathcomp = + let parentpath = name parent in + let path = + if parentpath = "." + then "." ^ pathcomp + else parentpath ^ "." ^ pathcomp in + Untyped path + +(* LablTk: Redundant with subtyping of Widget, backward compatibility *) +let check_class w clas = + match w with + Untyped _ -> () (* assume run-time check by tk*) + | Typed(_,c) -> + if List.mem c clas then () + else raise (IllegalWidgetType c) + + +(* Checking membership of constructor in subtype table *) +let chk_sub errname table c = + if List.mem c table then () + else raise (Invalid_argument errname) diff --git a/support/rawwidget.mli b/support/rawwidget.mli new file mode 100644 index 0000000..c9ac895 --- /dev/null +++ b/support/rawwidget.mli @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Support for widget manipulations *) + +type 'a raw_widget + (* widget is an abstract type *) + +type raw_any +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel +and ttk_labelframe + +val forget_type : 'a raw_widget -> raw_any raw_widget +val coe : 'a raw_widget -> raw_any raw_widget + +val default_toplevel : toplevel raw_widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + +val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + +val name : 'a raw_widget -> string + (* [name w] returns the name (tk "path") of a widget *) + +(*--*) +(* The following functions are used internally. + There is normally no need for them in users programs + *) + +val known_class : 'a raw_widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + +val dummy : raw_any raw_widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + +val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget + +val get_atom : string -> raw_any raw_widget + (* [get_atom path] returns the widget with Tk path [path] *) + +val remove : 'a raw_widget -> unit + (* [remove w] removes widget from the internal tables *) + +(* Subtypes tables *) +val widget_any_table : string list +val widget_button_table : string list +val widget_canvas_table : string list +val widget_checkbutton_table : string list +val widget_entry_table : string list +val widget_frame_table : string list +val widget_label_table : string list +val widget_listbox_table : string list +val widget_menu_table : string list +val widget_menubutton_table : string list +val widget_message_table : string list +val widget_radiobutton_table : string list +val widget_scale_table : string list +val widget_scrollbar_table : string list +val widget_text_table : string list +val widget_toplevel_table : string list +val widget_ttk_labelframe_table : string list + +val chk_sub : string -> 'a list -> 'a -> unit +val check_class : 'a raw_widget -> string list -> unit + (* Widget subtyping *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) diff --git a/support/slave.ml b/support/slave.ml new file mode 100644 index 0000000..44349c0 --- /dev/null +++ b/support/slave.ml @@ -0,0 +1,51 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* The code run on initialisation, in addition to normal Tk code + * NOTE: camltk has not fully been initialised yet + *) +external tcl_eval : string -> string + = "camltk_tcl_eval" +let tcl_command s = ignore (tcl_eval s);; +open Printf + +let dynload args = + List.iter Dynlink.loadfile args + +(* Default modules include everything from +let default_modules = [] +*) + +(* [caml::run foo.cmo .. bar.cmo] is now available from Tcl *) +let init () = + Dynlink.init(); + (* Make it unsafe by default, with everything available *) + Dynlink.allow_unsafe_modules true; + Dynlink.add_interfaces [] []; + let s = register_callback Widget.dummy dynload in + tcl_command (sprintf "proc caml::run {l} {camlcb %s l}" s) + +let _ = + Printexc.print init () + +(* A typical master program would then + * caml::run foo.cmo + * # during initialisation, "foo" was registered as a tcl procedure + * foo x y z + * # proceed with some Tcl code calling foo + *) diff --git a/support/support.ml b/support/support.ml new file mode 100644 index 0000000..7d01996 --- /dev/null +++ b/support/support.ml @@ -0,0 +1,48 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Parsing results of Tcl *) +(* List.split a string according to char_sep predicate *) +let split_str ~pred:char_sep str = + let len = String.length str in + let rec skip_sep cur = + if cur >= len then cur + else if char_sep str.[cur] then skip_sep (succ cur) + else cur in + let rec split beg cur = + if cur >= len then + if beg = cur then [] + else [String.sub str beg (len - beg)] + else if char_sep str.[cur] + then + let nextw = skip_sep cur in + (String.sub str beg (cur - beg)) + ::(split nextw nextw) + else split beg (succ cur) in + let wstart = skip_sep 0 in + split wstart wstart + +(* Very easy hack for option type *) +let may f = function + Some x -> Some (f x) +| None -> None + +let maycons f x l = + match x with + Some x -> f x :: l + | None -> l diff --git a/support/support.mli b/support/support.mli new file mode 100644 index 0000000..fe30208 --- /dev/null +++ b/support/support.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +val split_str : pred:(char -> bool) -> string -> string list +val may : ('a -> 'b) -> 'a option -> 'b option +val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list diff --git a/support/textvariable.ml b/support/textvariable.ml new file mode 100644 index 0000000..bcd3a04 --- /dev/null +++ b/support/textvariable.ml @@ -0,0 +1,150 @@ +(***********************************************************************) +(* *) +(* 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 Protocol + +external internal_tracevar : string -> cbid -> unit + = "camltk_trace_var" +external internal_untracevar : string -> cbid -> unit + = "camltk_untrace_var" +external set : string -> string -> unit = "camltk_setvar" +external get : string -> string = "camltk_getvar" + + +type textVariable = string + +(* List of handles *) +let handles = Hashtbl.create 401 + +let add_handle var cbid = + try + let r = Hashtbl.find handles var in + r := cbid :: !r + with + Not_found -> + Hashtbl.add handles var (ref [cbid]) + +let exceptq x = + let rec ex acc = function + [] -> acc + | y::l when y == x -> ex acc l + | y::l -> ex (y::acc) l + in + ex [] + +let rem_handle var cbid = + try + let r = Hashtbl.find handles var in + match exceptq cbid !r with + [] -> Hashtbl.remove handles var + | remaining -> r := remaining + with + Not_found -> () + +(* Used when we "free" the variable (otherwise, old handlers would apply to + * new usage of the variable) + *) +let rem_all_handles var = + try + let r = Hashtbl.find handles var in + List.iter (internal_untracevar var) !r; + Hashtbl.remove handles var + with + Not_found -> () + + +(* Variable trace *) +let handle vname ~callback:f = + let id = new_function_id() in + let wrapped _ = + clear_callback id; + rem_handle vname id; + f() in + Hashtbl.add callback_naming_table id wrapped; + add_handle vname id; + if !Protocol.debug then begin + prerr_cbid id; prerr_string " for variable "; prerr_endline vname + end; + internal_tracevar vname id + +(* Avoid space leak (all variables are global in Tcl) *) +module StringSet = + Set.Make(struct type t = string let compare = compare end) +let freelist = ref (StringSet.empty) +let memo = Hashtbl.create 101 + +(* Added a variable v referenced by widget w *) +let add w v = + let w = Widget.forget_type w in + let r = + try Hashtbl.find memo w + with + Not_found -> + let r = ref StringSet.empty in + Hashtbl.add memo w r; + r in + r := StringSet.add v !r + +(* to be used with care ! *) +let free v = + rem_all_handles v; + freelist := StringSet.add v !freelist + +(* Free variables associated with a widget *) +let freew w = + try + let r = Hashtbl.find memo w in + StringSet.iter free !r; + Hashtbl.remove memo w + with + Not_found -> () + +let _ = add_destroy_hook freew + +(* Allocate a new variable *) +let counter = ref 0 +let getv () = + let v = + if StringSet.is_empty !freelist then begin + incr counter; + "camlv("^ string_of_int !counter ^")" + end + else + let v = StringSet.choose !freelist in + freelist := StringSet.remove v !freelist; + v in + set v ""; + v + +let create ?on: w () = + let v = getv() in + begin + match w with + Some w -> add w v + | None -> () + end; + v + +(* to be used with care ! *) +let free v = + freelist := StringSet.add v !freelist + +let cCAMLtoTKtextVariable s = TkToken s + +let name s = s +let coerce s = s diff --git a/support/textvariable.mli b/support/textvariable.mli new file mode 100644 index 0000000..f18f6cc --- /dev/null +++ b/support/textvariable.mli @@ -0,0 +1,45 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Support for Tk -textvariable option *) +open Widget +open Protocol + +type textVariable + (* TextVariable is an abstract type *) + +val create : ?on: 'a widget -> unit -> textVariable + (* Allocation of a textVariable with lifetime associated to widget + if a widget is specified *) +val set : textVariable -> string -> unit + (* Setting the val of a textVariable *) +val get : textVariable -> string + (* Reading the val of a textVariable *) +val name : textVariable -> string + (* Its tcl name *) + +val cCAMLtoTKtextVariable : textVariable -> tkArgs + (* Internal conversion function *) + +val handle : textVariable -> callback:(unit -> unit) -> unit + (* Callbacks on variable modifications *) + +val coerce : string -> textVariable + +(*-*) +val free : textVariable -> unit diff --git a/support/timer.ml b/support/timer.ml new file mode 100644 index 0000000..fd232bc --- /dev/null +++ b/support/timer.ml @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Timers *) +open Protocol + +type tkTimer = int + +external internal_add_timer : int -> cbid -> tkTimer + = "camltk_add_timer" +external internal_rem_timer : tkTimer -> unit + = "camltk_rem_timer" + +type t = tkTimer * cbid (* the token and the cb id *) + +(* A timer is used only once, so we must clean the callback table *) +let add ~ms ~callback = + if !Protocol.debug then begin + prerr_string "Timer.add "; flush stderr; + end; + let id = new_function_id () in + if !Protocol.debug then begin + prerr_string "id="; prerr_cbid id; flush stderr; + end; + let wrapped _ = + clear_callback id; (* do it first in case f raises exception *) + callback() in + Hashtbl.add callback_naming_table id wrapped; + let t = internal_add_timer ms id in + if !Protocol.debug then begin + prerr_endline " done" + end; + t,id + +let set ~ms ~callback = ignore (add ~ms ~callback);; + +(* If the timer has never been used, there is a small space leak in + the C heap, where a copy of id has been stored *) +let remove (tkTimer, id) = + internal_rem_timer tkTimer; + clear_callback id diff --git a/support/timer.mli b/support/timer.mli new file mode 100644 index 0000000..4b31668 --- /dev/null +++ b/support/timer.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +type t + +val add : ms:int -> callback:(unit -> unit) -> t +val set : ms:int -> callback:(unit -> unit) -> unit +val remove : t -> unit diff --git a/support/tkthread.ml b/support/tkthread.ml new file mode 100644 index 0000000..4ae3668 --- /dev/null +++ b/support/tkthread.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of OCaml *) +(* *) +(* Jacques Garrigue, Nagoya University Mathematics Dept. *) +(* *) +(* Copyright 2004 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$ *) + +let jobs : (unit -> unit) Queue.t = Queue.create () +let m = Mutex.create () +let with_jobs f = + Mutex.lock m; let y = f jobs in Mutex.unlock m; y + +let loop_id = ref None +let gui_safe () = + !loop_id = Some(Thread.id (Thread.self ())) +let running () = + !loop_id <> None + +let has_jobs () = not (with_jobs Queue.is_empty) +let n_jobs () = with_jobs Queue.length +let do_next_job () = with_jobs Queue.take () +let async j x = with_jobs (Queue.add (fun () -> j x)) +let sync f x = + if !loop_id = None then failwith "Tkthread.sync"; + if gui_safe () then f x else + let m = Mutex.create () in + let res = ref None in + Mutex.lock m; + let c = Condition.create () in + let j x = + let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m; + Condition.signal c + in + async j x; + Condition.wait c m; + match !res with Some y -> y | None -> assert false + +let rec job_timer () = + Timer.set ~ms:10 ~callback: + (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer()) + +let thread_main () = + try + loop_id := Some (Thread.id (Thread.self ())); + ignore (Protocol.openTk()); + job_timer(); + Protocol.mainLoop(); + loop_id := None; + with exn -> + loop_id := None; + raise exn + +let start () = + let th = Thread.create thread_main () in + loop_id := Some (Thread.id th); + th + +let top = Widget.default_toplevel diff --git a/support/tkthread.mli b/support/tkthread.mli new file mode 100644 index 0000000..692a336 --- /dev/null +++ b/support/tkthread.mli @@ -0,0 +1,51 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of OCaml *) +(* *) +(* Jacques Garrigue, Nagoya University Mathematics Dept. *) +(* *) +(* Copyright 2004 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$ *) + +(** Helper functions for using LablTk with threads. + To use, add tkthread.cmo or tkthread.cmx to your command line *) + +(** Start the main loop in a new GUI thread. Do not use recursively. *) +val start : unit -> Thread.t + +(** The actual function executed in the GUI thread *) +val thread_main : unit -> unit + +(** The toplevel widget (an alias of [Widget.default_toplevel]) *) +val top : Widget.toplevel Widget.widget + +(** Jobs are needed for Windows, as you cannot do GUI work from + another thread. This is apparently true on OSX/Aqua too. + And even using X11 some calls need to come from the main thread. + The basic idea is to either use async (if you don't need a result) + or sync whenever you call a Tk related function from another thread + (for instance with the threaded toplevel). + With sync, beware of deadlocks! +*) + +(** Add an asynchronous job (to do in the GUI thread) *) +val async : ('a -> unit) -> 'a -> unit + +(** Add a synchronous job (to do in the GUI thread). + Raise [Failure "Tkthread.sync"] if there is no such thread. *) +val sync : ('a -> 'b) -> 'a -> 'b + +(** Whether the current thread is the GUI thread. + Note that when using X11 it is generally safe to call + most Tk functions from other threads too. *) +val gui_safe : unit -> bool + +(** Whether a GUI thread is running *) +val running : unit -> bool diff --git a/support/tkwait.ml b/support/tkwait.ml new file mode 100644 index 0000000..34f6908 --- /dev/null +++ b/support/tkwait.ml @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +external internal_tracevis : string -> Protocol.cbid -> unit + = "camltk_wait_vis" +;; + +external internal_tracedestroy : string -> Protocol.cbid -> unit + = "camltk_wait_des" +;; diff --git a/support/widget.ml b/support/widget.ml new file mode 100644 index 0000000..083e4b9 --- /dev/null +++ b/support/widget.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Hack to permit having the different data type with the same name + [widget] for CamlTk and LablTk. *) +include Rawwidget +type 'a widget = 'a raw_widget +type any = raw_any diff --git a/support/widget.mli b/support/widget.mli new file mode 100644 index 0000000..9d85050 --- /dev/null +++ b/support/widget.mli @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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$ *) + +(* Support for widget manipulations *) + +type 'a widget = 'a Rawwidget.raw_widget + (* widget is an abstract type *) + +type any = Rawwidget.raw_any +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel +and ttk_labelframe + +val forget_type : 'a widget -> any widget +val coe : 'a widget -> any widget + +val default_toplevel : toplevel widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + +val atom : parent: 'a widget -> name: string -> any widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + +val name : 'a widget -> string + (* [name w] returns the name (tk "path") of a widget *) + +(*--*) +(* The following functions are used internally. + There is normally no need for them in users programs + *) + +val known_class : 'a widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + +val dummy : any widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + +val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget + +val get_atom : string -> any widget + (* [get_atom path] returns the widget with Tk path [path] *) + +val remove : 'a widget -> unit + (* [remove w] removes widget from the internal tables *) + +(* Subtypes tables *) +val widget_any_table : string list +val widget_button_table : string list +val widget_canvas_table : string list +val widget_checkbutton_table : string list +val widget_entry_table : string list +val widget_frame_table : string list +val widget_label_table : string list +val widget_listbox_table : string list +val widget_menu_table : string list +val widget_menubutton_table : string list +val widget_message_table : string list +val widget_radiobutton_table : string list +val widget_scale_table : string list +val widget_scrollbar_table : string list +val widget_text_table : string list +val widget_toplevel_table : string list +val widget_ttk_labelframe_table : string list + +val chk_sub : string -> 'a list -> 'a -> unit +val check_class : 'a widget -> string list -> unit + (* Widget subtyping *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*)