labltk-8.06.11/0002755000175000017500000000000014121053726012173 5ustar stephstephlabltk-8.06.11/camltk/0002755000175000017500000000000014121053726013446 5ustar stephstephlabltk-8.06.11/camltk/modules0000644000175000017500000000657114121053726015050 0ustar stephstephCWIDGETOBJS= 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 labltk-8.06.11/camltk/native.itarget0000644000175000017500000000073314121053726016316 0ustar stephstephcPlace.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 labltk-8.06.11/camltk/Makefile.gen.nt0000644000175000017500000000211614121053726016274 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/camltk/Makefile.nt0000644000175000017500000000211214121053726015520 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/camltk/.gitignore0000644000175000017500000000003414121053726015431 0ustar stephsteph*.ml *.mli labltktop labltk labltk-8.06.11/camltk/Makefile.gen0000644000175000017500000000502314121053726015654 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/camltk/byte.itarget0000644000175000017500000000075714121053726016001 0ustar stephstephcPlace.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 labltk-8.06.11/camltk/Makefile0000644000175000017500000000407214121053726015107 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/README.mlTk0000644000175000017500000001344214121053726013763 0ustar stephstephINTRODUCTION ============ 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] *) ... labltk-8.06.11/INSTALL0000644000175000017500000000621114121053726013222 0ustar stephsteph Installing LablTk from sources ------------------------------ PREREQUISITES * OCaml (>= 4.08) should be installed (4.13 for ocamlbrowser) * Tcl/Tk (>= 8.03) should be installed * ocamlfind is used if available 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 if you prefer to use the system Tcl/Tk, ./configure -tklibs "-framework Tcl -framework Tk" -tk-no-x11 -tkdefs "-I/Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tk.framework/Headers" 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 explicitly linking to X11. This is now the default. -tk-x11 Build LablTk using X11 libraries detected by ocaml. Only works with old versions ocaml (before 4.09) -verbose Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. Additionally, you may set the MAKE environment variable to set the command used to read the ocaml configuration Makefile. Default is "make". It should be compatible with GNU Make. 2- From the top directory do make all and optionally make opt You may replace "all" with "library" if you wish to compile only the library, without ocamlbrowser. 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 labltk-8.06.11/jpf/0002755000175000017500000000000014121053726012752 5ustar stephstephlabltk-8.06.11/jpf/balloon.ml0000644000175000017500000000723514121053726014737 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/shell.mli0000644000175000017500000000217314121053726014565 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/README0000644000175000017500000000010214121053726013621 0ustar stephstephThis is Jun Furuse's widget set library, Jpf. It uses LablTk API. labltk-8.06.11/jpf/shell.ml0000644000175000017500000000323414121053726014413 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/balloon.mli0000644000175000017500000000236214121053726015104 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/Makefile.nt0000644000175000017500000000211214121053726015024 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/jpf/jpf_font.mli0000644000175000017500000000403714121053726015264 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/jpflib.mllib0000644000175000017500000000004214121053726015233 0ustar stephstephFileselect Balloon Shell Jpf_font labltk-8.06.11/jpf/jpf_font.ml0000644000175000017500000001542114121053726015112 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/jpf/fileselect.mli0000644000175000017500000000316314121053726015575 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/jpf/balloontest.ml0000644000175000017500000000257214121053726015636 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/jpf/fileselect.ml0000644000175000017500000003135014121053726015423 0ustar stephsteph(***********************************************************************) (* *) (* 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; Unix.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; () labltk-8.06.11/jpf/Makefile0000644000175000017500000000570614121053726014420 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/builtin/0002755000175000017500000000000014121053726013641 5ustar stephstephlabltk-8.06.11/builtin/selection_own_set.ml0000644000175000017500000000111714121053726017714 0ustar stephsteph##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 labltk-8.06.11/builtin/report.ml0000644000175000017500000000073414121053726015510 0ustar stephsteph(* 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 labltk-8.06.11/builtin/image.mli0000644000175000017500000000014214121053726015421 0ustar stephsteph##ifdef CAMLTK val names : unit -> options list ##else val names : unit -> image list ##endif labltk-8.06.11/builtin/rawimg.ml0000644000175000017500000001073214121053726015462 0ustar stephstephexternal 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 *) ##ifdef CAMLTK 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) ##else let unsafe_copy pix_from pix_to = Bytes.unsafe_blit ~src:pix_from.pixmap_data ~src_pos:0 ~dst:pix_to.pixmap_data ~dst_pos:0 ~len:(Bytes.length pix_from.pixmap_data) ##endif (* 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 *) ##ifdef CAMLTK 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 ##else let unsafe_get_pixel pixmap x y = let pos = (y * pixmap.pixmap_width + x) * 3 in Bytes.sub_string pixmap.pixmap_data ~pos ~len:3 let unsafe_set_pixel pixmap x y pixel = let pos = (y * pixmap.pixmap_width + x) * 3 in Bytes.unsafe_blit ~src:(Bytes.unsafe_of_string pixel) ~src_pos:0 ~dst:pixmap.pixmap_data ~dst_pos:pos ~len:3 ##endif (* 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 labltk-8.06.11/builtin/LICENSE0000644000175000017500000000231414121053726014644 0ustar stephsteph(*************************************************************************) (* *) (* 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. labltk-8.06.11/builtin/builtin_palette.ml0000644000175000017500000000034414121053726017356 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_palette.ml0000644000175000017500000000104414121053726017525 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_index.ml0000644000175000017500000001075214121053726017204 0ustar stephsteph##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 labltk-8.06.11/builtin/selection_own_set.mli0000644000175000017500000000042314121053726020064 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_ScrollValue.ml0000644000175000017500000000261014121053726020322 0ustar stephsteph##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 ~sep:" " ("TKtoCAMLscrollValue"::l))) ;; ##endif labltk-8.06.11/builtin/text_tag_bind.ml0000644000175000017500000000326214121053726017007 0ustar stephsteph##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; let register f what = register_callback widget ~callback:(wrapeventInfo f what) in begin match action with | BindRemove -> TkToken "" | BindSet (what, f) -> let cbId = register f what in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register f what in TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ set BreakBindingsSequence 0") | BindExtend (what, f) -> let cbId = register 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 labltk-8.06.11/builtin/optionmenu.mli0000644000175000017500000000131414121053726016536 0ustar stephsteph##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 labltk-8.06.11/builtin/winfo_contained.ml0000644000175000017500000000022114121053726017332 0ustar stephsteph##ifdef CAMLTK let contained x y w = w = containing x y ;; ##else let contained ~x ~y w = forget_type w = containing ~x ~y () ;; ##endif labltk-8.06.11/builtin/builtini_bind.ml0000644000175000017500000000676114121053726017016 0ustar stephsteph##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 labltk-8.06.11/builtin/builtin_GetCursor.ml0000644000175000017500000000251614121053726017640 0ustar stephsteph(* 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 labltk-8.06.11/builtin/builtin_GetBitmap.ml0000644000175000017500000000057214121053726017577 0ustar stephsteph(* 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 labltk-8.06.11/builtin/builtin_ScrollValue.ml0000644000175000017500000000077214121053726020160 0ustar stephsteph##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 labltk-8.06.11/builtin/builtina_empty.ml0000644000175000017500000000000014121053726017204 0ustar stephstephlabltk-8.06.11/builtin/builtini_GetBitmap.ml0000644000175000017500000000104214121053726017741 0ustar stephsteph##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 labltk-8.06.11/builtin/builtin_index.ml0000644000175000017500000000332514121053726017031 0ustar stephsteph(* 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 labltk-8.06.11/builtin/winfo_contained.mli0000644000175000017500000000036114121053726017510 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_font.ml0000644000175000017500000000011214121053726017030 0ustar stephstephlet cCAMLtoTKfont (s : font) = TkToken s let cTKtoCAMLfont (s : font) = s labltk-8.06.11/builtin/builtin_GetPixel.ml0000644000175000017500000000062214121053726017440 0ustar stephsteph(* 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 labltk-8.06.11/builtin/builtini_bindtags.ml0000644000175000017500000000111714121053726017663 0ustar stephsteph##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 labltk-8.06.11/builtin/canvas_bind.mli0000644000175000017500000000047114121053726016613 0ustar stephsteph##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 labltk-8.06.11/builtin/builtin_text.ml0000644000175000017500000000222314121053726016702 0ustar stephsteph(* 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 labltk-8.06.11/builtin/builtini_GetPixel.ml0000644000175000017500000000264614121053726017621 0ustar stephsteph##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 labltk-8.06.11/builtin/selection_handle_set.ml0000644000175000017500000000204514121053726020345 0ustar stephsteph##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 ~callback:(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 labltk-8.06.11/builtin/image.ml0000644000175000017500000000144614121053726015260 0ustar stephsteph##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 ~f:cTKtoCAMLimage names ;; ##endif labltk-8.06.11/builtin/text_tag_bind.mli0000644000175000017500000000045414121053726017160 0ustar stephsteph##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 labltk-8.06.11/builtin/builtin_FilePattern.ml0000644000175000017500000000174714121053726020145 0ustar stephsteph(* File patterns *) (* type *) type filePattern = { typename : string; extensions : string list; mactypes : string list } (* /type *) ##ifdef CAMLTK 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)) ##else let cCAMLtoTKfilePattern fp = let typename = TkQuote (TkToken fp.typename) in let extensions = TkQuote (TkTokenList (List.map ~f:(fun x -> TkToken x) fp.extensions)) in let mactypes = match fp.mactypes with | [] -> [] | [s] -> [TkToken s] | _ -> [TkQuote (TkTokenList (List.map ~f:(fun x -> TkToken x) fp.mactypes))] in TkQuote (TkTokenList (typename :: extensions :: mactypes)) ##endif labltk-8.06.11/builtin/builtini_grab.ml0000644000175000017500000000011614121053726017001 0ustar stephstephlet cCAMLtoTKgrabGlobal x = if x then TkToken "-global" else TkTokenList [] labltk-8.06.11/builtin/builtin_bindtags.ml0000644000175000017500000000054614121053726017517 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_GetCursor.ml0000644000175000017500000000307714121053726020014 0ustar stephsteph##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 labltk-8.06.11/builtin/rawimg.mli0000644000175000017500000000201714121053726015630 0ustar stephsteph(* * 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 *) labltk-8.06.11/builtin/selection_handle_set.mli0000644000175000017500000000060414121053726020515 0ustar stephsteph##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 labltk-8.06.11/builtin/optionmenu.ml0000644000175000017500000000311314121053726016364 0ustar stephsteph##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 labltk-8.06.11/builtin/builtin_font.ml0000644000175000017500000000005214121053726016662 0ustar stephsteph(* type *) type font = string (* /type *) labltk-8.06.11/builtin/builtin_bind.ml0000644000175000017500000003011414121053726016632 0ustar stephsteph##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 labltk-8.06.11/builtin/canvas_bind.ml0000644000175000017500000000325514121053726016445 0ustar stephsteph##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 ~callback:(wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback widget ~callback:(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 ~callback:(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 labltk-8.06.11/builtin/builtin_grab.ml0000644000175000017500000000005614121053726016633 0ustar stephsteph(* type *) type grabGlobal = bool (* /type *) labltk-8.06.11/builtin/dialog.mli0000644000175000017500000000123614121053726015603 0ustar stephsteph##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 labltk-8.06.11/builtin/dialog.ml0000644000175000017500000000277114121053726015437 0ustar stephsteph##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 labltk-8.06.11/builtin/builtinf_GetPixel.ml0000644000175000017500000000064114121053726017607 0ustar stephsteph##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 labltk-8.06.11/builtin/builtini_text.ml0000644000175000017500000000325414121053726017060 0ustar stephstephlet 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 labltk-8.06.11/builtin/builtinf_bind.ml0000644000175000017500000001031214121053726016776 0ustar stephsteph##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 ~callback:(wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback widget ~callback:(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 ~callback:(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 ~callback:(wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback Widget.dummy ~callback:(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 ~callback:(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 labltk-8.06.11/config/0002755000175000017500000000000014121053726013440 5ustar stephstephlabltk-8.06.11/config/Makefile.mingw0000644000175000017500000000037414121053726016222 0ustar stephsteph# 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 labltk-8.06.11/config/auto-aux/0002755000175000017500000000000014121053726015203 5ustar stephstephlabltk-8.06.11/config/auto-aux/runtest0000755000175000017500000000206114121053726016632 0ustar stephsteph#!/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 labltk-8.06.11/config/auto-aux/hasgot0000755000175000017500000000303714121053726016417 0ustar stephsteph#!/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 (for f in $*; do echo "int $f();"; done echo "int 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 labltk-8.06.11/config/auto-aux/readconf.mk0000644000175000017500000000020014121053726017303 0ustar stephstephwhere = $(shell ocamlc -where) include $(where)/Makefile.config includes: @echo "$(X11_INCLUDES)" libs: @echo "$(X11_LINK)" labltk-8.06.11/config/auto-aux/tclversion.c0000644000175000017500000000225714121053726017543 0ustar stephsteph/***********************************************************************/ /* */ /* 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); } labltk-8.06.11/config/Makefile.mingw640000644000175000017500000000026314121053726016371 0ustar stephsteph# Configuration for Windows, Mingw compiler -- NOT SUPPORTED include C:/ocamlmgw64/lib/ocaml/Makefile.config INSTALLDIR=$(LIBDIR)/labltk INSTALLBINDIR=$(BINDIR) TK_DEFS= TK_LINK= labltk-8.06.11/config/Makefile.msvc640000644000175000017500000000026714121053726016224 0ustar stephsteph# Configuration for Windows, Visual C++ compiler -- NOT SUPPORTED include C:/ocamlms64/lib/ocaml/Makefile.config INSTALLDIR=$(LIBDIR)/labltk INSTALLBINDIR=$(BINDIR) TK_DEFS= TK_LINK= labltk-8.06.11/config/Makefile.msvc0000644000175000017500000000125514121053726016050 0ustar stephsteph# 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 labltk-8.06.11/configure0000755000175000017500000002205114121053726014100 0ustar stephsteph#! /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=no 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;; -tk-x11|--tk-x11) tk_x11=yes;; -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 "x$MAKE" = x; then MAKE=make fi if test $tk_x11 = no; then has_tk=true # May still need to read headers if test -z "$tk_defs"; then tk_x11_include="-I/usr/local/include" fi 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=//'` tk_x11_include=`$MAKE where=$where includes -f readconf.mk` tk_x11_libs=`$MAKE where=$where libs -f readconf.mk` 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 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/X11/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 $tk_x11_include" tcl_version=`sh ./runtest $tk_defs 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="" case "$tk_defs" 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" ;; -I/usr/X11/include*) tklibdir="/usr/X11/lib" ;; esac if test -n "$tklibdir"; then case "$system" in *bsd*) tk_libs="-R$tklibdir -L$tklibdir" ;; *) tk_libs="-L$tklibdir" ;; esac else tk_libs="" 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" "/usr/lib"; do if test $has_tk = false && 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 echo "TK_DEFS=$tk_defs" >> Makefile if test $tk_x11 = yes; then echo "TK_LINK=$tk_libs $tk_x11_libs" >> Makefile else 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 labltk-8.06.11/labltk/0002755000175000017500000000000014121053726013444 5ustar stephstephlabltk-8.06.11/labltk/modules0000644000175000017500000000512314121053726015036 0ustar stephstephWIDGETOBJS= 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 labltk-8.06.11/labltk/native.itarget0000644000175000017500000000065014121053726016312 0ustar stephstephplace.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 labltk-8.06.11/labltk/Makefile.gen.nt0000644000175000017500000000211614121053726016272 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/labltk/Makefile.nt0000644000175000017500000000211214121053726015516 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/labltk/.gitignore0000644000175000017500000000003414121053726015427 0ustar stephsteph*.ml *.mli labltktop labltk labltk-8.06.11/labltk/Makefile.gen0000644000175000017500000000502714121053726015656 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/labltk/byte.itarget0000644000175000017500000000067314121053726015774 0ustar stephstephplace.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 labltk-8.06.11/labltk/Makefile0000644000175000017500000000404414121053726015104 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/Makefile.gen.nt0000644000175000017500000000211614121053726015021 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/support/0002755000175000017500000000000014121053726013707 5ustar stephstephlabltk-8.06.11/support/timer.mli0000644000175000017500000000234714121053726015536 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/cltkWait.c0000644000175000017500000000730514121053726015640 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/support.ml0000644000175000017500000000363314121053726015760 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/support.mli0000644000175000017500000000241314121053726016124 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/camltkwrap.mli0000644000175000017500000002132514121053726016560 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/support/fileevent.mli0000644000175000017500000000256614121053726016402 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/support/textvariable.ml0000644000175000017500000000773214121053726016742 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/cltkDMain.c0000644000175000017500000001644714121053726015733 0ustar stephsteph/*************************************************************************/ /* */ /* 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(); } } labltk-8.06.11/support/cltkMisc.c0000644000175000017500000000416514121053726015630 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/native.itarget0000644000175000017500000000016714121053726016560 0ustar stephstephsupport.cmx rawwidget.cmx widget.cmx protocol.cmx textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx tkthread.cmx labltk-8.06.11/support/Makefile.nt0000644000175000017500000000211214121053726015761 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/support/META0000644000175000017500000000267314121053726014366 0ustar stephsteph# Specifications for the "labltk" library: requires = "" version = "8.06.6" 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 = "" package "jpf" ( description = "a 'file selector' and 'balloon help' support for labltk" requires = "unix,labltk" archive(byte) = "jpflib.cma" archive(native) = "jpflib.cmxa" ) package "frx" ( description = "Francois Rouaix's widget set library" requires = "unix,labltk" archive(byte) = "frxlib.cma" archive(native) = "frxlib.cmxa" ) labltk-8.06.11/support/tkwait.ml0000644000175000017500000000244014121053726015542 0ustar stephsteph(***********************************************************************) (* *) (* 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" ;; labltk-8.06.11/support/camltk.h0000644000175000017500000000515614121053726015340 0ustar stephsteph/*************************************************************************/ /* */ /* 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" labltk-8.06.11/support/rawwidget.mli0000644000175000017500000000752014121053726016411 0ustar stephsteph(***********************************************************************) (* *) (* 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*) labltk-8.06.11/support/.depend0000644000175000017500000000227114121053726015147 0ustar stephstephcamltkwrap.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 labltk-8.06.11/support/cltkEval.c0000644000175000017500000001610114121053726015615 0ustar stephsteph/***********************************************************************/ /* */ /* 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"); } } labltk-8.06.11/support/tkthread.ml0000644000175000017500000000440514121053726016050 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/widget.ml0000644000175000017500000000242114121053726015521 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/widget.mli0000644000175000017500000000744614121053726015706 0ustar stephsteph(***********************************************************************) (* *) (* 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*) labltk-8.06.11/support/liblabltk.clib0000644000175000017500000000017014121053726016476 0ustar stephstephcltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o labltk-8.06.11/support/timer.ml0000644000175000017500000000423414121053726015362 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/Makefile.common0000644000175000017500000000303114121053726016631 0ustar stephsteph####################################################################### # # # 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) $(WARNERR) CAMLCB=$(BINDIR)/ocamlc CAMLOPTB=$(BINDIR)/ocamlopt CAMLCOMP=$(CAMLC) -c $(WARNERR) 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 labltk-8.06.11/support/fileevent.ml0000644000175000017500000000544014121053726016223 0ustar stephsteph(***********************************************************************) (* *) (* 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 -> () labltk-8.06.11/support/cltkCaml.c0000644000175000017500000000553114121053726015607 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/camltkwrap.ml0000644000175000017500000000510314121053726016403 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/support/cltkUtf.c0000644000175000017500000000475014121053726015473 0ustar stephsteph/***********************************************************************/ /* */ /* 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 labltk-8.06.11/support/tkthread.mli0000644000175000017500000000441214121053726016217 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/textvariable.mli0000644000175000017500000000360214121053726017103 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/slave.ml0000644000175000017500000000402014121053726015345 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/support/cltkImg.c0000644000175000017500000001025414121053726015445 0ustar stephsteph/***********************************************************************/ /* */ /* 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]); } labltk-8.06.11/support/cltkTimer.c0000644000175000017500000000334714121053726016016 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/cltkFile.c0000644000175000017500000001101414121053726015603 0ustar stephsteph/***********************************************************************/ /* */ /* 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 labltk-8.06.11/support/protocol.ml0000644000175000017500000002144414121053726016105 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/support/rawwidget.ml0000644000175000017500000001215014121053726016233 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/support/byte.itarget0000644000175000017500000000016714121053726016235 0ustar stephstephsupport.cmo rawwidget.cmo widget.cmo protocol.cmo textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo tkthread.cmo labltk-8.06.11/support/cltkMain.c0000644000175000017500000001270514121053726015620 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/protocol.mli0000644000175000017500000001116714121053726016257 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/support/cltkEvent.c0000644000175000017500000000352714121053726016017 0ustar stephsteph/***********************************************************************/ /* */ /* 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); } labltk-8.06.11/support/cltkVar.c0000644000175000017500000001036414121053726015463 0ustar stephsteph/***********************************************************************/ /* */ /* 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; } labltk-8.06.11/support/Makefile0000644000175000017500000000671414121053726015355 0ustar stephsteph####################################################################### # # # 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 \ camltkwrap.cmi PUBX= $(PUBMLI:.mli=.cmx) camltkwrap.cmx 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 $(PUBX) \ -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 $(PUBX) $(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) $(OCAMLC_CFLAGS) $(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 labltk-8.06.11/Makefile.nt0000644000175000017500000000470214121053726014254 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/browser/0002755000175000017500000000000014121053726013656 5ustar stephstephlabltk-8.06.11/browser/jg_box.ml0000644000175000017500000000576614121053726015474 0ustar stephsteph(*************************************************************************) (* *) (* 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 *) labltk-8.06.11/browser/winmain.c0000644000175000017500000000311014121053726015455 0ustar stephsteph/*************************************************************************/ /* */ /* 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; } labltk-8.06.11/browser/jg_menu.ml0000644000175000017500000000372314121053726015637 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_completion.ml0000644000175000017500000000401014121053726017032 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/editor.ml0000644000175000017500000006156514121053726015511 0ustar stephsteph(*************************************************************************) (* *) (* 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] ~set:(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_local modname) Mp_present (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) () labltk-8.06.11/browser/shell.mli0000644000175000017500000000326214121053726015471 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_bind.ml0000644000175000017500000000253014121053726015602 0ustar stephsteph(*************************************************************************) (* *) (* 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) labltk-8.06.11/browser/searchpos.ml0000644000175000017500000010615214121053726016202 0ustar stephsteph(*************************************************************************) (* *) (* 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_local s | Papply _ -> Ident.create_local 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 fun prf -> match prf.prf_desc with 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: (fun pof -> match pof.pof_desc with 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 Stdlib.Option.iter (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_expr=id} -> let path, mt = lookup_module ~loc:Location.none id.txt env in begin match open_signature ovf path env with Ok env -> env | Error _ -> 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.ptyexn_constructor ~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_expr=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 _ -> () | Psig_typesubst _ | Psig_modsubst _ | Psig_modtypesubst _ -> () 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 (pm1, m2) -> begin match pm1 with | Unit -> () | Named (_, m1) -> search_pos_module ~pos ~env m1 end; 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_local "dummy", {mtd_type=None; mtd_attributes=[]; mtd_loc=Location.none; mtd_uid=Uid.internal_not_actually_unique}, Exported) let remove_prefix ~prefix s = let len1 = String.length prefix and len2 = String.length s in if len1 > len2 then None else if String.sub s ~pos:0 ~len:len1 <> prefix then None else Some (String.sub s ~pos:len1 ~len:(len2-len1)) 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 Ok env -> env | Error _ -> 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 path = Env.normalize_module_path None env path in let id = head_id path in let name = Ident.name id in let name = match remove_prefix ~prefix:"Stdlib__" name with | None -> name | Some suff -> suff in let file = Misc.find_in_path_uncap (Load_path.get_paths ()) (name ^ 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 ~error:false 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 _ | Persistent_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 = let modtype = find_module path env in match scrape_alias env modtype.md_type with Mty_signature sign -> !view_defined_ref (Searchid.longident_of_path path) ~env | _ -> let id = ident_of_path path ~default:"M" in view_signature_item [Sig_module (id, Mp_present, modtype, Trec_not, Exported)] ~path ~env and view_module_id id ~env = let path, _ = find_module_by_name 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).desc with 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, Exported); dummy_item; dummy_item] | Tvariant ({row_name = Some _} as row) -> let td = {td with type_manifest = Some( Btype.newgenty (Tvariant {row with row_name = None}))} in view_signature_item ~path ~env [Sig_type(ident_of_path path ~default:"t", td, Trec_first, Exported)] | _ -> raise Not_found with Not_found -> view_signature_item ~path ~env [Sig_type(ident_of_path path ~default:"t", td, Trec_first, Exported)] and view_type_id li ~env = let path, _ = find_type_by_name li env in view_type_decl path ~env and view_class_id li ~env = let path, cl = find_class_by_name li env in view_signature_item ~path ~env [Sig_class(ident_of_path path ~default:"c", cl, Trec_first, Exported); dummy_item; dummy_item; dummy_item] and view_cltype_id li ~env = let path, clt = find_cltype_by_name li env in view_signature_item ~path ~env [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first, Exported); dummy_item; dummy_item] and view_modtype_id li ~env = let path, td = find_modtype_by_name li env in view_signature_item ~path ~env [Sig_modtype(ident_of_path path ~default:"S", td, Exported)] 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_local 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; val_uid = Uid.internal_not_actually_unique}, Exported)] 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 -> fst (find_type_by_name lid env), "Type" | `Class -> fst (find_class_by_name lid env), "Class" | `Module -> fst (find_module_by_name lid env), "Module" | `Modtype -> fst (find_modtype_by_name lid env), "Module type" with Env.Error _ | Persistent_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 ~error:false 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, Exported)] 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, Exported)] 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 = []; cty_uid = Uid.internal_not_actually_unique } in view_signature_item ~path ~env [Sig_class(ident_of_path path ~default:"c", cld, Trec_first, Exported)] | `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; md_uid = Uid.internal_not_actually_unique} in view_signature_item ~path ~env [Sig_module(ident_of_path path ~default:"M", Mp_present, md, Trec_not, Exported)] 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 ~error:false 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) -> Stdlib.Option.iter (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_local "c"), cl.cl_type)) ~env:!start_env ~loc:cl.cl_loc end and search_case : 'a. pos:_ -> 'a case -> unit = fun ~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) -> Stdlib.Option.iter (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 | Texp_letop _ -> () | Texp_open (_, 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 : type a. pos:_ -> env:_ -> a general_pattern -> unit = fun ~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, _, _) | Tpat_lazy pat | Tpat_exception pat -> search_pos_pat pat ~pos ~env | Tpat_value pat -> search_pos_pat (pat :> pattern) ~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_local "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 | _ -> () (* | Partial_structure st -> search_pos_structure ~pos st | Partial_structure_item it -> search_pos_structure ~pos [it] | Partial_expression e -> search_pos_expr ~pos e | Partial_pattern (k, p) -> search_pos_pat ~pos ~env:p.pat_env p | Partial_class_expr c -> search_pos_class_expr ~pos c | Partial_signature sg -> search_pos_signature ~pos sg | Partial_signature_item si -> search_pos_signature ~pos [si] | Partial_module_type mt -> () *) 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 labltk-8.06.11/browser/jg_config.mli0000644000175000017500000000200014121053726016274 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/Makefile.shared0000644000175000017500000000455214121053726016567 0ustar stephstephinclude ../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: if test -f ocamlbrowser$(EXE); then \ cp ocamlbrowser$(EXE) $(INSTALLBINDIR); fi 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 labltk-8.06.11/browser/viewer.mli0000644000175000017500000000271214121053726015662 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/list2.ml0000644000175000017500000000216414121053726015246 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_memo.ml0000644000175000017500000000253114121053726015624 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/typecheck.ml0000644000175000017500000001461514121053726016174 0ustar stephsteph(*************************************************************************) (* *) (* 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 ~pos:0 ~len:9 = String.sub ast_magic ~pos:0 ~len: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; Clflags.color := Some Misc.Color.Never; 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, _names, env' = Typemod.type_structure !env pstr in txt.structure <- txt.structure @ str.str_items; txt.signature <- txt.signature @ sign; env := env' | Ptop_dir _ -> () end; let open Cmt2annot in let iter = iterator true ~scope:(Location.in_file txt.name) in List.iter ~f:(binary_part iter) (Cmt_format.get_saved_types ()); txt.type_info <- Stypes.get_info (); with Lexer.Error _ | Syntaxerr.Error _ | Typecore.Error _ | Typemod.Error _ | Typeclass.Error _ | Typedecl.Error _ | Typetexp.Error _ | Includemod.Error _ | Persistent_env.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) -> l | Syntaxerr.Error err -> Syntaxerr.location_of_error err | Typecore.Error (l, env, err) -> l | Typeclass.Error (l, env, err) -> l | Typedecl.Error (l, err) -> l | Typemod.Error (l, env, err) -> l | Typetexp.Error (l, env, err) -> l | Env.Error (Missing_module (l, _, _) | Illegal_value_name (l, _) | Lookup_error (l, _, _)) -> l | _ -> Location.none in begin match exn with | Cmi_format.Error err -> Cmi_format.report_error Format.std_formatter err | Ctype.Tags(l, l') -> Format.printf "In this program,@ variant constructors@ `%s and `%s@ %s.@." l l' "have same hash value" | Failure s -> Format.printf "%s.@." s | _ -> Location.report_exception Format.std_formatter exn end; 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 labltk-8.06.11/browser/jg_text.ml0000644000175000017500000001005114121053726015647 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_tk.ml0000644000175000017500000000240214121053726015302 0ustar stephsteph(*************************************************************************) (* *) (* 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" labltk-8.06.11/browser/dummyUnix.ml0000644000175000017500000000235114121053726016206 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/README0000644000175000017500000001475214121053726014545 0ustar stephsteph 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 labltk-8.06.11/browser/shell.ml0000644000175000017500000003201014121053726015311 0ustar stephsteph(*************************************************************************) (* *) (* 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 (Load_path.get_paths ()) ~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" ~set: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 (Load_path.get_paths ())) ~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) labltk-8.06.11/browser/searchpos.mli0000644000175000017500000000621414121053726016351 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jglib.mllib0000644000175000017500000000017314121053726015765 0ustar stephstephJg_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 labltk-8.06.11/browser/editor.mli0000644000175000017500000000213614121053726015647 0ustar stephsteph(*************************************************************************) (* *) (* 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 *) labltk-8.06.11/browser/jg_button.ml0000644000175000017500000000233514121053726016204 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/help.txt0000644000175000017500000001447114121053726015354 0ustar stephsteph 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 labltk-8.06.11/browser/setpath.mli0000644000175000017500000000233614121053726016033 0ustar stephsteph(*************************************************************************) (* *) (* 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 *) labltk-8.06.11/browser/useunix.mli0000644000175000017500000000235614121053726016065 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/Makefile.nt0000644000175000017500000000242614121053726015740 0ustar stephsteph######################################################################### # # # 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 labltk-8.06.11/browser/jg_message.mli0000644000175000017500000000256614121053726016474 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/setpath.ml0000644000175000017500000001352414121053726015663 0ustar stephsteph(*************************************************************************) (* *) (* 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 = Load_path.init l; exec_update_hooks (); Env.reset_cache () let get_load_path () = Load_path.get_paths () 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:(Load_path.get_paths ()); 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);; labltk-8.06.11/browser/lexical.mli0000644000175000017500000000214514121053726016002 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_entry.ml0000644000175000017500000000243214121053726016030 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/mytypes.mli0000644000175000017500000000257314121053726016100 0ustar stephsteph(*************************************************************************) (* *) (* 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 } labltk-8.06.11/browser/.depend0000644000175000017500000002343714121053726015125 0ustar stephstepheditor.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 labltk-8.06.11/browser/jg_text.mli0000644000175000017500000000265414121053726016032 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/main.ml0000644000175000017500000001127014121053726015133 0ustar stephsteph(*************************************************************************) (* *) (* 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 spec ~f:(function (key, _, doc) -> bprintf b " %s %s\n" key doc); 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; Load_path.init (Sys.getcwd () :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path @ [Config.standard_library]); ignore (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 labltk-8.06.11/browser/useunix.ml0000644000175000017500000000432314121053726015710 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_completion.mli0000644000175000017500000000236714121053726017220 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/dummyWin.ml0000644000175000017500000000175014121053726016022 0ustar stephsteph(*************************************************************************) (* *) (* 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$ *) labltk-8.06.11/browser/lexical.ml0000644000175000017500000000730014121053726015627 0ustar stephsteph(*************************************************************************) (* *) (* 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) -> () labltk-8.06.11/browser/.gitignore0000644000175000017500000000003714121053726015644 0ustar stephstephocamlbrowser dummy.mli help.ml labltk-8.06.11/browser/jg_memo.mli0000644000175000017500000000220314121053726015771 0ustar stephsteph(*************************************************************************) (* *) (* 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 *) labltk-8.06.11/browser/jg_bind.mli0000644000175000017500000000222414121053726015753 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_config.ml0000644000175000017500000000364314121053726016141 0ustar stephsteph(*************************************************************************) (* *) (* 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" labltk-8.06.11/browser/typecheck.mli0000644000175000017500000000217514121053726016343 0ustar stephsteph(*************************************************************************) (* *) (* 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 *) labltk-8.06.11/browser/fileselect.mli0000644000175000017500000000304714121053726016502 0ustar stephsteph(*************************************************************************) (* *) (* 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 '/' *) labltk-8.06.11/browser/jg_message.ml0000644000175000017500000001061114121053726016311 0ustar stephsteph(*************************************************************************) (* *) (* 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) labltk-8.06.11/browser/searchid.mli0000644000175000017500000000330314121053726016140 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/fileselect.ml0000644000175000017500000002423214121053726016330 0ustar stephsteph(*************************************************************************) (* *) (* 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\\|") in let s = Str.global_replace ~!"{\\([^}]*\\)}" "\\(\\1\\)" s in let s = 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 (Load_path.get_paths ()) 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 := 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 (Load_path.get_paths ()) ~init:[] ~f: begin fun acc dir -> let files = ls ~dir ~pattern in List.merge ~cmp: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 = if not multi then [] else 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; () labltk-8.06.11/browser/viewer.ml0000644000175000017500000005553714121053726015526 0ustar stephsteph(*************************************************************************) (* *) (* 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=Load_path.get_paths ()) () = 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 ~set:modules then modules else item :: modules) end let reset_modules box = Listbox.delete box ~first:(`Num 0) ~last:`End; module_list := List.sort (list_modules ()) ~cmp:(Jg_completion.compare_string ~nocase:true); 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 = find_value_by_name id env in view_signature_item ~path ~env [Sig_value (Ident.create_local name, vd, Exported)] | Ptype -> view_type_id id ~env | Plabel -> let ld = find_label_by_name id env in begin match ld.lbl_res.desc with Tconstr (path, _, _) -> view_type_decl path ~env | _ -> () end | Pconstructor -> let cd = find_constructor_by_name 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_local 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; ext_uid = Uid.internal_not_actually_unique}, (if Path.same cpath Predef.path_exn then Text_exception else Text_first), Exported)] | _, 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 (fst (find_module_by_name 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 ()); 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 show_error report_error err = let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in report_error Format.std_formatter err; finish () let view_defined ~env ?(show_all=false) modlid = try let path, modtype = lookup_module modlid env ~loc:Location.none in match scrape_alias env modtype.md_type with 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 Error _ -> env | Ok 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 -> show_error Env.report_error err | Persistent_env.Error err -> show_error Persistent_env.report_error err | Cmi_format.Error err -> show_error Cmi_format.report_error err (* 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 ()) ~set: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) ~set: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 ~index:(`Num n); Listbox.activate box ~index:(`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 ~set: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 (fst (find_module_by_name 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 labltk-8.06.11/browser/Makefile0000644000175000017500000000201014121053726015305 0ustar stephsteph######################################################################### # # # 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 labltk-8.06.11/browser/jg_toplevel.ml0000644000175000017500000000237314121053726016525 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/jg_multibox.ml0000644000175000017500000001421614121053726016535 0ustar stephsteph(*************************************************************************) (* *) (* 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 -> () labltk-8.06.11/browser/jg_multibox.mli0000644000175000017500000000321214121053726016700 0ustar stephsteph(*************************************************************************) (* *) (* 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 labltk-8.06.11/browser/searchid.ml0000644000175000017500000005007414121053726015776 0ustar stephsteph(*************************************************************************) (* *) (* 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 ~set: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_local x)) ~f:(fun acc x -> Pdot (acc, x)) 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 Env.find_module_by_name mlid !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 _ | Persistent_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 -> match open_pers_signature m acc with Ok env -> env | Error _ -> acc end in try (Typemod.transl_signature env sexp).sig_type with Env.Error _ | Persistent_env.Error _ -> [] | 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_by_name (Lident modname) !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 _ | Persistent_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 _ | Persistent_env.Error _ -> [] in try_lookup find_constructor_by_name Pconstructor @ try_lookup find_module_by_name Pmodule @ try_lookup find_modtype_by_name Pmodtype @ try_lookup find_value_by_name Pvalue @ try_lookup find_type_by_name Ptype @ try_lookup find_label_by_name Plabel @ try_lookup find_class_by_name 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 = Some 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 ~set:(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.ptyexn_constructor.pext_name.txt | Pstr_module x when kind = Pmodule -> Some 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 = Some 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.ptyexn_constructor.pext_name.txt | Psig_module pmd when kind = Pmodule -> Some 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 labltk-8.06.11/frx/0002755000175000017500000000000014121053726012772 5ustar stephstephlabltk-8.06.11/frx/frx_rpc.ml0000644000175000017500000000404414121053726014767 0ustar stephsteph(***********************************************************************) (* *) (* 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" |] labltk-8.06.11/frx/frx_dialog.ml0000644000175000017500000001035514121053726015444 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/frx/frx_mem.ml0000644000175000017500000001001114121053726014750 0ustar stephsteph(***********************************************************************) (* *) (* 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() labltk-8.06.11/frx/frx_synth.ml0000644000175000017500000000635514121053726015357 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_fillbox.mli0000644000175000017500000000326314121053726016015 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/frx/frx_req.ml0000644000175000017500000001633514121053726015000 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/frx/frx_ctext.mli0000644000175000017500000000256014121053726015504 0ustar stephsteph(***********************************************************************) (* *) (* 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). *) labltk-8.06.11/frx/frx_listbox.ml0000644000175000017500000000700114121053726015663 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_focus.ml0000644000175000017500000000257614121053726015332 0ustar stephsteph(***********************************************************************) (* *) (* 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)) labltk-8.06.11/frx/frx_fit.ml0000644000175000017500000000626714121053726014776 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_synth.mli0000644000175000017500000000266114121053726015524 0ustar stephsteph(***********************************************************************) (* *) (* 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] *) labltk-8.06.11/frx/frx_lbutton.ml0000644000175000017500000000402314121053726015667 0ustar stephsteph(***********************************************************************) (* *) (* 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") labltk-8.06.11/frx/README0000644000175000017500000000010714121053726013646 0ustar stephstephThis is Francois Rouaix's widget set library, Frx. It uses CamlTk API. labltk-8.06.11/frx/frx_font.ml0000644000175000017500000000414314121053726015151 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/frx/frx_after.mli0000644000175000017500000000226514121053726015460 0ustar stephsteph(***********************************************************************) (* *) (* 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}" *) labltk-8.06.11/frx/frx_ctext.ml0000644000175000017500000000623614121053726015337 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_entry.ml0000644000175000017500000000345314121053726015347 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/Makefile.nt0000644000175000017500000000211214121053726015044 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/frx/frx_rpc.mli0000644000175000017500000000270014121053726015135 0ustar stephsteph(***********************************************************************) (* *) (* 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] *) labltk-8.06.11/frx/frx_group.ml0000644000175000017500000000231314121053726015334 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_selection.mli0000644000175000017500000000224314121053726016340 0ustar stephsteph(***********************************************************************) (* *) (* 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] *) labltk-8.06.11/frx/frx_fillbox.ml0000644000175000017500000000607414121053726015647 0ustar stephsteph(***********************************************************************) (* *) (* 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]) labltk-8.06.11/frx/frx_after.ml0000644000175000017500000000262014121053726015302 0ustar stephsteph(***********************************************************************) (* *) (* 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) |] labltk-8.06.11/frx/frx_lbutton.mli0000644000175000017500000000234314121053726016043 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/.depend0000644000175000017500000000245614121053726014237 0ustar stephstephfrx_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 labltk-8.06.11/frx/frx_focus.mli0000644000175000017500000000221214121053726015466 0ustar stephsteph(***********************************************************************) (* *) (* 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 (* *) labltk-8.06.11/frx/frx_toplevel.mli0000644000175000017500000000220414121053726016202 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_listbox.mli0000644000175000017500000000327514121053726016045 0ustar stephsteph(***********************************************************************) (* *) (* 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) *) labltk-8.06.11/frx/frx_selection.ml0000644000175000017500000000377414121053726016201 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_dialog.mli0000644000175000017500000000253714121053726015620 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/frx/frx_text.ml0000644000175000017500000002041114121053726015163 0ustar stephsteph(***********************************************************************) (* *) (* 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"] ] labltk-8.06.11/frx/frxlib.mllib0000644000175000017500000000026314121053726015300 0ustar stephstephFrx_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 labltk-8.06.11/frx/frx_mem.mli0000644000175000017500000000247714121053726015142 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/frx/frx_color.mli0000644000175000017500000000216114121053726015470 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_misc.ml0000644000175000017500000000500014121053726015127 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_widget.mli0000644000175000017500000000221614121053726015636 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_req.mli0000644000175000017500000000425214121053726015144 0ustar stephsteph(***********************************************************************) (* *) (* 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). *) labltk-8.06.11/frx/frx_font.mli0000644000175000017500000000245614121053726015327 0ustar stephsteph(***********************************************************************) (* *) (* 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. *) labltk-8.06.11/frx/frx_widget.ml0000644000175000017500000000246614121053726015474 0ustar stephsteph(***********************************************************************) (* *) (* 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) labltk-8.06.11/frx/frx_fit.mli0000644000175000017500000000313314121053726015134 0ustar stephsteph(***********************************************************************) (* *) (* 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. *) labltk-8.06.11/frx/frx_text.mli0000644000175000017500000000413114121053726015335 0ustar stephsteph(***********************************************************************) (* *) (* 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 *) labltk-8.06.11/frx/frx_fileinput.ml0000644000175000017500000000271314121053726016203 0ustar stephsteph(***********************************************************************) (* *) (* 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 = labltk-8.06.11/frx/frx_entry.mli0000644000175000017500000000326614121053726015522 0ustar stephsteph(***********************************************************************) (* *) (* 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) *) labltk-8.06.11/frx/Makefile0000644000175000017500000000442614121053726014436 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/frx/frx_color.ml0000644000175000017500000000313514121053726015321 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/frx/frx_misc.mli0000644000175000017500000000253214121053726015307 0ustar stephsteph(***********************************************************************) (* *) (* 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) *) labltk-8.06.11/README.md0000644000175000017500000000063614121053726013455 0ustar stephstephLablTk 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://github.com/garrigue/labltk You can find information here: https://garrigue.github.io/labltk/ Bug reports go to Github: https://github.com/garrigue/labltk/issueslabltk-8.06.11/lib/0002755000175000017500000000000014121053726012741 5ustar stephstephlabltk-8.06.11/lib/Makefile.nt0000644000175000017500000000211214121053726015013 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/lib/labltk.bat0000755000175000017500000000007014121053726014700 0ustar stephsteph@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 labltk-8.06.11/lib/.gitignore0000644000175000017500000000006114121053726014724 0ustar stephstephlabltktop labltk mltktop mltk .depend *.ml *.mli labltk-8.06.11/lib/Makefile0000644000175000017500000000772514121053726014412 0ustar stephsteph####################################################################### # # # 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) endiflabltk-8.06.11/.gitignore0000644000175000017500000000006314121053726014160 0ustar stephstephlabltklink labltkopt Makefile.config config.status labltk-8.06.11/Makefile.gen0000644000175000017500000000502714121053726014405 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/labl.gif0000644000175000017500000000277514121053726013605 0ustar stephstephGIF89a9.Ǿuuuuqm}yu}}]Q 1Db= Ξ ePD~PԢ1)<",IG.}^ 9A3AZ@stDApӝyKeZ<8T g$k8P5ڱ\ʀBLJ}%"/t]J;labltk-8.06.11/examples_labltk/0002755000175000017500000000000014121053726015342 5ustar stephstephlabltk-8.06.11/examples_labltk/tetris.ml0000644000175000017500000004273314121053726017215 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_labltk/eyes.ml0000644000175000017500000000462014121053726016641 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_labltk/lang.ml0000644000175000017500000000623014121053726016614 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_labltk/Lambda2.back.gif0000644000175000017500000015030214121053726020171 0ustar stephstephGIF87ao@ϪϚòߊuuϺueuequuUueeuϺϺߊ}}}UeUeEUuEeuEEUeu<<}0QaUuu0EeEUeߪ<}}߲Ϛeu}}euuuuuuuEeeUueϚuuUee]]]Ϻϊ}IAIuuuEUEE0EueeeUUӶeEEeuuUuuEueEUu00E 0 UUUuee 0,o@ͯ˱όۖΥν `%Dبq#T*DZa|ٓϞ4(S<_uƤT ]łYDq%^ |z.G}*%XRR6t>ZxV"_ӢVjVV[*LHf6~*&)۰M +I k-:s]AOeZ@*tgFÚ-5_*CiPT6v,jhvd߶kYlcἳ;+Zi eԳ;i^8wwvjуVGWnYjv~#a9f(}jY^V&}>m&pz+ŸdH y%L*'ZVd|1kmoZ',qI_䶕_~k>4z-EW_ϲ@TQ;K]Wl$&g |zwgs9Wniۉ o%j2y(~e;R {,-;Է?F+L37υNC*aNr>V-7ք%0oix-J6N3m9,}e(չ,8܌-9Yy7١hoݪgC>ٱڹf]+kfx٦z[W=nz'w0ԣy7È,Yƍ.{ʗO!<)|V+'ެ}u˟V[{"g,G5Fi NlmCR~3T+RS /k\0e,9Q.^ fIqE%ϋ~bMʙ2@ͣ,cYćԢ[g:R쌤94hTbժb8ʌrTpC\U8enY7֏yriMS:ΘSHǹᣤ0,e4s!ںQSeE©iVYqV-*JbLTJuVj"K-0G5Fuhڿ!ӃD5,rZ#]< Pv6[s>,#ӑ03)T.k:^Ku]jecAjUݟs;V֯ع=kRl\tl^gKlmM0=nzSr&uo Y\*_kc/gvHR ״Ugњ`6VݽrL[hj6V+1dTCrŭ:S283X\L9nPGIc4$'@ɚȋ䰎g 9 o W*N4twF4wo##`Y]-ga=2'Vְޑ9$ue/L+sӝNTAո3oB+N6/ zUdg@6˻pG,j+KNk`I6Jd.mn[K~r)IW$y:Na7Wf9:'+V_fbWVӂZ־6 :!D_17pO.t8m6} q_I~`|Wy+:暞dyL;-r3fUX p,t^ӧӷ rS*-:Xbڹ_(i>{g;LmDNy]yy[\߯9 OX)om|!'>]Wկsߥ=R~_=nG`}3]w ,߷·꒺,is&^F/bɊjI2OaxmRg|g5U~gĥQyZ}nWma?L̴緁~w'kdOLe\Lj\ Vgv&ljā vc`iy `ٌtYMI~Ɋy$`wRs{ʧLHzhiֆpHxΘp!P&  !{Y0yz,p1ʌzٞH0CJiل/jyڢJƊ"ꬥJꪉךMڬ͸抮 y஺7}9AָX)|!@}Uj& , ) 0F+鞠xj Z Pf{~v `Oz9J9ɨ+I:YڸYFxȉ(Qh 2lψ8Y8 Dk ,/E+<ۍuK)̘T{y Jx3kEQ=u[v Z) 8 0*;D2@I10 IN9 [H.@i.*\ 0{T'CvW˓j9ȐɊF۞iDE31@ 1c IͨJ٥E{j-*sÆ ̈́0SiF۹yꍊzGظܫ0]0܋1мڼɪyۓJU\0\()jhÇvvȎlGYɗJɄȽ~Jʦ̼  \\<}98̺̑6.Q)8Zy iӏٞH 8 I0&64-6;ū e=.ꞟ,:ɞh!ˮmHU W- 8.˿m} 췍;4#" Zp!0bcɿMٔwYȨuy۝ J94 pٴzշt{,!û˼ȝ\PJX p'@Y+Vۭܫ3zX밤xi9ԕ;pPا^]{)nL αʨ]xۘwukuvdۿ♚;I;e:쯡h$ 8 r; nD+c\;ȊɊ]yh.Ƶ)ɉ9)QWG>/b.#3b6ݍߝ\sM5;h<=p8 >֨\Ni詭 ojجγ}[KGQʐI;"|`a׾}n` @ؐD !F`F "xWc]3!*hf"VF \ jaQJmhB(XP5mEB .VJє=lπuV .3ڮF{'"jI]pƩv6X@~ZȄ rd.*|>z!A Gz׸Bsjb\Ne>,@HԨ ^C( 1걈OG= _GTb`@􏭵&۷7v^zU $*Eb0cJF:af}ƙrEPiZvgEEmf:5#i`"ɉ6>=GtTWv}!2R,9 7H{W_Ye^~ :ԶXR <(H+PZǂ "` fnpH$E%T6?~u3*iX^{HA~wd:HhAd B=- _eA%H2K{L@ βB/%--5yM88⛋mS +c& ;: 0svBy #R }`Bm"5hh`P/:!0.&, *TE( r?X,U!&u1-> 3݂$ 4?= t44ݴ 83!\wr-Vr"ytxrPNBҡيIA=&h& !Af1׭BM[i-Dd')cD7NTuZ鄜(aK)Ob &8॥x4\Ҹ<9 '2h!A 'U v(N@=FwLsT/%5`p7$8Z>%(h $#+*؅߾ժQ؃)ШUFVИr O0)VH?2dV ?%qTą +cLǏCDx kE A} )hlf !*G,3Atꖹ%SKЄFÌ_YdnD i394ٴSCMpgk ɜb~kg*JOͳ $?O֗l36J,TU(C 9⎤&uMtĤ x:vZ2mS 6Gx!E ZthBzA NuPS.9 @gJ9 z`8.C49Gⵐ$zo  l4SP_yQ @f5 pL'i/H :DoGLƾ)rf=N &39!4|.s4QW0Ǧ sM.U)@!ZP(OXD}#l YC0$ !.qP_Q^gs.F`=Hl RaY޸"^IB R3e~C X@PQTHL@Cp&uWz+8ռQ>@b|<2)LOdwLLyj .BwFxg0΄# f$㔀gt*BC#9})s!Tfx@R x `7k4!s=l'8E;$БVeA's5pzL> d`R]ØmSj>Vz7_ v@tCЁ y?Dvub;0: b~l!UmFj?Ey\[(A (WLDn 8ͧxR_ 1 `'. סhD@ъxǔL[Hnloj_+;y $M^'F]) 8!G q+11`A,&:t`cp ~t pNt`b`-ށe 0dt%88l'G| `|.W#| ɥ g}}56p5P~$w;mGbw rwk-x6)Q"p| X9SFHr[%:x $ၽ Y9(H *XY 6c<˓dl9ddn4]49 8BaX6 ^ .c>nx>,=em `a!oh)U=oJhp^EO GN/@4p63 31.VTQD٣p ߱q}Ffao.0a 0 pze+tP`Vls7Ԋvbs"Pebqc%(cd @gvusE *3"o_3) "rLa03w7Q[2ud1*?F 9OSQ$*5+`Ty y XaPŠWY(yUOȳd2CglKDICW=y }"'uTGC y@>SgKyjs1!uJ?}ضR6fy((>4 2"zG}Đdo7ϑ8!2z_#r2 13:3}!3Z:(Ρz QGiyE2U2IJ#‚6dl@s>3tH1x{SW'VGPN`|j!y&yvQ6U4/ L,BcWSs?r`hwW1$va4%ULhJv2 mT?P*G2  O>q:01x55R*PH*Т0:7:s35 eTց ˚1Ԕi ڊZl"홖cT0oSٍ~Я4 QaC K9 U y_TV-+*v9\rQ,H<-i6<  ;Y&>ڙmS25`Xy.dT2"Pj dB!Ч,7QQh\=~#g5}5$o FdߪXV?>/'+I*`* !KA(U12u2:h'!ށ+b79RaPZE)͓{5:h +Y^9N imy e4.W5rr0L®Uc`eYEX*5L#mq?~FupF^R78U@5[^Q5streɘG2a ;*0x@;l2&Ȃv-]c!su 3}XыEI .K;uF -s+t.$Z'$1& QEl8pp(q q&/"{=怮:56(A0=D#9F3 I"bIU!=9SrЍYw/  c=du*"AIR5 Z}t>K!<*ׇV5J;/ga9Pʭhוg\QŌa*PTOwҋgwA$v=Z&if $#]ڂNգz h3} ;Sx*Pu˫ԧ*du$L-ep7j 7 \Nד>  -\!׋cOZFy8 ܪ,R?i93d%!X@l'foKV?cL? `'j( T @I;na "uWQQfڲA S_a';fa47E(? Fm@뺸a2BQZu˚'@`|z".+.G*G\w2nfJyU"7hz Q8/U3v inf)1u Q {%,c-&2"*M WI5f IP,7R|f<5Wϩ ޔ2$2> N y2 z5` Zw#ℶ*zyaƭ+NF/l*AK|Q ^< ㎳l)ՕQMsB+hQ.'SV3e|Qɉ*Qg\W Ѡ|]TD|Q2A8'Zøm+MC n'hدC>IuE5v̰n`7g+7"($my:\xߘs(p5vx}߯@eLcHq+5LJt:!;Dn M榪 G YDCi.p[b@RJ腕*1 ">uSPT@..y!QuVF8f "("^$ա[A\n0ѣGQOo|b~F 8nt &$5(B;$EI@ e(VV$;BlKK{ D"XJ B|B|rİcJÐB 5l@P#4h|B8\ np `gg03zƌ(aIFa4M*@ $X+*ܙ/SPbE8u="1IBJ+ :!ZXJE ùPGK2R 94Q'€Qz`?u`1k03yF'd, :I m EpG*#3yA!l1G?*yd5rU$- bKSj&$(T` +y"b Un'!o1}Gk"zRF.RShU0n]hXe$1+5C6CGE1cAkY aSHd`Qb ip Lv:಄U|2r`ȫ]D 2 ]9V!llȉ.x)@#;wX-B=R} `-S ,a.6aQgXVYrM{5MDk :Bߓ $QyP* EG!Uq.4NT+P2@bX]CV`815 nPeЀ0F=Wq9j@L1w]Jq$| *NAȳR84 tFcc1Da+l@1<.2sgPs&tX!}HI w @PC)/GT%>K>r+u Ac0W{'% 4`U+E2$0T2E@<`  2]R 7T$!ezgx>mnE 8-Rf uPL2)PP/HZt!4 15/sr1G**L7)r +V$wdp,iFxIp>PtPbGF7U>FVP77ؕ 3ThGI<%PHy(+m?B+#(a+A/DX!pTB1KZP1-WQ0J/0&P:O1!tyv!ld d5)UyF4=5P' mT_"M7P34qCct s yR"-0F]ICu$@T1y-UdIE!!_!`=Л?;]w !h悡AZ'rb~1$ݑEt-+u/+n0@]DZV>,dh-  /915Yx#ɐ*=W~2)X < Iep4`RjPw$yGBTE@8Q":tH\t_jDPrJ52x86E#Atg!P\̓}Z*|e)b#rpE}Kkդ5FFlSUj̀.BYt@7`ln*tdru:,§R!zzxq鐨I])j". zUzъAZ, ʪϒЮ5 WS#p* V( ^)4 [Tɠ_RAku@9F8m}t WU m!u)ޅ5 &QP>Е顣G?"`Q=5DhNW3iR,9_ EaWy3AEp_zr[TWJpw h*$suu% ~ ? S@wk ιzOEzQ!p*/pkمZ:= HF 472E"4-HZnfw1.+p`"w\Ww x>vA k9*EIgRUXX f,QkVhDQyV[ G`f<"<a}z^ /J ܡ {@dHu5O?G"1<2`RW#Q&AHd-XBk_ )}N!Nvq 1\hǷ70 x@ '*(qH!W]9-:8.K5q~Qt[D) c)*1GĒ<P 2ȉcrPG]@rdx )\xoaJRTYD0pmitiG>?wKy+!& xI703PZp-phôƎU.|U$˫pMq$7R a>a,IGc<2^}5`& f P7;PHhŴl Qt!_@ 3С+P9 NNGtKry|L}4@;#5efq^ZQ(sZr@  9TyO1)#wu!-6Yf(Z׌;%|׈|E$BɴP4*2 9#>18m 5)U y0*%*+!Pt*I-򴷕_̶@>OuH*x4Z>/#‹QoP-zq 7@?DFgK'[avBS2B޼Z [M3kW @P6p#*"!27mҏf_D֢]9wTZQ FS!P "~PJ1Y(qJ}*@ `⁆}*ΚB/I2^l*:?lQ^4F~SINM R*TVykc! ^21e=;dLlp~N2Y/)xz|>w~޶a'A$V.k( rY)F*lQDgfV]P_6H&G|* 7̀><Е\< t!NAS7 <_0$ s7$`!< N(Mpҟ8tCם "42P2ws%t,2Y.x7Z@/u(>fWdQ-!_V:vRk4_ ?XA܂ZTaQF|<;YP,0푵iw򑪻>!%++ɛd}>ہ104A,_,eE2~mQl 6ޗݙ}-:H E"!!!!h(IXؒ"RcX(Yb*#RQb!XA[S+"B*L( "()r*S"QM#1+R!rC/a"@pAG|!ބ%2ntP Z/8JԀY Ai,X!URwb pQg KC9Z$d  E`Å(U$ 6@xj]0xzKsI"".K*u0)*o"T5C 4<`MwT T0Pc0A_@B]Mc[;"\AnRE5xAdBƒ"~-R$8EqQ\3bڦ%a*]sNQQ~٦ >'0(a<HQp@FI 1Fl#5ֈ"E"- -_o f A!EP ҂s!C2MXAi0#i22R,' )w5#\{AF 5d_a#% mFB#$֜5*Q!,7/ȠK,ӜJoI S|٘Ù(40!ujjy }`hD*OhfW饙Biqyq3ȤLYF骭&vZ뭹ګ5)ð" )2 N8GXUrW:".梫.q.9&Gܛﾂ˿\0n) SC0qe*jֈ` /tN20~b̉JYzs/i6 ɯ+8BPנ#@Ci2)$tzWl'e75,& *:65sBM*_$H1[&eJ_GIГ%(*i״*%O1L3!e,tBHLR-MpS ]+H4vT= !aiTGoȕEPFN`:ԧ\}Oz9q"? ц" # "p*K 4lf F5'; Z}W 6|ՌGF[6Э#!ݴy:=o"ԻDmc)OxW ~C| Où(ZrPFHrF)ǀW 4f!>$=i6!6CY* K5, e<&`SU @tSW40" t1RpQ r s%34b%fVV 35qB=2e&) -YrUPPR!P!zA 8x 7}r&InSq&+&BlG 6N1K@baC=2= UqM>e3ِQ DF (2!N)$Q1␀Ag~J=7"=M2|3aW5FSb/e΢C*)@A Q7)T%ELIIscG+ȰKp 3,p%R,1OV[BPgC;b8 O; րP %3HyB h0(Q,4@#pr * \>!Z1>\ DDjr&( 1C!p(=D 6Au" PV+΅!0`h(( 4|`tzx fl c ӊi&:lj)pcիz"ǚnʚZ+4H1 F 8z%s 5ߚ ,P 뺷&KQLGЯ"$b0_5а/q9Dp騴DM E:6pFPb!E>q Z:2 %E)FHYwe{&^&#q΁ +f` ,"*]Gg"b2yDH-pQTwL )0h3p ¡E,&Faor[vV<#fVXW?TPa Z@ pE*ii< P ZCDp3U#EQU׻:W,,)V0 fAS|@#I c:D_v(+4A1+ò- H )ACP b`<˩>›Rl,J05s^?#A,%0\#% <.!JȥHPC'aI0]h(q^W pQ&aJ) T2_URq =`Φ)P gydдq4@Uvd)YoA<Cg-x" H\S `qp!I0"Pu>#ȉ)@R-% Td#|"` & td0AI0lfU1c$`UV\ @\ :!3fY)E ,EA gEsƲU,ҵ3I%3|XpMc}M5C'20Q< s,UhXA DpTa  ۂR9BKvp { Y-h!wnADiUT)2C=iLl7E\spX7@0@Lg{* \4fYFgPE%$`A P G%>#nkG$/Co+.$ .L@1ed2ΩP˰dRR  3I}AjPtB<]~("x*ư**)RT^*Vzxe? 2GC1)VZNl B*`=XLYV~N ta|,Lp k鳹#ꤞW-Aೱ8Cf59!^ ,c7`쀖 ~z$A.DRnt#:i@cѱB$$Ù@+q"-1@ >Z "Q{fK syGG@^{'"PV;b r^ǁ< <X"^glFR<sa}7sS-XaAU}d1-<#W=`t2/0HyH jIa>---**5/I2DII>!>AA2>5>-A00D7F*>CCE5C*>>"5 -Ez`2H5*AI$>@Fy@DIƩhAV"BH(R+AA,Xp"hC xaD! D !B 4p& "U/<ʐQiY\9 Hx"dDP# JE萠 MjtPZɸJfH1D5BI?>+A*>>X D-֨P1Dd]f4;YnG?B'Ye>.7:0`nV1 %E-?1E|Ã)ɍNM8\ QA TX !c!!XAtrϔ6 "(+B(+1^USՎ bʨLYX _YJƤBp5$`AmSsi\<+Aa*t,|*a"+A2 Q7̎Mz fOJ`+Ao*|@T! k6S )'6 CуWX--"|4TtD GOd+R?a4=AWxv9 t 6"x V  8(%m#p-d $qUʠr;?DBD1>+R\^QHu1kl mGXudPB\P#FرƠ|3 >nfF|zDs4DZ&șN|=hFI>m56"  >{8D4QB YlX6F6uc1=fX>@9eC,`z簄ylAC6HD˛zIezx.XHh D@`GJ 1Axq""Nq8o+&|Wsj&w:EL`4AqINMRU,K&‹(z#:YNG,`ElQ5ih Nȇ[`I( %#T0SӚ P22) @堊jpbǩر,m1r[!z0HMP$DKX-jp=4VL/>ƴ SK̠qBLF lScĤ- A Ӂ&(9J&Aj>!n@LR׍mQ^f~ց!bǾDjcC8e?2* ]!VF5) P!2:$Fk &lq@FGi%R< FLia6eǙ (DiA^0PH:h6{܍@$1u20LExH-ǒXDHHVxׇRu0rĘT_f\󌳖7$:Vr<&e>j8T "G38="+ġ ơv@cр=uQOF4!~ bE@R $I :u W6Ig^'%2'Mgp7{[Q`oG2BRAbAP#!U+09`(%EVx!"#<5 +R` *VS5gfQ,E`E2pMA%&Y0P#" P!PI kR|@Q3s(%"s0`cq# B 87'B -.,FL:LqL2WR'# ,PSD:PG#A1ZQ wr D+S $H_uR2Y 2+4Ubx%1 yT"Ug U[ +XKSS! H%2P '…,Q\n?RakgE:VmB0pMpL 8FnGJ6sK1+R1#TK0%? }!OREi %8 !@Hpƈq<8 8!鰉hA u(4-EЊ(G43\Xы$Q76{Fq!dRRHv#,XMvؕ\% Y2 (D7`˂? ΑB8BGi+@װL!!}DA,"2 YLy3+!I[df d C0C}arQXp P #'0;: PiU@H7+A1B#=LG1A) "pP?6?U]tVx$p r5or%E8.PJ@P+ $l,t3ٰ5Z" -eddT#0C<+$C i} q 2GaVw`VatAw8& YbwwIP {r5Q#8tK0p-bA*w* iEPx_Q2%} 磠c'yb1vuoaIx`2%*'?ϐ*+GDkrWWR//b! `CnsS!!; 20|A ԉ#gJRF*, pu^+>_oU.p&1?RI0aE*1"wpGU `>r0&!qCsd-C-70.Ӧ~!,E%Œ|+yGTFHW#Bd7AAeBXq?+!0.7 [XG #v#0h g&|%"RKfZE4Xdq:8WH aK9,GcD; -i4 ) D&CB o=GOW1g+67bAq'b:I[wdQu O& ,x UrD?K ! aveM2XRac! #u#2@ ]SP0c `%)/@/`="H2s[2Ql o@34i}2F$ưG ^+weUI&2{P&u Sc d ~(Q {vLvS(`_ /7\(? HKP9F,q*PV\!#S=5!uP-}\aA(EBwE|rX+@B R mG\Jl`*> !Ş@U\gWY4]],`,bl dlƝp!B*nLU6 sL;`\%|E 37ȷPȇ,l,S|3 VAɒ `tqpphS2]a&if("^s1-΄$W!67g].TE<>^PA4ѵG4YWA@ ʀ ҋ&^(3x72>qY%) 1FP7Y"sB08@8m,M`~09 YNK1XBGsH0"O Z'mD2@tK} ! /1La( u.!ˈJ& ${}>qQh: ?c :deB!XDmJ+aT+wPa4xޜЂS,p -0n6Եo{ ,́$7GRfOU]#p@TmRM @)Gly#bGt"Fd/*K/v pf4P@tq/\NJ?W7rkQT?*0Ӌ32Ft$݊C²ei!0n2@_òK1jFyE@j) 3nq}-z2^U3BG'g@-f(p.X27W 1WPT!"!!#q!qTQRR!"!BSSr*ر8##ss(Q8irc,]M]SC$S1T. 3 <`Ѓ#JAȐ\ &5d4taF+hTq$&C|hQN#>* MHY"HEzm*x8UccHԔ'OxX5Ga1m!Y3BQ &*k>* 9pk[rqvb35I$ jԨ"Di$)'C c0bEH@2eA9kZiײm-\Υ[xBԻZ?4†F"F58z9oH %9J-L5ݔN=tDPCuTRKVQMmWV]}BXcPg?n\t`W xŗ_'&X"b5-X(rEdTYV"g@""ZkɶݦBnx)Co &%#%$ yUcL-5֖6 ,'MQ; dW>'!BF`L䨠AE|pHAHhqC~Z@#HRECrXMtCVBAQ%tPMT(AtS)NDVupý%"XM eHwAɧ@%C&P%#Z4Afm%=|k%$2O0AM].@ CF2q"7Ѝ Ih/UУt+xeypkK,~J[P!-`B}U*>LO!+n$W|dm 7C"f!Vp-fJ b%bNa壯y"㨕 `*NOD`#`"I @*W%TU?"0;IP(u+\*Bql$3%c?I137Fi8xIo>*0*}i˞wr'#!825-I0]AKʿ! h!ײ3br<^z2&,?)JVhx*TUfZ-PbE?ZlCcⷛTXA`B9ř3Jr&R7T%AlC|?``MTD%22=(R#M-X"Qa (~< |T߰M2Jn=!AA.frC(w:F8 A)#P%+t *p9B^~5 ŭK uF#]LP.)Tm pg:TؠyGH)'ti]c2D%(DAB稍D4i/ I\ūSPEx ,;s)<0끏mD>,쮉1wa. i„r8dOa?0em ;% 03wrr%>r ,XQ 6zeaFhxE,A !$,얋.gZfP^pL"/{盔$o8e)N ~6dJ(AU3 SiTkS&>q}U*$fh3Lfh6VfoYqE\<#A:Ah)F,yVl^ W 8kէe/NT, B'Wޣu HnBCb+#@_jdC1De c=22 N36] =Ȉȕ+u$_NitZS=2ذ lq&(<6F^uoK` MAc,Xc!^ED! =;6 "x&C+7|Q:KvA4fjS&WQKfMFP^:#Luz>AtCN6i3R!Psl\]"k- 02?> GPa5' 6SR zB DB+oj!\; 0?7pC99[!!D0FO+cс%836E[E1aRQ,8LHH Ǔ Sd4GJo!E gE'_+(7T]W^7{ KGI4@ɰ^> s=*U|3f3 8`b!"~w["WJEGB /0bG)2Q%3a!pNCP@ 00J?6u&QYU*-r/Θ~S!++=$f#,$SQ~ LN+4+s5@oS?'>t>e'F0'`0?jfE4wQ7?aICd'r=$^*CAC7,0~BPv #gPHp  Gu } 'q7 ]!lGQ d;r0]%/%w S̠;6#BBP LL0@t"=~[/b5X ceюKDB0J@P P9%S5&GP3UH_IS,I@!s x OW5'K1KA9I*`8^URȈ}Gr4d"IDj 2 }b 0!1` 1 `BS^Bf_P @6M`=WM`oxP1#W -p: "/iF$ P?0^B=0$$3 I~RX+@[W 4YMpg+0N1p4= @ (%3Y*♥G ,> 5КU F C~(S7WEp2i.y iA Rp3v *9 p3QCp}&ED`֕ŸђZ,#.j:e@!:%yp)j>,6/D1t: <BJwVGjJ>5u<rh ,'S6~̇>ƠSQ(OW&"]6?:'"+)= 'A rQEd@C7Д :Jo^r,@XN Pij!J7dZWE? ;=&YQC3^$'=R%bC2d@ R&E/#8eq@I\8N:*@{#4˔nātRgS{ %|,Kd@6 0^Jզp(B *`0CVERQdZ/Yuqa%aIS1d*i3 YFԓ@Mؠ5vy414~"v O0dD7q"8pR,3@*iQ,,\$X'w7g<Es%;Bz1!8

w2,2M|AjJ<ƴ_QO}$@ 4V`4?40K0Q#'!XźM3qx_P !zh[{dy>1[РqA#2 5'l+4q1}"]6o[&,-Dx:%Bwe$2"$@,Eq"=ʷeäg=Pq*x@q#?D>P3·P&zecqRVȶ[Bdԡ*l4̷7l /R7YpPD03]" &ELjAp ?ZOrӐPT =0#$ !2J0 [ = j-N8yQ'6Y/]2PL`?Sr䪷'kH>UScsXJ {683g8da(G3XtavqUr33&Η~l2rΐqSr U v&1 w-'F}~bWq GZe]Ǔm0E|62E C;-p$sZ O7ܔ0ܔ$7V'܄g?xgm,:Q2$ŝq)Oobwm5@s۽rֆ aޭj'^LdKM3ߊ'}Z4[ YR > p3L5lUp>~r_>"Nl;U(-.iaZ DG۰8Y&f<} q 6a9lJL\@RƂʩ|4׭kx^0?+gq_ h =?Dq3GU1,HIp|0\!aWFmB#! l(YC*=+]U7>S! ± @ 60ets zD ?:5!z-@41>]WnG1B|2XOyW"vh1AcT./L@E'>=J|_?s vu:i4 jOW4 ~ KYV3Xj1't2Y 'r+ :]P~Siה}a4\  @'~х-dk412@ )(@ݎWF{Fzn8TPT|B cgK9i JS\(i 227I5>>A5A25"*"AAH++5H">7A>!5ID! HH5"/DI2A>!"ŗE+A?**?B*#H"6Dӻ *,*0200!>"CH7CtAčFMzA|hdƍC6@hd`(R$ՐaE#J- ğK*a}9$IC !AȐK`R#?lRLj>$hC<12" k01#5dcXXZX$y݂˜AHXơ5Hl$#|b#{JQg ~P!m$ ӞRqh "H9Xc7 Ũƍw:프7^:pDu/Zg% <# z%+&I`E2 >5:CeE8MRxRDo;}B!xD&uNLT>AS $Ё K2``h2td#_uD|&uxgȐFT6Ow rH0sYh{Vv" Xs5b$^0'.5 /̕\WE@i‰|Hb@ Eb QМ-!ITWC@dr&adD'"$"biv jH`uQ2P8)]ER PA $AGz/<#c<׊,UMDuT<4Q%Kotd5DCkg;0F̘sȼ& cI<!`Hi *s6& &+v1voD*#-7H|PB\VICD F:$B Ed 3`ˈ@ / _%A@ n) FZhsɈc7˶PJ_$O#p7evxTM?C|%#= d? $Eպ 47P+Q%YJ?5BL 1 ; qp]#]"!8Ɋ\v+w>{N56&EiLsԤF5Y"kE;&lf^6P7o*7ep!S=l8r-(g9i9DҙNR[ Zw׵#lgn]q xAH혧zң=K 7‚0; Bv l ChCC|P j1rctЦe, z#'=>cf\2X`S㙡#Hą hS2d)0mZ `2$(#,!3A`Fb~&Ԡl6@fZlP,LU"jT nb;Ћ g>2̫Hгh(!v'?L"bHq00M!L% DIXhˆ% -Rr2 Uʨ 8dԟxA_W<0A%HxЭ‹XLn17%J1Mڕ ,- ZA{n rR)I 3 "4E)ԈzF;;$`( "ܕL AԦxIˆf" Tg̀TRxa`EYR!cLnX3ĸJkI`daų9&`B1Ń6`]O%@ElZM#EN EoIFI@y{aQ!t$)b]pKឥaSb24|LSĩ3rJi(.g%ğ?r;OL>p 6E4g9<`x""o+z|brd?hС;,ދiZHfC%<%$~"\+(A &YWDs{~8Xr<=dyF2HT]łߞ@T J#N} ^zVD{,Eb!$$NQ1za4TRػkLF "bC[S9ŖRX^;LX裺nF;-i&ȭ $]L"-3ljD1_} G@]%k♉uSFa1 &G[kzB[ɮ7iP<'**Вj%0)á+Ϩ]OD02y;!5|_=ң3€霉,]^]p3:C&;%|'HBtnlOsWwbyG |wp8w] 0 x$qe[xaCy+`yNyxyx.e 'pczMzd>$R5_G# `21t aJ6 f%/v vQ% lpR&2h> i%q+1 b 0`Hp~,pO ́C fIi ;Botueq #Mf"yrfP(F`KM=pe0\]F_K_!/ CT1;f-W& 0o `p Q8v v'H2>+%|_c%hj,%P8fShSX1)a!M5 ~#*L4qP!WvƐm" V pfU0p0# L# 7GO!):EW]zu v,A*QDB pE-å20#(uo-0Ɠ!0\PL"zBfJpa$9>F yVFZ{Dh1)9!p4h>8X.v{6)Tja>*6Mmw%Ù@Pp9O^l>Cuf'BPTQ8Q+QR}@L! p()IDGlSģq154W"/N)p/kB ~ hZ os@A"+ c>?4dn4!v5-P4+E@q CW$5s$sM-$R-B= )NYOiç"aV`q `"'`8$BsD*GWq -+Y6?s8ױrSr -Z0W_3@*A8 N]"ASi?Y~ayщq43!.=(d7ngpEU3'Q% Hq*`k\( r-.PI\l%#22Xu*g*`j BB 27&F *tN ЩưSMd AB;+J3.{r=iPVY@ !pZWR++t&&Q15D3?3 kA Xl:NƷ*;6'W4ICH<CY.È~#*rFG;0X-xA#b"!k$N?ಇBIZ7+: }H'*hZ}GJJpZ@J|WᰵеQ|Df g{)iжZ3s[{!k2+M4'󙍠:C4+ӹM50Z˺j -K,%/$QТ9& `1 `th &dJǀ`gi0Z8S@(T- 4kl3Pz3 * s;q 2t7c27- c|316 ?`+QAvzQV`ŀaeAL% @6BiI,ThZ.L- Q.YkeQ DKS I=§OXD9rNXO7KpTG!7 %P6Gx) %`&iBn'9t _ %ٱb5L''xtCtR0$D, wz23wKA֨O95-lPlqN$ܹfܒQr5 5؃_ȝPy&q4iC*=L0!b"# 3AsH}Bt@`vWK Y+( z0*V|0b&7 mM`~IR.3:4 ;'lBY)3bhv?s47 % y"*T콂A;0.YW($m]- 2":M^7P&!/ZE;ܭ><8rC *́Y.(0ŪmI$$}&7ҽpN,~6&1I k3 `v`0ukc{'0=@:Dg OXqq`#s-cO"Eq"b-`vrE/k4Osx` IsuA0 ~ |?P2R^PMY9_a/yR ~3sP$&ʯ1uxPSCXRrx("BrCITs#(#S"Xy!IDy㪨rt!A)c2)zQ$CBRTP}!1-stTbdQQTq14TsAI#d(DG L$")K4Qu#$AX$Q B($D$2Q #$=R Ş(Y씤F5Dd$HO sPO ƍ+*!hқ< C $0`$$Df@"H`Nnhqy"c\nxAħ%$8F;2 qN[C7Ŵ- a-ABŪczw\=GH0)",|LF;I@QɵR"35v,#I$K(w(4D &1&$S)HEZ2QEQ&7dQ&KyMPTOq GTX!Fd&hr IH` l,IЊxy@ !%HWdV"6ҢBPXb!/bUiŠ'͗ 4#pS;0\;J !TQ&! @ đA^d> 12ӂ\ϩ1<N'hRDwxaogШwL!C7&Y<"CDZDc@D.%4G?VNנ5VP%eH*ҁ't8)Zt V* aqB^݇]b viK %y9e@H2`">a"xH%SumdʂD-"x.l-<#▕)GfPxc 4ң#oXEA2 0TIsaTiEaVLvDQLp9B4sFc,Co0$`6P vQC= A0[a!9fV(.hF[ad9"b!n0ePnU32 S!pr8 3"=`g5_qt* K?k hJP6p*T6*ڔ(=0KAHHmOCedKPc-& ph9`E6re!{EHaHX =q:(Q"@4BxZsD%2!wFF I h,wgu "&ss @ dh0@JLD@2 D@M!1Q$ԡ rhDD>r%Wt@Uh,֥50GEph  H!0<0IvE"נFhPV%0% *!vvhH`}؍h)V`Fю!EC$hmH4!2!?v)CgY"#?Ґ> tp- #)%Y'+ْf0"PrE;=!tdA)`hbJcN P)@,uYѕ8ay0X,plp)tM%Q^m{1[hy)`hhbtG"n;''QIi#]vd63 E}L?>\2 hqHNrFW}{  q2x27hp7'o2<'0}7IC}0Ru2#1/(U" P070`$ `L@@ *PNmG%G0N^֦s,>ʍ"`"'Vc%F J&XR"}DF;3w/P]p+@GS`R.ӓY t< ]pkI}'YאBP PpX03i_0Q&oE?GGG J4w~JBjs]56EVY> R7SaNr$Mp 1Q$߲\jZ)`R.JaoSm@(7A?h^b!I$;arsw[`l1s"s[2\ Mp]O$O w{װLY*1Kv J.Vw h"$EH@qXyzh>" g]i(G4 `B?D)?yd6m bA2s#LoȀ=#$"a:QQ/w[S9X" J0 n(001t-s4"qG!YNGF !BYJnl"s/eiri&ʽ?d{x RE0à5C"@(Ws\]9I <# UڄXDqDP}PŅG@*W68),ˍh5T6 :f`(ROTm9:2 @$HgH".`O.Ȓ^hɁ$hV5(h ^Z,[ Tcld欬T`Ja0n~wDc]f^Ui/dj$ fy =XJaAG]rZ1Nȼ@  ? %Q/@@p Qp 4Ɏڨ 2_O0Vq/J^Sbo Dmy a  M-pOO]afհ\Ok[( 5VUE98 PSVA `BBɾ-ͅNITij9diН0|T `S'171eQ)]A>5>>A5!2F$ 9 &&#+AK7>** #?E$<%EJJ-?*KCC*A*767A>!B766 ,,7D//0FF>HH2D5""*H-EE6-*EBI2*<ᑡH E2Rd-H$#%L-[pBL0Tx" *`0^Ie̘(dlrL&Z lx T@h 7pȃ ySEaDG)0`fdCݐ⠌xCHI "$ajB (3CS(QBL7f2z$$I*HҙL)TC@F8` $x #"%HJ#>d$I"Xg=m bD "DޠAH#AɠaC!l =T^  >4:2 0KZe0!+>!cUT,&QFGd!%x=@zBu eCB1 0 X`P=ZvO H5g522h3#!% HB,IL-ZG3NA * @PhiT7Tx2Z$Q2[mրpgr[-sѭCuiwxxazͨǞ{w"3_} Eh Bx:Z2p胇 HE,vb3x9 YF"dP SRi%"h^Cd` h&Zm6 C$&Aw.?>JzhTBL ̌ixP7DX Un$T"H 2 1l ; _ !f A35CTTq3z0C *2!,DV^|_g VbC-HERF(r2MhҊ!TBeTAsca0 AELcaLh>D A4kC8eCADjD|y5-   ЁxbI@uд%2a!".h P h`F( V(1$x`AŵR%!@h@ 0)XHLbxB%,87 N?3΀>{AC# rHS+@DY<0EPy$I@ #| k(Gt1x! RhъВ1/ !"B.RR\a8( H<P&A 3h@i=X x `T5LU6A *܃'bTcun U@HzpC 5&&i݀ژ(`XbPUb' (1Zq 0|>D!r'>L.E'<G`x8C@_#A%_"(Y.AHB#5! 80`wi\*a ' KNruLXt M`&@a3 c/ iO| _ ;QA6>I1 :AD1F9=6D3 Jt 2 (-(ϩD4 M/UAt$[dyd$=#2E+NHaE H78v=?n `M>= g+T($A h;2 'pڲR&.Ѕ.<.~M`W0Y5[~= **<(Edʵ@\B5Y`ȋ@2!!0(4 %,=QmaBP A$(p\ D>CH`EǛcpS0 -n AGKKP0 (g<%P#U"jp D-?fo ڣ )g SLT" *=1#F1>` xp@G.  7=D33@DR`m" VE< I5c'~ FC+4A@ɓDcPTCH%Jd"*Blg^@1a&`56ɄIX#!Qd xt k&%!21spt9 7JIY<sGJU7HG|!f.sq =8^"`)ȋ c ._9,\<6")j":ѢPv-tWoRꮮճ[b7dgv=ojU%a!qGsWwdpw^U"zw(wGxm[xxGyryՐy z~SLd$P|ΤAzCz:0{'wY<&%|rG|Ʒ|`(T,``!@D prEE7ǕL LP!7B9 P9w -{SZ 2$mu<AV@`a{a-t? C5B` aXa*AU P9?ʂn.s Zh1Lqp `IqOO 1@ Hw,n4P%P@P#P$@ V$AD }5J`g pP!h$t7,ÂbwEeuWUr'?9v(-]7Q ]'͔(>  P9% D9CB@o@;jE `&E) Q@~V׈f*Iۣ³x0beu[)j=Ev{ ERu:w$V&Q#Xi$6ww= mFb&j-&\@/֪!Sw .-b; ,G &dpFGpr 2P=4¨A}d"P:KQ 0e%0 `3˜ڧņ1N4SD 7ʝ KQ"  V=6v0yiM˔pU.$=P0_VPq4&wcP2U(QXXU#/eՊ)==LVWps9i{G@;0`勺CFAQADXiVI0!ꢇ&5pPp 1-WW0,!8p &YL{`諾|+[4'6kBۿ$ <<H=̭ v~t ,$lEWOa¶ÿC[`î`U;\#]E?Rx@F_.AKJP<]0U|Yů1x` ƶe|iSl^oq̓<@]``}\1L;wSjȍ;%s9@A E ) QG[Qꆖ ,@o%2 oL\Tb(11)l0qL:VΣDuS`\[Ru=&J?=mWf<Xb (F\4Bh-a!JN u W3ppC#1`@0i1%F@C1 ELJ0UukeT\cPp}bb '@  }Dg GdQbܰ@ I:%!v.1W^(#+KH4qS4R[ ^Pfwmd<2a<#Q'l##^0MTE0J`u^ň^HeЊ"xm<!xWXmVsiv[f"d?2$SV+x#&sb۪R ͕GC #V[WPu4#Z±A0yrG Y -@gsJ ]%#MЧ  u } G Pv'"(UaVmde(ahuLvUx[w,O-p<%  |֞FFF8PjHvk=qam~0.#d *Ȥبm]<0Wj>" p{xEP*HTtÛK IZ5O@s%_3wK JZU0Q`Z-Q0dhBWvpeU㗧Ԋ"UܬD:Yu,a&v&i5׌)Rq=CuWA-z jo(#MrGbo)TtPPX8PĔXpsـy zIzrbdZ21T*;K[kZZptuud EE5FEF66VDFmvLE]= F֒,TսT$Ľ<䥲օU6 32)#Sl۱tqIF+Ķ pܺ)LoОl)M .]rFjT9e gۮhТ)]J]XZ,) M<):J:.db"*D9$ r%0u j[rzek†L Et1)q-y1/c}DI<5'H`D2I%` @,)taExdv)bDrEJ\Z0)Wq4TTUPm:AW`lKTtED u^9YRG`(^8#XTX!(ELM"aMPjbDFQr !ψM578dUĶG]!H[p]*V45EVdp!V<50XeB? f1  +L SRlcQx,%Oe,k"36RDd =PBH \ "€f,Qe?pl9!K.+jS #@g:i!Kӝ9*IO{sgπԛ}BP:i6(\acQjKHDRJs,TֲBMsSg=O %T*G%CRMih/Z[WM'e*Zu['k++jVyE _Z>jO(ai6INN(f Hs6++셙UaJW8 7]_?BJRdlƨP,"d(yU{  B(x 6WO:0ЃS$%0!u꠰cpǛQa zʓ.*XcX fx*H2~3PL 2aM@04 H4j  H,YN(_A9L2qNLg8+(  >W?yhS `@ jaI쀓/@gDhaab*LD h}x@ !a APۂn:%lϨT9d!C2U 4Izb$qϕ4bH kC6&&P ITZ䉲ABPa]U 3v(WL <(aX d`@'x(:\^6B[ \QnY_1%b:ɤ7M oj<&1&T58[@_-ˠ1. kyA#KX>ƛ Pe8܈Xօ(t:|]4hR0-h yԲÃJNmStjj3.D:$ Sϊ=;"E:MwPdA(cI rgW)`L a V{msd'Ts ٠*a`QP H ek2"(h P "3ya 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 () labltk-8.06.11/examples_labltk/README0000644000175000017500000000102314121053726016214 0ustar stephsteph$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) labltk-8.06.11/examples_labltk/taquin.ml0000644000175000017500000001145614121053726017202 0ustar stephsteph(***********************************************************************) (* *) (* 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 dcoupe_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 pices = ref [] in for x = 0 to nx - 1 do for y = 0 to ny - 1 do let pice = Imagephoto.create ~width:tx ~height:ty () in Imagephoto.copy ~src:img ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pice; pices := pice :: !pices done done; (tx, ty, List.tl !pices);; let remplir_taquin c nx ny tx ty pices = 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 pices in for x = 0 to nx - 1 do for y = 0 to ny - 1 do match !p with | [] -> () | pice :: reste -> taquin.(x).(y) <- Canvas.create_image ~x:(x * tx) ~y:(y * ty) ~image:pice ~anchor:`Nw ~tags:["pice"] c; p := reste done done; let dplacer x y = let pice = taquin.(x).(y) in Canvas.coords_set c pice ~xys:[!trou_x * tx, !trou_y * ty]; Canvas.coords_set c trou ~xys:[x * tx, y * ty; tx, ty]; taquin.(!trou_x).(!trou_y) <- pice; 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 dplacer x y in Canvas.bind ~events:[`ButtonPress] ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pice");; let rec permutation = function | [] -> [] | l -> let n = Random.int (List.length l) in let (lment, reste) = partage l n in lment :: permutation reste and partage l n = match l with | [] -> failwith "partage" | tte :: reste -> if n = 0 then (tte, reste) else let (lment, reste') = partage reste (n - 1) in (lment, tte :: 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, pices) = dcoupe_image img nx ny in remplir_taquin c nx ny tx ty (permutation pices); pack [c]; let quit = Button.create ~text:"Quit" ~command:closeTk fp in let help_lines = ["Pour jouer, cliquer sur une des pices"; "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;; labltk-8.06.11/examples_labltk/calc.ml0000644000175000017500000000762014121053726016601 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_labltk/Makefile.nt0000644000175000017500000000414614121053726017425 0ustar stephsteph####################################################################### # # # 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) $< labltk-8.06.11/examples_labltk/demo.ml0000644000175000017500000001335314121053726016623 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_labltk/README.md0000644000175000017500000000121014121053726016611 0ustar stephsteph# 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](hello.ml) A very simple example of CamlTk - [hello.tcl](hello.tcl) The same programme in Tcl/Tk - [demo.ml](demo.ml) A demonstration using many widget classes - [eyes.ml](eyes.ml) A "bind" test - [calc.ml](calc.ml) A little calculator - [clock.ml](clock.ml) An analog clock (uses unix.cma) - [tetris.ml](tetris.ml) You NEED a game also (uses -labels) labltk-8.06.11/examples_labltk/.gitignore0000644000175000017500000000005614121053726017331 0ustar stephstephcalc clock demo eyes hello tetris lang taquin labltk-8.06.11/examples_labltk/hello.tcl0000755000175000017500000000217314121053726017155 0ustar stephsteph#!/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 labltk-8.06.11/examples_labltk/Makefile0000644000175000017500000000440514121053726017003 0ustar stephsteph####################################################################### # # # 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 $< labltk-8.06.11/Widgets.src0000644000175000017500000022617014121053726014320 0ustar stephsteph%(***********************************************************************) %(* *) %(* 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 % } labltk-8.06.11/compiler/0002755000175000017500000000000014121053726014005 5ustar stephstephlabltk-8.06.11/compiler/tables.ml0000644000175000017500000003217414121053726015616 0ustar stephsteph(***********************************************************************) (* *) (* 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 ~set:!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 ~map: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} labltk-8.06.11/compiler/pplex.mli0000644000175000017500000000223214121053726015635 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/compiler/ppexec.ml0000644000175000017500000000422114121053726015620 0ustar stephsteph(***********************************************************************) (* *) (* 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 ;; labltk-8.06.11/compiler/lexer.mll0000644000175000017500000001165014121053726015633 0ustar stephsteph(***********************************************************************) (* *) (* 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) ~pos:0 ~len:(!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 } labltk-8.06.11/compiler/ppyac.mly0000644000175000017500000000335014121053726015643 0ustar stephsteph/***********************************************************************/ /* */ /* 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 } ; %% labltk-8.06.11/compiler/ppparse.ml0000644000175000017500000000326614121053726016016 0ustar stephsteph(***********************************************************************) (* *) (* 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)) ;; labltk-8.06.11/compiler/Makefile.nt0000644000175000017500000000211214121053726016057 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/compiler/copyright0000644000175000017500000000212614121053726015737 0ustar stephsteph(***********************************************************************) (* *) (* 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. *) (* *) (***********************************************************************) labltk-8.06.11/compiler/.depend0000644000175000017500000000213714121053726015246 0ustar stephstephpplex.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 labltk-8.06.11/compiler/parser.mly0000644000175000017500000001643614121053726016034 0ustar stephsteph/***********************************************************************/ /* */ /* 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 } ; labltk-8.06.11/compiler/.gitignore0000644000175000017500000000016014121053726015770 0ustar stephstephlexer.ml parser.output parser.ml parser.mli tkcompiler pp copyright.ml pplex.ml ppyac.ml ppyac.output ppyac.mli labltk-8.06.11/compiler/code.mli0000644000175000017500000000233414121053726015422 0ustar stephsteph(***********************************************************************) (* *) (* 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 ;; labltk-8.06.11/compiler/maincompile.ml0000644000175000017500000003421414121053726016636 0ustar stephsteph(***********************************************************************) (* *) (* 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 ~f:(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 ~set:!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 ~map:!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 () labltk-8.06.11/compiler/pp.ml0000644000175000017500000000242214121053726014754 0ustar stephsteph(***********************************************************************) (* *) (* 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 ;; labltk-8.06.11/compiler/printer.ml0000644000175000017500000001537514121053726016033 0ustar stephsteph(***********************************************************************) (* *) (* 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 "@,}@]" ;; labltk-8.06.11/compiler/flags.ml0000644000175000017500000000216014121053726015430 0ustar stephsteph(***********************************************************************) (* *) (* 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;; labltk-8.06.11/compiler/compile.ml0000644000175000017500000011005714121053726015771 0ustar stephsteph(***********************************************************************) (* *) (* 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 ~set: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 -> Stdlib.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:" " [(if !Flags.camltk then "(List.map (function x ->" else "(List.map ~f:(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 -> Stdlib.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 -> Stdlib.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 Stdlib.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 ~f:(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 labltk-8.06.11/compiler/Makefile0000644000175000017500000000500714121053726015445 0ustar stephsteph####################################################################### # # # 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 labltk-8.06.11/compiler/pplex.mll0000644000175000017500000000435514121053726015650 0ustar stephsteph(***********************************************************************) (* *) (* 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)) } labltk-8.06.11/compiler/intf.ml0000644000175000017500000001533514121053726015304 0ustar stephsteph(***********************************************************************) (* *) (* 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 ~f:(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") labltk-8.06.11/compiler/tsort.ml0000644000175000017500000000552214121053726015514 0ustar stephsteph(***********************************************************************) (* *) (* 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 labltk-8.06.11/Makefile0000644000175000017500000000656514121053726013645 0ustar stephsteph####################################################################### # # # 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 WARNERR=-warn-error A-3 include config/Makefile all-devel: $(MAKE) all opt WARNERR="$(WARNERR)" all: library cd browser; $(MAKE) opt: libraryopt library: 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) libraryopt: 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 library libraryopt .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 install-browser: cd browser; $(MAKE) install 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: labltk-8.06.11/examples_camltk/0002755000175000017500000000000014121053726015344 5ustar stephstephlabltk-8.06.11/examples_camltk/eyes.ml0000644000175000017500000000502514121053726016643 0ustar stephsteph(***********************************************************************) (* *) (* 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 ();; labltk-8.06.11/examples_camltk/taddition.ml0000644000175000017500000000442314121053726017656 0ustar stephsteph(***********************************************************************) (* *) (* 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 () ;; labltk-8.06.11/examples_camltk/jptest.ml0000644000175000017500000000231114121053726017202 0ustar stephsteph(***********************************************************************) (* *) (* 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();; labltk-8.06.11/examples_camltk/images/0002755000175000017500000000000014121053726016611 5ustar stephstephlabltk-8.06.11/examples_camltk/images/Lambda2.back.gif0000644000175000017500000015030214121053726021440 0ustar stephstephGIF87ao@ϪϚòߊuuϺueuequuUueeuϺϺߊ}}}UeUeEUuEeuEEUeu<<}0QaUuu0EeEUeߪ<}}߲Ϛeu}}euuuuuuuEeeUueϚuuUee]]]Ϻϊ}IAIuuuEUEE0EueeeUUӶeEEeuuUuuEueEUu00E 0 UUUuee 0,o@ͯ˱όۖΥν `%Dبq#T*DZa|ٓϞ4(S<_uƤT ]łYDq%^ |z.G}*%XRR6t>ZxV"_ӢVjVV[*LHf6~*&)۰M +I k-:s]AOeZ@*tgFÚ-5_*CiPT6v,jhvd߶kYlcἳ;+Zi eԳ;i^8wwvjуVGWnYjv~#a9f(}jY^V&}>m&pz+ŸdH y%L*'ZVd|1kmoZ',qI_䶕_~k>4z-EW_ϲ@TQ;K]Wl$&g |zwgs9Wniۉ o%j2y(~e;R {,-;Է?F+L37υNC*aNr>V-7ք%0oix-J6N3m9,}e(չ,8܌-9Yy7١hoݪgC>ٱڹf]+kfx٦z[W=nz'w0ԣy7È,Yƍ.{ʗO!<)|V+'ެ}u˟V[{"g,G5Fi NlmCR~3T+RS /k\0e,9Q.^ fIqE%ϋ~bMʙ2@ͣ,cYćԢ[g:R쌤94hTbժb8ʌrTpC\U8enY7֏yriMS:ΘSHǹᣤ0,e4s!ںQSeE©iVYqV-*JbLTJuVj"K-0G5Fuhڿ!ӃD5,rZ#]< Pv6[s>,#ӑ03)T.k:^Ku]jecAjUݟs;V֯ع=kRl\tl^gKlmM0=nzSr&uo Y\*_kc/gvHR ״Ugњ`6VݽrL[hj6V+1dTCrŭ:S283X\L9nPGIc4$'@ɚȋ䰎g 9 o W*N4twF4wo##`Y]-ga=2'Vְޑ9$ue/L+sӝNTAո3oB+N6/ zUdg@6˻pG,j+KNk`I6Jd.mn[K~r)IW$y:Na7Wf9:'+V_fbWVӂZ־6 :!D_17pO.t8m6} q_I~`|Wy+:暞dyL;-r3fUX p,t^ӧӷ rS*-:Xbڹ_(i>{g;LmDNy]yy[\߯9 OX)om|!'>]Wկsߥ=R~_=nG`}3]w ,߷·꒺,is&^F/bɊjI2OaxmRg|g5U~gĥQyZ}nWma?L̴緁~w'kdOLe\Lj\ Vgv&ljā vc`iy `ٌtYMI~Ɋy$`wRs{ʧLHzhiֆpHxΘp!P&  !{Y0yz,p1ʌzٞH0CJiل/jyڢJƊ"ꬥJꪉךMڬ͸抮 y஺7}9AָX)|!@}Uj& , ) 0F+鞠xj Z Pf{~v `Oz9J9ɨ+I:YڸYFxȉ(Qh 2lψ8Y8 Dk ,/E+<ۍuK)̘T{y Jx3kEQ=u[v Z) 8 0*;D2@I10 IN9 [H.@i.*\ 0{T'CvW˓j9ȐɊF۞iDE31@ 1c IͨJ٥E{j-*sÆ ̈́0SiF۹yꍊzGظܫ0]0܋1мڼɪyۓJU\0\()jhÇvvȎlGYɗJɄȽ~Jʦ̼  \\<}98̺̑6.Q)8Zy iӏٞH 8 I0&64-6;ū e=.ꞟ,:ɞh!ˮmHU W- 8.˿m} 췍;4#" Zp!0bcɿMٔwYȨuy۝ J94 pٴzշt{,!û˼ȝ\PJX p'@Y+Vۭܫ3zX밤xi9ԕ;pPا^]{)nL αʨ]xۘwukuvdۿ♚;I;e:쯡h$ 8 r; nD+c\;ȊɊ]yh.Ƶ)ɉ9)QWG>/b.#3b6ݍߝ\sM5;h<=p8 >֨\Ni詭 ojجγ}[KGQʐI;"|`a׾}n` @ؐD !F`F "xWc]3!*hf"VF \ jaQJmhB(XP5mEB .VJє=lπuV .3ڮF{'"jI]pƩv6X@~ZȄ rd.*|>z!A Gz׸Bsjb\Ne>,@HԨ ^C( 1걈OG= _GTb`@􏭵&۷7v^zU $*Eb0cJF:af}ƙrEPiZvgEEmf:5#i`"ɉ6>=GtTWv}!2R,9 7H{W_Ye^~ :ԶXR <(H+PZǂ "` fnpH$E%T6?~u3*iX^{HA~wd:HhAd B=- _eA%H2K{L@ βB/%--5yM88⛋mS +c& ;: 0svBy #R }`Bm"5hh`P/:!0.&, *TE( r?X,U!&u1-> 3݂$ 4?= t44ݴ 83!\wr-Vr"ytxrPNBҡيIA=&h& !Af1׭BM[i-Dd')cD7NTuZ鄜(aK)Ob &8॥x4\Ҹ<9 '2h!A 'U v(N@=FwLsT/%5`p7$8Z>%(h $#+*؅߾ժQ؃)ШUFVИr O0)VH?2dV ?%qTą +cLǏCDx kE A} )hlf !*G,3Atꖹ%SKЄFÌ_YdnD i394ٴSCMpgk ɜb~kg*JOͳ $?O֗l36J,TU(C 9⎤&uMtĤ x:vZ2mS 6Gx!E ZthBzA NuPS.9 @gJ9 z`8.C49Gⵐ$zo  l4SP_yQ @f5 pL'i/H :DoGLƾ)rf=N &39!4|.s4QW0Ǧ sM.U)@!ZP(OXD}#l YC0$ !.qP_Q^gs.F`=Hl RaY޸"^IB R3e~C X@PQTHL@Cp&uWz+8ռQ>@b|<2)LOdwLLyj .BwFxg0΄# f$㔀gt*BC#9})s!Tfx@R x `7k4!s=l'8E;$БVeA's5pzL> d`R]ØmSj>Vz7_ v@tCЁ y?Dvub;0: b~l!UmFj?Ey\[(A (WLDn 8ͧxR_ 1 `'. סhD@ъxǔL[Hnloj_+;y $M^'F]) 8!G q+11`A,&:t`cp ~t pNt`b`-ށe 0dt%88l'G| `|.W#| ɥ g}}56p5P~$w;mGbw rwk-x6)Q"p| X9SFHr[%:x $ၽ Y9(H *XY 6c<˓dl9ddn4]49 8BaX6 ^ .c>nx>,=em `a!oh)U=oJhp^EO GN/@4p63 31.VTQD٣p ߱q}Ffao.0a 0 pze+tP`Vls7Ԋvbs"Pebqc%(cd @gvusE *3"o_3) "rLa03w7Q[2ud1*?F 9OSQ$*5+`Ty y XaPŠWY(yUOȳd2CglKDICW=y }"'uTGC y@>SgKyjs1!uJ?}ضR6fy((>4 2"zG}Đdo7ϑ8!2z_#r2 13:3}!3Z:(Ρz QGiyE2U2IJ#‚6dl@s>3tH1x{SW'VGPN`|j!y&yvQ6U4/ L,BcWSs?r`hwW1$va4%ULhJv2 mT?P*G2  O>q:01x55R*PH*Т0:7:s35 eTց ˚1Ԕi ڊZl"홖cT0oSٍ~Я4 QaC K9 U y_TV-+*v9\rQ,H<-i6<  ;Y&>ڙmS25`Xy.dT2"Pj dB!Ч,7QQh\=~#g5}5$o FdߪXV?>/'+I*`* !KA(U12u2:h'!ށ+b79RaPZE)͓{5:h +Y^9N imy e4.W5rr0L®Uc`eYEX*5L#mq?~FupF^R78U@5[^Q5streɘG2a ;*0x@;l2&Ȃv-]c!su 3}XыEI .K;uF -s+t.$Z'$1& QEl8pp(q q&/"{=怮:56(A0=D#9F3 I"bIU!=9SrЍYw/  c=du*"AIR5 Z}t>K!<*ׇV5J;/ga9Pʭhוg\QŌa*PTOwҋgwA$v=Z&if $#]ڂNգz h3} ;Sx*Pu˫ԧ*du$L-ep7j 7 \Nד>  -\!׋cOZFy8 ܪ,R?i93d%!X@l'foKV?cL? `'j( T @I;na "uWQQfڲA S_a';fa47E(? Fm@뺸a2BQZu˚'@`|z".+.G*G\w2nfJyU"7hz Q8/U3v inf)1u Q {%,c-&2"*M WI5f IP,7R|f<5Wϩ ޔ2$2> N y2 z5` Zw#ℶ*zyaƭ+NF/l*AK|Q ^< ㎳l)ՕQMsB+hQ.'SV3e|Qɉ*Qg\W Ѡ|]TD|Q2A8'Zøm+MC n'hدC>IuE5v̰n`7g+7"($my:\xߘs(p5vx}߯@eLcHq+5LJt:!;Dn M榪 G YDCi.p[b@RJ腕*1 ">uSPT@..y!QuVF8f "("^$ա[A\n0ѣGQOo|b~F 8nt &$5(B;$EI@ e(VV$;BlKK{ D"XJ B|B|rİcJÐB 5l@P#4h|B8\ np `gg03zƌ(aIFa4M*@ $X+*ܙ/SPbE8u="1IBJ+ :!ZXJE ùPGK2R 94Q'€Qz`?u`1k03yF'd, :I m EpG*#3yA!l1G?*yd5rU$- bKSj&$(T` +y"b Un'!o1}Gk"zRF.RShU0n]hXe$1+5C6CGE1cAkY aSHd`Qb ip Lv:಄U|2r`ȫ]D 2 ]9V!llȉ.x)@#;wX-B=R} `-S ,a.6aQgXVYrM{5MDk :Bߓ $QyP* EG!Uq.4NT+P2@bX]CV`815 nPeЀ0F=Wq9j@L1w]Jq$| *NAȳR84 tFcc1Da+l@1<.2sgPs&tX!}HI w @PC)/GT%>K>r+u Ac0W{'% 4`U+E2$0T2E@<`  2]R 7T$!ezgx>mnE 8-Rf uPL2)PP/HZt!4 15/sr1G**L7)r +V$wdp,iFxIp>PtPbGF7U>FVP77ؕ 3ThGI<%PHy(+m?B+#(a+A/DX!pTB1KZP1-WQ0J/0&P:O1!tyv!ld d5)UyF4=5P' mT_"M7P34qCct s yR"-0F]ICu$@T1y-UdIE!!_!`=Л?;]w !h悡AZ'rb~1$ݑEt-+u/+n0@]DZV>,dh-  /915Yx#ɐ*=W~2)X < Iep4`RjPw$yGBTE@8Q":tH\t_jDPrJ52x86E#Atg!P\̓}Z*|e)b#rpE}Kkդ5FFlSUj̀.BYt@7`ln*tdru:,§R!zzxq鐨I])j". zUzъAZ, ʪϒЮ5 WS#p* V( ^)4 [Tɠ_RAku@9F8m}t WU m!u)ޅ5 &QP>Е顣G?"`Q=5DhNW3iR,9_ EaWy3AEp_zr[TWJpw h*$suu% ~ ? S@wk ιzOEzQ!p*/pkمZ:= HF 472E"4-HZnfw1.+p`"w\Ww x>vA k9*EIgRUXX f,QkVhDQyV[ G`f<"<a}z^ /J ܡ {@dHu5O?G"1<2`RW#Q&AHd-XBk_ )}N!Nvq 1\hǷ70 x@ '*(qH!W]9-:8.K5q~Qt[D) c)*1GĒ<P 2ȉcrPG]@rdx )\xoaJRTYD0pmitiG>?wKy+!& xI703PZp-phôƎU.|U$˫pMq$7R a>a,IGc<2^}5`& f P7;PHhŴl Qt!_@ 3С+P9 NNGtKry|L}4@;#5efq^ZQ(sZr@  9TyO1)#wu!-6Yf(Z׌;%|׈|E$BɴP4*2 9#>18m 5)U y0*%*+!Pt*I-򴷕_̶@>OuH*x4Z>/#‹QoP-zq 7@?DFgK'[avBS2B޼Z [M3kW @P6p#*"!27mҏf_D֢]9wTZQ FS!P "~PJ1Y(qJ}*@ `⁆}*ΚB/I2^l*:?lQ^4F~SINM R*TVykc! ^21e=;dLlp~N2Y/)xz|>w~޶a'A$V.k( rY)F*lQDgfV]P_6H&G|* 7̀><Е\< t!NAS7 <_0$ s7$`!< N(Mpҟ8tCם "42P2ws%t,2Y.x7Z@/u(>fWdQ-!_V:vRk4_ ?XA܂ZTaQF|<;YP,0푵iw򑪻>!%++ɛd}>ہ104A,_,eE2~mQl 6ޗݙ}-:H E"!!!!h(IXؒ"RcX(Yb*#RQb!XA[S+"B*L( "()r*S"QM#1+R!rC/a"@pAG|!ބ%2ntP Z/8JԀY Ai,X!URwb pQg KC9Z$d  E`Å(U$ 6@xj]0xzKsI"".K*u0)*o"T5C 4<`MwT T0Pc0A_@B]Mc[;"\AnRE5xAdBƒ"~-R$8EqQ\3bڦ%a*]sNQQ~٦ >'0(a<HQp@FI 1Fl#5ֈ"E"- -_o f A!EP ҂s!C2MXAi0#i22R,' )w5#\{AF 5d_a#% mFB#$֜5*Q!,7/ȠK,ӜJoI S|٘Ù(40!ujjy }`hD*OhfW饙Biqyq3ȤLYF骭&vZ뭹ګ5)ð" )2 N8GXUrW:".梫.q.9&Gܛﾂ˿\0n) SC0qe*jֈ` /tN20~b̉JYzs/i6 ɯ+8BPנ#@Ci2)$tzWl'e75,& *:65sBM*_$H1[&eJ_GIГ%(*i״*%O1L3!e,tBHLR-MpS ]+H4vT= !aiTGoȕEPFN`:ԧ\}Oz9q"? ц" # "p*K 4lf F5'; Z}W 6|ՌGF[6Э#!ݴy:=o"ԻDmc)OxW ~C| Où(ZrPFHrF)ǀW 4f!>$=i6!6CY* K5, e<&`SU @tSW40" t1RpQ r s%34b%fVV 35qB=2e&) -YrUPPR!P!zA 8x 7}r&InSq&+&BlG 6N1K@baC=2= UqM>e3ِQ DF (2!N)$Q1␀Ag~J=7"=M2|3aW5FSb/e΢C*)@A Q7)T%ELIIscG+ȰKp 3,p%R,1OV[BPgC;b8 O; րP %3HyB h0(Q,4@#pr * \>!Z1>\ DDjr&( 1C!p(=D 6Au" PV+΅!0`h(( 4|`tzx fl c ӊi&:lj)pcիz"ǚnʚZ+4H1 F 8z%s 5ߚ ,P 뺷&KQLGЯ"$b0_5а/q9Dp騴DM E:6pFPb!E>q Z:2 %E)FHYwe{&^&#q΁ +f` ,"*]Gg"b2yDH-pQTwL )0h3p ¡E,&Faor[vV<#fVXW?TPa Z@ pE*ii< P ZCDp3U#EQU׻:W,,)V0 fAS|@#I c:D_v(+4A1+ò- H )ACP b`<˩>›Rl,J05s^?#A,%0\#% <.!JȥHPC'aI0]h(q^W pQ&aJ) T2_URq =`Φ)P gydдq4@Uvd)YoA<Cg-x" H\S `qp!I0"Pu>#ȉ)@R-% Td#|"` & td0AI0lfU1c$`UV\ @\ :!3fY)E ,EA gEsƲU,ҵ3I%3|XpMc}M5C'20Q< s,UhXA DpTa  ۂR9BKvp { Y-h!wnADiUT)2C=iLl7E\spX7@0@Lg{* \4fYFgPE%$`A P G%>#nkG$/Co+.$ .L@1ed2ΩP˰dRR  3I}AjPtB<]~("x*ư**)RT^*Vzxe? 2GC1)VZNl B*`=XLYV~N ta|,Lp k鳹#ꤞW-Aೱ8Cf59!^ ,c7`쀖 ~z$A.DRnt#:i@cѱB$$Ù@+q"-1@ >Z "Q{fK syGG@^{'"PV;b r^ǁ< <X"^glFR<sa}7sS-XaAU}d1-<#W=`t2/0HyH jIa>---**5/I2DII>!>AA2>5>-A00D7F*>CCE5C*>>"5 -Ez`2H5*AI$>@Fy@DIƩhAV"BH(R+AA,Xp"hC xaD! D !B 4p& "U/<ʐQiY\9 Hx"dDP# JE萠 MjtPZɸJfH1D5BI?>+A*>>X D-֨P1Dd]f4;YnG?B'Ye>.7:0`nV1 %E-?1E|Ã)ɍNM8\ QA TX !c!!XAtrϔ6 "(+B(+1^USՎ bʨLYX _YJƤBp5$`AmSsi\<+Aa*t,|*a"+A2 Q7̎Mz fOJ`+Ao*|@T! k6S )'6 CуWX--"|4TtD GOd+R?a4=AWxv9 t 6"x V  8(%m#p-d $qUʠr;?DBD1>+R\^QHu1kl mGXudPB\P#FرƠ|3 >nfF|zDs4DZ&șN|=hFI>m56"  >{8D4QB YlX6F6uc1=fX>@9eC,`z簄ylAC6HD˛zIezx.XHh D@`GJ 1Axq""Nq8o+&|Wsj&w:EL`4AqINMRU,K&‹(z#:YNG,`ElQ5ih Nȇ[`I( %#T0SӚ P22) @堊jpbǩر,m1r[!z0HMP$DKX-jp=4VL/>ƴ SK̠qBLF lScĤ- A Ӂ&(9J&Aj>!n@LR׍mQ^f~ց!bǾDjcC8e?2* ]!VF5) P!2:$Fk &lq@FGi%R< FLia6eǙ (DiA^0PH:h6{܍@$1u20LExH-ǒXDHHVxׇRu0rĘT_f\󌳖7$:Vr<&e>j8T "G38="+ġ ơv@cр=uQOF4!~ bE@R $I :u W6Ig^'%2'Mgp7{[Q`oG2BRAbAP#!U+09`(%EVx!"#<5 +R` *VS5gfQ,E`E2pMA%&Y0P#" P!PI kR|@Q3s(%"s0`cq# B 87'B -.,FL:LqL2WR'# ,PSD:PG#A1ZQ wr D+S $H_uR2Y 2+4Ubx%1 yT"Ug U[ +XKSS! H%2P '…,Q\n?RakgE:VmB0pMpL 8FnGJ6sK1+R1#TK0%? }!OREi %8 !@Hpƈq<8 8!鰉hA u(4-EЊ(G43\Xы$Q76{Fq!dRRHv#,XMvؕ\% Y2 (D7`˂? ΑB8BGi+@װL!!}DA,"2 YLy3+!I[df d C0C}arQXp P #'0;: PiU@H7+A1B#=LG1A) "pP?6?U]tVx$p r5or%E8.PJ@P+ $l,t3ٰ5Z" -eddT#0C<+$C i} q 2GaVw`VatAw8& YbwwIP {r5Q#8tK0p-bA*w* iEPx_Q2%} 磠c'yb1vuoaIx`2%*'?ϐ*+GDkrWWR//b! `CnsS!!; 20|A ԉ#gJRF*, pu^+>_oU.p&1?RI0aE*1"wpGU `>r0&!qCsd-C-70.Ӧ~!,E%Œ|+yGTFHW#Bd7AAeBXq?+!0.7 [XG #v#0h g&|%"RKfZE4Xdq:8WH aK9,GcD; -i4 ) D&CB o=GOW1g+67bAq'b:I[wdQu O& ,x UrD?K ! aveM2XRac! #u#2@ ]SP0c `%)/@/`="H2s[2Ql o@34i}2F$ưG ^+weUI&2{P&u Sc d ~(Q {vLvS(`_ /7\(? HKP9F,q*PV\!#S=5!uP-}\aA(EBwE|rX+@B R mG\Jl`*> !Ş@U\gWY4]],`,bl dlƝp!B*nLU6 sL;`\%|E 37ȷPȇ,l,S|3 VAɒ `tqpphS2]a&if("^s1-΄$W!67g].TE<>^PA4ѵG4YWA@ ʀ ҋ&^(3x72>qY%) 1FP7Y"sB08@8m,M`~09 YNK1XBGsH0"O Z'mD2@tK} ! /1La( u.!ˈJ& ${}>qQh: ?c :deB!XDmJ+aT+wPa4xޜЂS,p -0n6Եo{ ,́$7GRfOU]#p@TmRM @)Gly#bGt"Fd/*K/v pf4P@tq/\NJ?W7rkQT?*0Ӌ32Ft$݊C²ei!0n2@_òK1jFyE@j) 3nq}-z2^U3BG'g@-f(p.X27W 1WPT!"!!#q!qTQRR!"!BSSr*ر8##ss(Q8irc,]M]SC$S1T. 3 <`Ѓ#JAȐ\ &5d4taF+hTq$&C|hQN#>* MHY"HEzm*x8UccHԔ'OxX5Ga1m!Y3BQ &*k>* 9pk[rqvb35I$ jԨ"Di$)'C c0bEH@2eA9kZiײm-\Υ[xBԻZ?4†F"F58z9oH %9J-L5ݔN=tDPCuTRKVQMmWV]}BXcPg?n\t`W xŗ_'&X"b5-X(rEdTYV"g@""ZkɶݦBnx)Co &%#%$ yUcL-5֖6 ,'MQ; dW>'!BF`L䨠AE|pHAHhqC~Z@#HRECrXMtCVBAQ%tPMT(AtS)NDVupý%"XM eHwAɧ@%C&P%#Z4Afm%=|k%$2O0AM].@ CF2q"7Ѝ Ih/UУt+xeypkK,~J[P!-`B}U*>LO!+n$W|dm 7C"f!Vp-fJ b%bNa壯y"㨕 `*NOD`#`"I @*W%TU?"0;IP(u+\*Bql$3%c?I137Fi8xIo>*0*}i˞wr'#!825-I0]AKʿ! h!ײ3br<^z2&,?)JVhx*TUfZ-PbE?ZlCcⷛTXA`B9ř3Jr&R7T%AlC|?``MTD%22=(R#M-X"Qa (~< |T߰M2Jn=!AA.frC(w:F8 A)#P%+t *p9B^~5 ŭK uF#]LP.)Tm pg:TؠyGH)'ti]c2D%(DAB稍D4i/ I\ūSPEx ,;s)<0끏mD>,쮉1wa. i„r8dOa?0em ;% 03wrr%>r ,XQ 6zeaFhxE,A !$,얋.gZfP^pL"/{盔$o8e)N ~6dJ(AU3 SiTkS&>q}U*$fh3Lfh6VfoYqE\<#A:Ah)F,yVl^ W 8kէe/NT, B'Wޣu HnBCb+#@_jdC1De c=22 N36] =Ȉȕ+u$_NitZS=2ذ lq&(<6F^uoK` MAc,Xc!^ED! =;6 "x&C+7|Q:KvA4fjS&WQKfMFP^:#Luz>AtCN6i3R!Psl\]"k- 02?> GPa5' 6SR zB DB+oj!\; 0?7pC99[!!D0FO+cс%836E[E1aRQ,8LHH Ǔ Sd4GJo!E gE'_+(7T]W^7{ KGI4@ɰ^> s=*U|3f3 8`b!"~w["WJEGB /0bG)2Q%3a!pNCP@ 00J?6u&QYU*-r/Θ~S!++=$f#,$SQ~ LN+4+s5@oS?'>t>e'F0'`0?jfE4wQ7?aICd'r=$^*CAC7,0~BPv #gPHp  Gu } 'q7 ]!lGQ d;r0]%/%w S̠;6#BBP LL0@t"=~[/b5X ceюKDB0J@P P9%S5&GP3UH_IS,I@!s x OW5'K1KA9I*`8^URȈ}Gr4d"IDj 2 }b 0!1` 1 `BS^Bf_P @6M`=WM`oxP1#W -p: "/iF$ P?0^B=0$$3 I~RX+@[W 4YMpg+0N1p4= @ (%3Y*♥G ,> 5КU F C~(S7WEp2i.y iA Rp3v *9 p3QCp}&ED`֕ŸђZ,#.j:e@!:%yp)j>,6/D1t: <BJwVGjJ>5u<rh ,'S6~̇>ƠSQ(OW&"]6?:'"+)= 'A rQEd@C7Д :Jo^r,@XN Pij!J7dZWE? ;=&YQC3^$'=R%bC2d@ R&E/#8eq@I\8N:*@{#4˔nātRgS{ %|,Kd@6 0^Jզp(B *`0CVERQdZ/Yuqa%aIS1d*i3 YFԓ@Mؠ5vy414~"v O0dD7q"8pR,3@*iQ,,\$X'w7g<Es%;Bz1!8

w2,2M|AjJ<ƴ_QO}$@ 4V`4?40K0Q#'!XźM3qx_P !zh[{dy>1[РqA#2 5'l+4q1}"]6o[&,-Dx:%Bwe$2"$@,Eq"=ʷeäg=Pq*x@q#?D>P3·P&zecqRVȶ[Bdԡ*l4̷7l /R7YpPD03]" &ELjAp ?ZOrӐPT =0#$ !2J0 [ = j-N8yQ'6Y/]2PL`?Sr䪷'kH>UScsXJ {683g8da(G3XtavqUr33&Η~l2rΐqSr U v&1 w-'F}~bWq GZe]Ǔm0E|62E C;-p$sZ O7ܔ0ܔ$7V'܄g?xgm,:Q2$ŝq)Oobwm5@s۽rֆ aޭj'^LdKM3ߊ'}Z4[ YR > p3L5lUp>~r_>"Nl;U(-.iaZ DG۰8Y&f<} q 6a9lJL\@RƂʩ|4׭kx^0?+gq_ h =?Dq3GU1,HIp|0\!aWFmB#! l(YC*=+]U7>S! ± @ 60ets zD ?:5!z-@41>]WnG1B|2XOyW"vh1AcT./L@E'>=J|_?s vu:i4 jOW4 ~ KYV3Xj1't2Y 'r+ :]P~Siה}a4\  @'~х-dk412@ )(@ݎWF{Fzn8TPT|B cgK9i JS\(i 227I5>>A5A25"*"AAH++5H">7A>!5ID! HH5"/DI2A>!"ŗE+A?**?B*#H"6Dӻ *,*0200!>"CH7CtAčFMzA|hdƍC6@hd`(R$ՐaE#J- ğK*a}9$IC !AȐK`R#?lRLj>$hC<12" k01#5dcXXZX$y݂˜AHXơ5Hl$#|b#{JQg ~P!m$ ӞRqh "H9Xc7 Ũƍw:프7^:pDu/Zg% <# z%+&I`E2 >5:CeE8MRxRDo;}B!xD&uNLT>AS $Ё K2``h2td#_uD|&uxgȐFT6Ow rH0sYh{Vv" Xs5b$^0'.5 /̕\WE@i‰|Hb@ Eb QМ-!ITWC@dr&adD'"$"biv jH`uQ2P8)]ER PA $AGz/<#c<׊,UMDuT<4Q%Kotd5DCkg;0F̘sȼ& cI<!`Hi *s6& &+v1voD*#-7H|PB\VICD F:$B Ed 3`ˈ@ / _%A@ n) FZhsɈc7˶PJ_$O#p7evxTM?C|%#= d? $Eպ 47P+Q%YJ?5BL 1 ; qp]#]"!8Ɋ\v+w>{N56&EiLsԤF5Y"kE;&lf^6P7o*7ep!S=l8r-(g9i9DҙNR[ Zw׵#lgn]q xAH혧zң=K 7‚0; Bv l ChCC|P j1rctЦe, z#'=>cf\2X`S㙡#Hą hS2d)0mZ `2$(#,!3A`Fb~&Ԡl6@fZlP,LU"jT nb;Ћ g>2̫Hгh(!v'?L"bHq00M!L% DIXhˆ% -Rr2 Uʨ 8dԟxA_W<0A%HxЭ‹XLn17%J1Mڕ ,- ZA{n rR)I 3 "4E)ԈzF;;$`( "ܕL AԦxIˆf" Tg̀TRxa`EYR!cLnX3ĸJkI`daų9&`B1Ń6`]O%@ElZM#EN EoIFI@y{aQ!t$)b]pKឥaSb24|LSĩ3rJi(.g%ğ?r;OL>p 6E4g9<`x""o+z|brd?hС;,ދiZHfC%<%$~"\+(A &YWDs{~8Xr<=dyF2HT]łߞ@T J#N} ^zVD{,Eb!$$NQ1za4TRػkLF "bC[S9ŖRX^;LX裺nF;-i&ȭ $]L"-3ljD1_} G@]%k♉uSFa1 &G[kzB[ɮ7iP<'**Вj%0)á+Ϩ]OD02y;!5|_=ң3€霉,]^]p3:C&;%|'HBtnlOsWwbyG |wp8w] 0 x$qe[xaCy+`yNyxyx.e 'pczMzd>$R5_G# `21t aJ6 f%/v vQ% lpR&2h> i%q+1 b 0`Hp~,pO ́C fIi ;Botueq #Mf"yrfP(F`KM=pe0\]F_K_!/ CT1;f-W& 0o `p Q8v v'H2>+%|_c%hj,%P8fShSX1)a!M5 ~#*L4qP!WvƐm" V pfU0p0# L# 7GO!):EW]zu v,A*QDB pE-å20#(uo-0Ɠ!0\PL"zBfJpa$9>F yVFZ{Dh1)9!p4h>8X.v{6)Tja>*6Mmw%Ù@Pp9O^l>Cuf'BPTQ8Q+QR}@L! p()IDGlSģq154W"/N)p/kB ~ hZ os@A"+ c>?4dn4!v5-P4+E@q CW$5s$sM-$R-B= )NYOiç"aV`q `"'`8$BsD*GWq -+Y6?s8ױrSr -Z0W_3@*A8 N]"ASi?Y~ayщq43!.=(d7ngpEU3'Q% Hq*`k\( r-.PI\l%#22Xu*g*`j BB 27&F *tN ЩưSMd AB;+J3.{r=iPVY@ !pZWR++t&&Q15D3?3 kA Xl:NƷ*;6'W4ICH<CY.È~#*rFG;0X-xA#b"!k$N?ಇBIZ7+: }H'*hZ}GJJpZ@J|WᰵеQ|Df g{)iжZ3s[{!k2+M4'󙍠:C4+ӹM50Z˺j -K,%/$QТ9& `1 `th &dJǀ`gi0Z8S@(T- 4kl3Pz3 * s;q 2t7c27- c|316 ?`+QAvzQV`ŀaeAL% @6BiI,ThZ.L- Q.YkeQ DKS I=§OXD9rNXO7KpTG!7 %P6Gx) %`&iBn'9t _ %ٱb5L''xtCtR0$D, wz23wKA֨O95-lPlqN$ܹfܒQr5 5؃_ȝPy&q4iC*=L0!b"# 3AsH}Bt@`vWK Y+( z0*V|0b&7 mM`~IR.3:4 ;'lBY)3bhv?s47 % y"*T콂A;0.YW($m]- 2":M^7P&!/ZE;ܭ><8rC *́Y.(0ŪmI$$}&7ҽpN,~6&1I k3 `v`0ukc{'0=@:Dg OXqq`#s-cO"Eq"b-`vrE/k4Osx` IsuA0 ~ |?P2R^PMY9_a/yR ~3sP$&ʯ1uxPSCXRrx("BrCITs#(#S"Xy!IDy㪨rt!A)c2)zQ$CBRTP}!1-stTbdQQTq14TsAI#d(DG L$")K4Qu#$AX$Q B($D$2Q #$=R Ş(Y씤F5Dd$HO sPO ƍ+*!hқ< C $0`$$Df@"H`Nnhqy"c\nxAħ%$8F;2 qN[C7Ŵ- a-ABŪczw\=GH0)",|LF;I@QɵR"35v,#I$K(w(4D &1&$S)HEZ2QEQ&7dQ&KyMPTOq GTX!Fd&hr IH` l,IЊxy@ !%HWdV"6ҢBPXb!/bUiŠ'͗ 4#pS;0\;J !TQ&! @ đA^d> 12ӂ\ϩ1<N'hRDwxaogШwL!C7&Y<"CDZDc@D.%4G?VNנ5VP%eH*ҁ't8)Zt V* aqB^݇]b viK %y9e@H2`">a"xH%SumdʂD-"x.l-<#▕)GfPxc 4ң#oXEA2 0TIsaTiEaVLvDQLp9B4sFc,Co0$`6P vQC= A0[a!9fV(.hF[ad9"b!n0ePnU32 S!pr8 3"=`g5_qt* K?k hJP6p*T6*ڔ(=0KAHHmOCedKPc-& ph9`E6re!{EHaHX =q:(Q"@4BxZsD%2!wFF I h,wgu "&ss @ dh0@JLD@2 D@M!1Q$ԡ rhDD>r%Wt@Uh,֥50GEph  H!0<0IvE"נFhPV%0% *!vvhH`}؍h)V`Fю!EC$hmH4!2!?v)CgY"#?Ґ> tp- #)%Y'+ْf0"PrE;=!tdA)`hbJcN P)@,uYѕ8ay0X,plp)tM%Q^m{1[hy)`hhbtG"n;''QIi#]vd63 E}L?>\2 hqHNrFW}{  q2x27hp7'o2<'0}7IC}0Ru2#1/(U" P070`$ `L@@ *PNmG%G0N^֦s,>ʍ"`"'Vc%F J&XR"}DF;3w/P]p+@GS`R.ӓY t< ]pkI}'YאBP PpX03i_0Q&oE?GGG J4w~JBjs]56EVY> R7SaNr$Mp 1Q$߲\jZ)`R.JaoSm@(7A?h^b!I$;arsw[`l1s"s[2\ Mp]O$O w{װLY*1Kv J.Vw h"$EH@qXyzh>" g]i(G4 `B?D)?yd6m bA2s#LoȀ=#$"a:QQ/w[S9X" J0 n(001t-s4"qG!YNGF !BYJnl"s/eiri&ʽ?d{x RE0à5C"@(Ws\]9I <# UڄXDqDP}PŅG@*W68),ˍh5T6 :f`(ROTm9:2 @$HgH".`O.Ȓ^hɁ$hV5(h ^Z,[ Tcld欬T`Ja0n~wDc]f^Ui/dj$ fy =XJaAG]rZ1Nȼ@  ? %Q/@@p Qp 4Ɏڨ 2_O0Vq/J^Sbo Dmy a  M-pOO]afհ\Ok[( 5VUE98 PSVA `BBɾ-ͅNITij9diН0|T `S'171eQ)]A>5>>A5!2F$ 9 &&#+AK7>** #?E$<%EJJ-?*KCC*A*767A>!B766 ,,7D//0FF>HH2D5""*H-EE6-*EBI2*<ᑡH E2Rd-H$#%L-[pBL0Tx" *`0^Ie̘(dlrL&Z lx T@h 7pȃ ySEaDG)0`fdCݐ⠌xCHI "$ajB (3CS(QBL7f2z$$I*HҙL)TC@F8` $x #"%HJ#>d$I"Xg=m bD "DޠAH#AɠaC!l =T^  >4:2 0KZe0!+>!cUT,&QFGd!%x=@zBu eCB1 0 X`P=ZvO H5g522h3#!% HB,IL-ZG3NA * @PhiT7Tx2Z$Q2[mրpgr[-sѭCuiwxxazͨǞ{w"3_} Eh Bx:Z2p胇 HE,vb3x9 YF"dP SRi%"h^Cd` h&Zm6 C$&Aw.?>JzhTBL ̌ixP7DX Un$T"H 2 1l ; _ !f A35CTTq3z0C *2!,DV^|_g VbC-HERF(r2MhҊ!TBeTAsca0 AELcaLh>D A4kC8eCADjD|y5-   ЁxbI@uд%2a!".h P h`F( V(1$x`AŵR%!@h@ 0)XHLbxB%,87 N?3΀>{AC# rHS+@DY<0EPy$I@ #| k(Gt1x! RhъВ1/ !"B.RR\a8( H<P&A 3h@i=X x `T5LU6A *܃'bTcun U@HzpC 5&&i݀ژ(`XbPUb' (1Zq 0|>D!r'>L.E'<G`x8C@_#A%_"(Y.AHB#5! 80`wi\*a ' KNruLXt M`&@a3 c/ iO| _ ;QA6>I1 :AD1F9=6D3 Jt 2 (-(ϩD4 M/UAt$[dyd$=#2E+NHaE H78v=?n `M>= g+T($A h;2 'pڲR&.Ѕ.<.~M`W0Y5[~= **<(Edʵ@\B5Y`ȋ@2!!0(4 %,=QmaBP A$(p\ D>CH`EǛcpS0 -n AGKKP0 (g<%P#U"jp D-?fo ڣ )g SLT" *=1#F1>` xp@G.  7=D33@DR`m" VE< I5c'~ FC+4A@ɓDcPTCH%Jd"*Blg^@1a&`56ɄIX#!Qd xt k&%!21spt9 7JIY<sGJU7HG|!f.sq =8^"`)ȋ c ._9,\<6")j":ѢPv-tWoRꮮճ[b7dgv=ojU%a!qGsWwdpw^U"zw(wGxm[xxGyryՐy z~SLd$P|ΤAzCz:0{'wY<&%|rG|Ʒ|`(T,``!@D prEE7ǕL LP!7B9 P9w -{SZ 2$mu<AV@`a{a-t? C5B` aXa*AU P9?ʂn.s Zh1Lqp `IqOO 1@ Hw,n4P%P@P#P$@ V$AD }5J`g pP!h$t7,ÂbwEeuWUr'?9v(-]7Q ]'͔(>  P9% D9CB@o@;jE `&E) Q@~V׈f*Iۣ³x0beu[)j=Ev{ ERu:w$V&Q#Xi$6ww= mFb&j-&\@/֪!Sw .-b; ,G &dpFGpr 2P=4¨A}d"P:KQ 0e%0 `3˜ڧņ1N4SD 7ʝ KQ"  V=6v0yiM˔pU.$=P0_VPq4&wcP2U(QXXU#/eՊ)==LVWps9i{G@;0`勺CFAQADXiVI0!ꢇ&5pPp 1-WW0,!8p &YL{`諾|+[4'6kBۿ$ <<H=̭ v~t ,$lEWOa¶ÿC[`î`U;\#]E?Rx@F_.AKJP<]0U|Yů1x` ƶe|iSl^oq̓<@]``}\1L;wSjȍ;%s9@A E ) QG[Qꆖ ,@o%2 oL\Tb(11)l0qL:VΣDuS`\[Ru=&J?=mWf<Xb (F\4Bh-a!JN u W3ppC#1`@0i1%F@C1 ELJ0UukeT\cPp}bb '@  }Dg GdQbܰ@ I:%!v.1W^(#+KH4qS4R[ ^Pfwmd<2a<#Q'l##^0MTE0J`u^ň^HeЊ"xm<!xWXmVsiv[f"d?2$SV+x#&sb۪R ͕GC #V[WPu4#Z±A0yrG Y -@gsJ ]%#MЧ  u } G Pv'"(UaVmde(ahuLvUx[w,O-p<%  |֞FFF8PjHvk=qam~0.#d *Ȥبm]<0Wj>" p{xEP*HTtÛK IZ5O@s%_3wK JZU0Q`Z-Q0dhBWvpeU㗧Ԋ"UܬD:Yu,a&v&i5׌)Rq=CuWA-z jo(#MrGbo)TtPPX8PĔXpsـy zIzrbdZ21T*;K[kZZptuud EE5FEF66VDFmvLE]= F֒,TսT$Ľ<䥲օU6 32)#Sl۱tqIF+Ķ pܺ)LoОl)M .]rFjT9e gۮhТ)]J]XZ,) M<):J:.db"*D9$ r%0u j[rzek†L Et1)q-y1/c}DI<5'H`D2I%` @,)taExdv)bDrEJ\Z0)Wq4TTUPm:AW`lKTtED u^9YRG`(^8#XTX!(ELM"aMPjbDFQr !ψM578dUĶG]!H[p]*V45EVdp!V<50XeB? f1  +L SRlcQx,%Oe,k"36RDd =PBH \ "€f,Qe?pl9!K.+jS #@g:i!Kӝ9*IO{sgπԛ}BP:i6(\acQjKHDRJs,TֲBMsSg=O %T*G%CRMih/Z[WM'e*Zu['k++jVyE _Z>jO(ai6INN(f Hs6++셙UaJW8 7]_?BJRdlƨP,"d(yU{  B(x 6WO:0ЃS$%0!u꠰cpǛQa zʓ.*XcX fx*H2~3PL 2aM@04 H4j  H,YN(_A9L2qNLg8+(  >W?yhS `@ jaI쀓/@gDhaab*LD h}x@ !a APۂn:%lϨT9d!C2U 4Izb$qϕ4bH kC6&&P ITZ䉲ABPa]U 3v(WL <(aX d`@'x(:\^6B[ \QnY_1%b:ɤ7M oj<&1&T58[@_-ˠ1. kyA#KX>ƛ Pe8܈Xօ(t:|]4hR0-h yԲÃJNmStjj3.D:$ Sϊ=;"E:MwPdA(cI rgW)`L a V{msd'Ts ٠*a`QP H ek2"(h P "3yaCAZI[h8HȔ#c1'M*LSB9HAE˜1WMJjL/iy5^)c.YRb%V&ZX# v"[.Q#LM1"gC&4aJ)XV4 ')QP)t ќCU5Mz7c<ټTK+#"Ӝ /dC [ה^#pDA8ni3)T ]5Ŋ㞡AEN-E. u TJWpIp\XPTH\%D"55ZjR\!ZeTBj)u'P)XBVra5$@BBw"PEV^CuP#d$V{DY/|《mI8%ETWQqeM84@IG@UiDu1CJ"HɤZRv(SAyQ(G$#A&;6/1|]81lc|LhQ$0s,ShhPt@V ^U[Հڤѥ֩nTD2ŽΫy$s"BO$IvażҦelde*pt 'FEx`SzEd.,mU(Ԟly.hEY43( BjBHA AE6%GMNON{2H|<"tZcXA^c2(HL_aJgM\g DsZ(8]b' SZ!9CcTKPPo9jE-x13%" Dł} 2(uevYCES#1`Eـf@X;Jgts =u}y PZoVPd!vU"ɋm~'x'jfȌ(x~Gj !Rh #Ђ( `D'%mYhS pR%@F!@q30;y;].6!` uIhqBL|vch@JXOeh=$1(`jג~ג~xGqW~gx=j( 0S.N ey(f}4;P$tLk'_1!(0J0-#d@;D5gW!#5gD{`H(xYZnqUXx('-~njhbq1pш`qyw{A ]Ix30a<k2}@B@,@3@!p{Z*CSe`Ivu+ԗhZd%5qD";!x, wYh~6i G7@i(=ɡkerQ:91X 2ga Pdf'pw0bA ޡ";o$@BDP#ߧUPHfW0P{&j80f ɨ, qZWZx֟.Ԩ]qojj=Arz mtXk,;K/Z X%MZ֯xX'/4Vp,!0@ ` GƎqJ Uru;h%":p){V){ٚw @iي=yjwiY"Z@. LH-h@u2e3QkuOGTitɤ n|Z$'1iW)ۋfx'z~Yx{{'~h(ܺϺjj fxq3^I^ {`hYmt#vShHEP4:G$k3v{pmUS5f0<ŗ)|)ƪ  ZUp[(;qIxw91?px9xyjY&6q(T5PT "숎'a@'ZL2% 1g:XF9zYBB+Y'oMGQh1X(R#(GͱIл=`̨q!=? j, =.c=ʎ3"05=(4 @kZJɢF;iL`@dͧ"ʕTY±ΜvYW ϝ Ŏ#) [6ˑAX!=wNޥǒ,W'ic4=b>N,3Pj_z:בS+4G3tIm: $QF4/0P'6zq$;!"Qtuׁ{j @9)Oؽ'업p \6j.٤mj-3?ڠ> N3c>y ɮo`SyҔ 3 PYm8,Pw1PgT6yAW0>nM3X {P x1^Ǭ;-m!}cP6]N?AzPf5vTAX61؁v4F%5Ex5ص2VٱRօ61"B0Tʘ(JABQbB\@a" D%S^uaю!1_o_Ooh'/G"L84 /&pÌ;j8<8!F@)4fĔ10hP#Q$*3ϞDe҄p@W/ `i4R mƲ P Y#n1V:XPp >Cwpwc>| &LQG͐!z=ReY|%(+ztReLBThʔi).](HB!L=dh@13[=k"1'жTn%(Y8 X?fXb8@:X:=vA U&<ԃg@Zf" &֙W2"S屢ԈQtiEu".9LnEv@H3XLȍ]DW 280XlLYۘIA5P14XgJ`:擠>s4Ѓ ̰h!C0 S8P4&>+Ll*T8 畲(@q,,(Dhe:&3[m{̙) Y>\p@ S@Hca@ٿobZfdL6C"xDH*Feܑ=h^E'@/hQBZ@apDv/8\"V4gl4iqA DAE,̰Udǘ^s L29o9# $\(L (A, i)~:"Ƣ( <qc3YJE)#P3ϥAr YE8v(`* JP&`ImWŮ8 ƼB,nOb.=` =Тafhnx>4D⨈c(0A(8JU Y1]#$)bg`V<>)@ Yɫ>!؈<@Ո 3ǃ !#az _ 12g*8"'*QфqbOU&`LaP` .l Ph(R iN&zCa5:h)!8yD)*L/.`F4PlP)@_o ;(DCrml*H7Ȥr>NW#+Xa1@'( !9PH4"8/A:Q2@I"\Gy# 4LCr@|0FXP<aL,` `h>Q$tT]LpyhZ*qHP`(IB1M% 8K*a&WE#0 ׌nG)"@p1"ׄ`$HK`pe!u4ơ @ȗ= g0%FHP)IE p^QhTʥ82P ʹ@K&W`oZ$(]('$B1WZ#u)_V^6p43`P98϶;C3II%V $fE Jp 2 CW1 zvFdG9 ob'|t r]Ѣ V "CWd93ؚjM%MJVVypVbбIErp63hV?`[pw?^$qEy5!28 aB`Q}Ѐcw1>D5Ȯ/`FY ~1@$Bw!ɶkP*(C5"#20#!t`4ua )33#FAg=JuXNJX@5#T|7OCs50q "}m%7ؗ^(>cA6f ~3! rRRJQ Wz1^Tgb3%o5ԑ `.zcq5CC @!`V7#9]C#U)/ZEbWnu }3!K)GW!PB8lpJV"PIrp^8u10rUW`d- e 3M GDb>R3p<7'`0Q-S`3XU Ob1  `A!5^] C0>7%)W qPV]f}-R213 )lA@#g19҆D0W2!N*Z 20z2:zL 6AsoC^@T!0  [\.j7S!3/'8dx0c`> g>s^BSD!z`3;h!`Rq![ HWN4 8V+\(GqmSG:0@Irm`hY2E \@w}8PC5\smRC\ @(}"(k}w66VDq~`8:E*0И~qd (U:A54 8R$3q 8*QD 1Nq1 *25H5Z @|?U@Gv(ߵdyD?)<O8G\>ih řEce9b2<0Xbe@5)` %S+&%FBp2d 01 A' 0Ӂ#I*ҹCWw~QwޙP67w91ZzsV)CDtjwud %)0^"e)Jf!Ѧ[) Lkt58P6 +1&5s 8S@Rap, 3J|p_\mUXE A!("V d')_w#wiz_} o8)fA70 _9rX@ ASc0 Δ 8٘)5 %x[Pi.*Z Yp b0Iae琰wy">}7!mrHK:re%)"Kbfl}Q^<6&(/p@LQxm2qȡuLn2LQ&6[c_A.h0aDM7(q"+"5x!OLP8R;Q)0* _Z]r]ȶ+)pAH2R`0YURZBJHJhT[+U3 5i4'X0il|a )Jt k77!f kA!"% *)Xg[X $w rpeD!ij~ (H3x#&ôr3Qh n5ÏS[ J`*ګ͗;ghʥCr2'ѕ! }jy^IưJ f"3P{;1SQ+R]Wl~x7/S m3GS!G_v(A19:&H  FY vmm_ᒖ PPyVZ:A^zЖVvok11_6'P$ee2_pY<_h, <OuG L9S[iBv[JA` PG]ՠi58dq#WLT(~bJ?^0ӫl)[e q)lZ\XSZI0 e0AѸL׊Ipп> _k)+&׶ RGQVI4Z 0g+C)t|a}~0s_P(3P);G~_vee7juFp~J]SZܑ2\(Z3U('&1sV`Za`_Tuk\ij.)W )!3W3zq w8 +pe~VTKepXJ^3EiUy`:)cb&pA6@uNq PH:- /ppFIP=p bkSdRV!7[Q^ 5<}u՞]JYrTpO}7|nE) q~ '*[!*2ST0.uP y7BX Їͧ&h.. (xԟ/׶7 5k=!u-}}04/bP70Z KPIT*3LNL+!ZN 4'i'Q/bEFnu m*׾/LPC?rJ_d u `,<@]p?7iґ4N3*s G;/N&QU+#@>S"T6 pM!;0r("! V@?r ͭk(G@0PG@,hijA!p*Xpᩈrt+1<]GzS`&``YqAN%R4aJ2*ah , d(K(tթFym uAd_ DD` Bh7<)Qc]]Q3$97( *<[#SBS3WBcQS/GGS]hGhVQ)!!NQ,JGQPc+)) BB)-,B9F9F999p<9L07n#h߇.;# J %""ZX)@@JB0𒀂QD)3FA@ 1t@jSV9bHR&if ByQkmХht(7!cIP@ϟJXihܩG2 0 IРy0 bFZVeޘ@ CM ialDSrwDaiD,bTE<4cEPaEBVtLc%B 9BpZ;QrTljO?!=IQ(lT@,E,BdDMtS%Pbjvh1 @^TE*pHA ЀHx!"Qx@lP 8Wp9ƤPMaa|i@ 8H}L$!63RAQHvoTD"] ]QͲ(@&AQ7]UehnX0[!Hhro* }6ÿ\̗aѕLVH(`1~%u&LA8~tͦ*tg͜Qins?S-:W B)p'Vc;$`OMTttNtmɵ.ݓ7pp=@Y  5A5q9`ťpE.\1 'E5.hD@~x)8JDin^ $յPhs4;6@3BF|$(@:!ZY TUD"AP#|@Q-eɓ X>D&'3*A!ÐV!8Q7^p Tt?YcA T8J lh#iYAb p@ ֪g`YJ<-# Cq`!¥tMc׺@O(']T0M\P.93?b hqnDS2!<s60@lfA>p"  8ҕuJ Oa )!eaf9d J~)(]шfp z)voO IAH+>t>K]\ C':d尜7W$€M#}jG.KMU}@b h <L%!@R%Y`AA,s>ᔨvB̠[ais,O NNE=llPL`v5I#@SH  H p SQ% Nr,C"9At&UE骴N$IbxHDWH0$? N(A .7A"OFb$'A4@ !Vw8x ЁӠ1$ag8 -g%+gPL\Ζ0yk4б <%OhA EK< #e TPG|*]@jij=]wĬٹMH]GN͑:$ { Cdig$khXAlp- ]o"+/0{3N0 f~q ! ]u )a S0R' !!f++6"0NAI5lI ;4i\FW,L;GxQBJW5+@F5wm4vA`}7t"bԐ6sܓaAM(>s 1"&p =U"h^GN3&A!b k"F 7I)XcV)3d# Fkg[\wm7mdr£I#t SO6GEb@t>C(u sC*{o.0#q"oMeO!6,R1*BPJcJ1W 4AP1GS<fR<6g.=y4#:@(aq A X G0!V "b N@B'[P=xl+p*POI13bP@5DPa`*WC5:у34CC-Vhyge@y D8Y+WAƖ_6$Y1I B@!"F Q` tb) u $p !9qQ&w#,u7EBd0iIP0,0X w "H'PJ+`<"%3%`Y`(rP=`=nS cP>)@Ey>a! :Ն9Z1 쓚a/JWUWU1!a-I@"w&:`Jৡn`6<1IpByyiy"yK)Pd;"%U'0zs b @5101X!"c5p4|67Y#q3rs 32x^{k#xXpU2 UY (B ϙA$K‹? D5D&qMK?25 1 K' =ōsucL ?"1/[PuB2"J4@gUplӊO.)1B$t8fPy i]Ekf`H X1ڮ ?@X^\5x_  QbEaiRVYZ KeiBr-a%x' W /c T7 fsPU{D@^"7?S%-w#32-0X$B0@I0P,84sD̓[Z3$=As#ZJH5aep  {2aFoq c1z [!"V(SN\sPP@#O%2͈ Mru TN@E;XQG》'-5Up! [ !,Ba05#;0tb/Z7` j1'"NEKAH0D>( 3b{ V=9&,Cg>Ygn+]sGOr-:#5h 3ja S1G'!>LoGjD *p 0H! 30=^pZg1 ZNN;0)SK2<(׶rB gW/5о;e6*۳-L]i0669A{'(|2B1332ġ5a1119x8q23ApqCs4"0C1U2qR\VA}=]]ֱ==m NBaKpSz?\?cy%G(XŁ eDyeה-(RHqdKRPp)Fp`1E |T`[PI>EiSC*9 }!'UTݘA!k Us`EKQl*WoծAl[g۞i %*O*%$ 'BƼ堃.-FrƬ OvZ` Q- > :iRM E3TZAG B^%c<`UUt"\Z. ,L|DW6pc@[X`d RU*84P PECGdFPQ E0@Y2&EPBY-$k )=MA8"&M@&D%=u KڳJXو<Z V=0aN65FXP06GLB{AB `BH*^l1,@eY ̀BL/DqA)EjbHUF.-ZlYEmQ(B]$DT  9)Qr uP1XbVFD4]y=pDM^}M4$oXE\܈j A+!EB 2@f `a2u $JAS<iQPQMYۮ*ml(0)PaQ'!NaK0 $B#Lb 9DJ,!̀ !(i`хe$E q.-'AI&(aD Z86\*^3~Ђ$!eKhn5GACaY@54ʛk"6XJ+{W)&1XCBF`fQ9Iж+%(qX#9wT M$NSēoAX~UQHBPXk5οMpJȓ1t!f@hL⒂DiL!#Cd fIAB"B,D c 0BR.\q'!?=Ax$!HӁu\T D /ph2fJ`A]PG;ugu827N~0pGkЌ%R@X9$`#p:bnapVQ δ7a ,撤 Iރ0&^f#KJ}zHmg#W3DbQ33+?WVh/ 9R=6a PX(jНc,ʬg \G h89.uVG[Ь'Ɛ*0t7+SP/f5C4$7͒CYfX,h  % MyI(a# U%VeG`! >VΐBݦ!] ɟ\ La렮F5%:bc6ӧoAeY&El=H.E Mvpbx @i5h" 7In_lR5cyF)gl qfО=3㳢]([K}e@n  ~i8z-nqR/-`n$]W$M~G0+~4TxE ,x !@z:tl# 6B4!AV2aCm mtA.7K-B E3ab6=0gD(N@@}@X&:`Psopa`v+ QPV&9 HJІqt(XdI&af!ATH_?f;$Ar.7G ?Fg*s'jdv|z3[BΆ]O<d IcIk 11XNahH)(J&I 5pDŽK?F+ouoyThPpFjyM Ui隢p+ P0 dfq({35AH!RhPKӠed;:X/ U;?94 "J q:Ζ"bfOZ`A p Ip& DSQn8N va&qD,: vHb3/iqcNc(!+p=A:.H.\my1sA8g5(#d"zTOdJBXhބih'尢Z;{b][W p/pG,ĢeC6>oIL҅<#(e4-: ,yЕ"_(ǚJ#$>Q5WV]]IjGۈIl3dĒJN+VVspUlb&TIGBZ ba}Bڪ{&B(I$*@<2jI8SCQHx7ӫRd\e౧V'~;/P&`4ƗTd7epFEJ;dGlG@ b'q*]z W;t3lxƇ}3']q3,3:VWyQHȃWu⎕/Ԇm?df (I _]PNTLNPpەp *;w O 7%*6WJu3c5h.^` (TPc[ ef3q38~}O]]J]e4>lɇ{PGtvY%miȳ`78 8toU*~</x/<]pϗJ?0*-tB~}xl8"lZdĪGB-P7ZHrsewodBul"]+op1E[]Ji%0#WEeP4oEV7cD*]ԀBCI>J!pJ $ckC($z\#aBJ"Oaw*Ds׸tm dPcGsxo}⩻쏽:۴8$ą\y*qpMuF4*VXMAsD*ʹS'=l@OQ_y4 IBc)hEƍqaG}&4Suv8+8\Cav/K4<3f7yܙ@ߩ>#MIB<@&:04:# U^S,0e3,a6q/qGx~W= 7X0ҎeUVwbhZ[Z} M8 GB3MԬI7{Йyѫ?SQ'~$8@5:)r,*DB5PŌU[uK%q !MF0J5X}x?7 jp16c- lm@kQ8 lcf;,K^ UiBꃗPcI(񙺙X*TZVc0c EѵP*' BfHp_)@Bi߮?xi[9&YowK5wK cy,oq;Dhce[DXS0WkL@AQ##GGT#VSSQGSQQVVST)[]]QSV+G)BNW* WWBNSZePee+PZZ+e+Z+[XSGcQeVǑ]uyQFUcAI0a#eh9Xaؘ(NB̈pC1 uI(I!W$M\5qZ^4>_QR/`tpVppGiU[͙ud㦍/ǐu1dQ(3[4pǰ08c\Qq.fcE*@@Ɉ)]]DWa1[Ԥ%BD˥<Ţi՘=-UZСIح[WP%4ru#lo3sYrݔ), @!5g`>IhH&t1]HGhZ1R46 %qa ˰ApI-"LDA^'DDCEth҉+S2C:%X]HT)u` a+9fMÖyհw{s'2,@`A` |3 1BPۊeh 1k-(bI x` WLBt %QcǹBSeȦKc SeTJIBR'e"Qaw@ ĘGM{XfA:zh|C`W8qL8g}dZ]I u1}xЅePaLdJ0@` 5P1m#0ɚֈ|䍸P*YAYpPJ)@)p]XFwca9n X L<|Ijpx! 1ҡhЊàNX21A") StY+F3*I+*I6Z~'T ɑX*"V4@M.^ t7i^MWS8b\oqŕ { H*r4h40tk UZd]N`1!pDI jkqZQVTF)]+]:Tp_!R֏NB P9YvR  DZY9k5Nq zP I\h4T{aHp , H#VhjЁm y z( B|Y)DěO[Ȁ{:lǁvJ&؟.,ICȢF]9`،cha,(t5sHCD Qp؊@)#xdh! "@ ,+X*Dc!9&BD` Mo,wн9cDeN4  b0 JQ%t.sbBz^Kv$ yK"!D7ZdN$b"Hx$ J@P1$cpF$f),7HoD0HAJ\V P4]]n!7IթE<V7;d/f/QN*YVB rӘm Kb:fY&+(#D4(X9Bt#SZ UP uc3;ȴ6Ugl$˻Ҵ7I#?zَ `JfJݸ}BQ[+O|$D dqm=Gȉ 8ѩׄKiM"**'(p% y,paPa)|3u,耏Y:%@m&|GCViĢ!H 0CT1'YLu!UBX`XK+oNBd QERR@XY0NrZGgN9͉LМH G.RPp1;tdx_X/$˖BZ'(uqvѡ.RER@ǝ+UB9IX;^J*n\@7+|s%Օs!BvHUxA#ÉU<&(8 C #(Nq}ĭ-lR h:@ KV|s,&FSGVD.ȣJ U`FCx<79YML4aw $ p DЀp̽(@QG( $8tv|cލM(Ϡq(R dW)qiA$#.Ybp*o|! 2,ʱgcG15vL@ǜ1E h .px$Cɮx$l *ยl. ,LqH=5<݄d-x9t$(`̊U0HTA&& ?\njݪsJ$pM4P.`>Gy1 &_tY"@!QQP&A v"$XB?!_? @p `:Z;q%00L33.B@$x1 2mע;c4cJLss4pJ'pS6дt T)bV+DQcHQ^ 5$pJG >qq3 Qq##e4pw̒:NqUwсG~S&"X h0vH;WBX? zPI HhX(WAg: su1!ǀ>H2\KG 0""8#6akK$4eL4VNՐW 0q{w:X3x-o)0&AUA̘J5?@Xz 5s$B/:2@2EpDр M_ d\q9*!ׄTpД  Ggl 6%~БU YQ`Y`13*_A|U'Or,I 2 :׆ І ;P'>0}2 ړ$TiA x6¨)đFل$9R_sJN)S3`tN甗u= ~=ZqGSf} !%BGMИ)"@9/aWF72>\8q*P]W* y KeL$ b *i 'wi6TĐRN)"=&Z LXZR:V~NALqUwO7aqX?Hz. ;=89pe* mikIvc@WoI|3!@.B C$\*f p$_`DG NّG 0 PTYj&@Y*ʞ=Xp B`qQ#倬H XpX`@P;~ZzϸڮP 0 ,P+,0Z$+pt F HUXtYD*}(Q9c3 / ,*jn~NyzZZ> ȊKPHq3TqJ'Av0zJІ:s5IE@?@D0vJ0uR+8B) 0 1 F)Q FNhoSKJ+l4, 9%:Ǣ*3ǪiXW51r}w`?7NNI`$pM@P>Y!@X/ 0A$@N-QOp#_Ms \ȡp W,pT GMN)> ;Tj8;2B bhDxE;~S p'0z}:zMP?Lmx;@E\0 Rw#KW?h`5-J774B7"P2@/?*_χ2f@vl ` 5;jWz"XK)pRB,aD.ʂlʦJPX.' s,y`xh#9xMu =y @‚f P"ME+2Cqqt,Yv\~lLL 0ɓPU9#W[)=4= 5`$v2:\ǯPơG—Y*/bo^=.D$.2ia JM^|-+M@w,nv ԗ}< i `b@PbiƐPP Y{;cWq4:p7. X @j~>YZkVG ;/KQK pYGe8 ##Mt)3* 4PlfQ~t,!Pz ) $ i)-hh ~P8VBw $zw4 hGi50zǛ>R20A8 }_B?+P].%e0g}`D2JJQqt1 [4 ܐɂ{Y^V*ςLb Pbr-i&|T  HP3X`=?y*İL0ds&&7 :)92R2H Mt'9f[6[5w$dq!BؤxfP,L3Pl=8mbBـ909.ɞ H#G,KX>$p1*YRv o5Lb!&($0$y")MkjT {ͻL *^^K$ꖮ0* pLB0¢ >'V``=PM vꓡ'g*3A#X0Na`H]+Z4nKӏO#( /e>.00M?R?p  VWqDa/Z 7Yi s` ԝl_X0=)Y~1@9@5`. ` z0tA<9 K) a dĿ▰*>KN?TZo[Ypdd xv`0;Ϟ/T7ko?!X`wW1r:$`?s>E@0BTRUePq%q16&Q6AA!hH12庪2$!++$5<`BcaQ"-c"bR.=AQP"ԢѲ"A$f 81*zW]t8 D@lpB $Ha 6$ ,TѡE 3/x Q҅!f0TH1Q+S:l)!.SVX2%!rp#D#lіXn -5j4®,`@`tfX@~A 3@N CA9f!U0LDFJ!d :0p(0@pD!cPMA L NT@ND1t&``D'XJB)S慤- #31Q S+.VBb61Qʘ"h Xig 4A6 1C  Y&1S QHFA*6@k5)u"rcֹC P48B .N(@% Jr\  M2`zRAN13 h`1Rpыhp\6)%la@` pδTpǪ݀sߐN ` ?*vs. ^s.tx,BT,4PP7v-B!`-<@ud 5.@+ &d X19:j=$נּ+|< ;oy $\H"3`aE(@F2H dZuLIslPE*: Ru`D\auBЧV; OȠ ICP_Qġ R /@q";aygr|Au$`znCs3VBL\`6X{TA,s!@^b^@7xd0Fjۤ^:Ql1q&0ggxd~}bwf ] T!nY`1IJw3 WNn317dRg^A&7WM.M`:A"K7LR>47^`\dOAׂi@lh^!@!" D;x"mև,AWH Zp,*PF1D8Dy!q3A&h"p12Bp z/  /~8/? ^qyx%.M%$aS1sPr>F.J`0PId 4P1;%"8>զ70(rT,@YW2u+H XDX֑&q& X41IA 2c #`0BA;_b pBhyV^hpVuWwȑ]IH9z>GSАP0<\ӥ{{h !;;ltB%DW+ONvOJp( cj;a0'!pXp7XgRwh dx)@O9QA9bQ1.|ba5^Xw 'L#Q`ٖ"1pT^N*pT6X,h0HFI3.@;@skBH&ДeHgH3pY)YDٓ58(1Dr7VϑrehT()(xpYP[/m8@wgqop%19E=z0` Y\=0s#q,+B^"@6TDw[ReЄ`|Ux P ~'k=9w;&/gB&y?\`DV 9' QX2!!eu7!Q[_qy0zp<>P^Wt)E3p P AE0s  L .;p 07G$ ,W 0BP: J0PBX0Zb&fB~ W1`9R)`@4 p7B*ٹWh&̱L0P=mmtR4W̱ B@$X!j*HzP^if|t'+ Z,Iyj3'f0kf``&#Б/qX'GP1AS3!rXQg^eBB+0L"=*0IPaPDs@{ņ B6 ;zS{VvCJ ] }DjE/ y/!.$A֢9YP( .ܑNJzKzm dRj8w)kiB30^!X00`\ \{Qz!/*w )\$jE1wuTD(epk{@7`@*( P?P{81?c)p(]2Ed:_Iz8Qz]+ۦ˲@y zOd^0/"6UE֗AZR)'!!t8MV ch< Es!s: p.(3Hy7zOoQL@0M S@GAG(& U##3#$( 5 |Zʫm6kE@0IR0]h ˠ@0J* 66+3`fP+pKvJ3`rv <$V 85[h.okf84L#礊8pN 1b %!:.4؆)̀Aڀuf yŀ\?X&Ds?0wSxzrzBFBĔ1Ĭq+ #HA\W "H!Ba& ,@Z[r447  xxh`TU2NP`*% PN-@ b bh@K5FaH0^" G('ޕ',JQ+@ R <*sW@}h@ dB~u G[%!DBڠ5-%X`䆿s]{&@ $5}X@-͔8aR0T_=S$M fGi ":gn(:R[0O'8(*Z/%#8ҟŒdWj}^Ԥ&^rL  dA%%A^VE8- z.bns+BI oh "0F^fpǁUP"W:a:C4A94^ 0*#^8*aI*P` >QPo,7Pp@HQcD t4e6e; @!w$ pm,P2\~эk܁A2GW5+Y5Qʠ™Q>@'t3<ϡ"4xF " ^άGG;jE|v2{I04X . >]1lXo_2$# 5dy &EXDp1*pF4cHA"=3T`TB>`alYQ֑fm1(!o#wWvkC2= ^؄Y4$`a Sp50> +X! @ZE+@ #4F@$ $p&NlB@LRa((7#CavvKb9eFj1*S+ui6*AU;`H;A@` jJ,' ,!ekR  AFVSP 2 `Hcj345PgYm'0 GD 0T1gі?^$13=)02a9ao,nWb =4$|S |Ʈ QV?@ |JV@BA}40ɰr^sd ʷuzC1s:@h+F2h]5Q+c Na:!)g(x)7)# 2R^.PO-X 7LsUpuI2%ks{sC2@'+ld`%!SHhwFPJK@(z+ !pXp10aFT:? cW^MD>_Y TU(Q090>fZu%CG@ sx@Y jWh ɐ=0[PpJ ʡnIvA FV1DZ=aAcAosw=A$E+' TO1=۬$xc + D'=%ub\,kA D((\6?6Qvj5<< !H|>'apO dFTe8*⶷̿x_VUN>1uB ځOFXXjf .z >W*H3;8x .V=$+l[3=\̗,PRSBg*P= HE`J(GGI[ԫ6pԒjʏ57 Wib~,2A~_hP~#@w)Mؿ9 EF> ͞ u*JFk! x0`J<0$a;P>e"  -y Nc"7-E3Uw@"ȗ^la3?M+gez1LA<&-B EF誦UpO(A Om_ipYEGl`QYdIVcy0D<`$OJ,ֽ4%[[1 `!cl1شK(0LZV+tg҉0b@RQSS!RSCYPt@2r52urt40rv46beEA06p+4D|P|AɸyYXQq2`"""#s/c?!2hЌ Y `"m񢍈p0chPBx?|_=&@#h?5ځIE!&00 StE2VWSreeESZ!*`R\8mțSp ( )o<ɹ^ (&gH¥HG5Ʀ" !gp2d1C^N&t'N*F I.(q bZ¤2eP.Smw%W[+rSM5.cDpKW<4( S^''Չ6l 'h:WIFY'41  t@-xOpD ЂP@B DlᶑEEX ACwA& N 褏 @!pBU &4!r !4ae䇊tQ.GhY10D)Е68"6 vaЈs84v4QŖ1O̤*,WBF 0iёEƖ۱?  \<W`̃ٶA WAddBTn)MFU3Wp\q(1tTU.l{nPI0bŗ>2hL qz@L(C9gT"+D@#b @!B"[,GRlDQI3a N&sfO|-# L Sp{S:LQQ_ͧ߂ W,0B. ЍQMW 5H5z}b N!\sMf6obLHАH@CP@dC>E0`C ^I3Lטf xѠ͚lVIv 0B8 LO_*0 "p TS. ؛"QQ9.0kN2 @ ;B't$7 *@ܐAU@CF%` _t"2:TgKlpy 6b5J` UXa _4(X" ry-2.(rr!.JY*B'd`bd ?@k) :IA C ", ɂX , C$q! C < p.D"L.}aر/ 뜨jQQBG_Pp@П (xAxP@+Ѕ. „C"QKiBYA E9N0AlKVD&L{\ *$;k;e )HćB|RƗwHgEDK]cQg` KAA,m ~ |2bεb6E1&H{цh0h@I||&ۚT2r6 B x(˒ )Dr "9 p'4{Iu^赛L3tmBbؤ5"oWHsR GlA漅LT@1D eB'A2th@sؑ9&273`i`%hay(}in 0(uI2tР i-{Јۏi<"SB>2> FYvAaijATBe#TF5' a :Tf-|>sLzD xa P@D@ i@4F'HS`!l"V T. 8ki Sy$ay"y(h?҇Hc|/q0hT!*CH'!2Sx@~U\P4sp@":el9`r'HEhkBZQ e 9E33& Bo19oQ r|1Ԓ8 $}X:!׃Cc\7d 0 R)-]%1y d(V';luh4/ DqFYHs<``a'"[%'i`&@v#I buI`ptD\/F hQG@q_\kq 7PF!/lG2y1PpAk@FlGЄs7%"dh,@mB+-p6 4KH,?PY[@RPYn٠ Q!:, A=8x1 ME pƌ V.O(O\zY Ln( qe1 [IW-[*$s5l-B xXP@be%KPaUR?Yp<Q&E7Q5`Fa:  'P*GE2 |'Z8VxY7z4TUGoV(\1@*-&s3 ) sHz iqB&W (>I3"=B@3_@7P #D@R%4X @_oYJ@ f0C 2!4 "Ÿat ?60'UWZA8(/D B4 dԠ }PW!:$0yWz$:WXĶ%_b J#dfm_f'oIC{Ff"ZZQ Q 5rrF[$3pe` @(Z\ccVUe@XE o)(/>d`:2iEP' j.?Ha#S<@'1"#htI,(pbYe+0KjvI_Q =QCϖH4  'kMP5 * e/ZG76U@ kz(@!Bk7vh:8"u2 .;5"pF7H0+0PP@Je O3K7r##" {Y{!MbFa!U?OG" x[~8'\ R1' vLx:ZL339"Z PpT_Уge7;$_u;\KJE7}ty_{A  p!qX !j/ G 0vN'Hp! 0yb Bhv WrK:A AҀ2v1% @GWh Kj/B QsA_X,w; N:>s hWAPaP6Jc~/6 VU7Yp!@ #ⴌRepFu>Ae:.}9ܰ1d7PBl;HUW[63s Ai@ ;R-[` ]ɤ"{ұ.AptøvW5 I&Ae u oqh /ͮ(\\Z4X $w)Py>! d ><tA %(`b#Z [[`"V{2 l| 2+"@ L;; Z)гq *X |s[=b'"D#)J Ie:s2" X~,pJ}dƝi82;b3pz)-ƴdA$@!g Z1FEr HYrAG}g0m8 :(g(Q-* Bvx)wPQdT隭e/zU%Dc`0UX^ 8P@bgYƬL x:`!Z.@EP:Z5M g;?r!HЭ@ R Te|1A91@ߏ$A롨**(e"*tr;; J,;<@&Q3<,_ HwH dP&@7,:Mw,>UףUȠ>Mٶ8/I0uG#] e50' "bNFz!o \ տhp IkpkV, 'mЩX;ű4<6tandC ;& 5e N8ŕURR d!]WpwyN :@pA1 {ŲLF#:5&1eYD>:'bI ݿ`'#C?6%-5YlK>v2$1A4Mt)bUw@+8GO 38bOV .5'L M5$ .$M  & "== `-B[Q++PBPiihXPiRP,B,P-B`PBXXi 4!4^ !J! 4!!:!!*p! @ DB.HtH+S8 #8)P IA-5s.߇KZ2UdCF2`#<pF LCE+Y=&Vˆk*"|F pKӢEX~ ʗIE ܻ@  W埁58uĥM 2bX)#LF"JSt&ʒ "v!#@jB+h B](S!LA̺2{V#@ABZkW_ 5MP77`\B 7+DP@^0'zH0XCv1c@QB-&`8u Í0S|DQG<'cdnUIHMqDL1EAA0ByP1rB!CRYxIxpIRYm$,П3B0EA.~#.]ՂW䕋^t.qM+l RhpOf T!\$5lK SLƍ`MLbb%E8[H"t19@O $1&CFuB{BD)BC)$@yc&B[ArR@K&2a{\# 6T0xE>|Mϔ3 g|F:P}:i=uL0FpieUZ!Jmw+tRtDpo)T!xәL8̉c|(G sC *8 Eт,&1@9[˘FP\+2"m@ QҀ,c^0@4Ј41BF+Djx !]%0GL%q)2PQ15aA,05a

q4xcH H)Br":p\P\ 0a$]#8J'^2l'!IbAH|j"zk i_=(q]a~M:V(ta:'q1= bx4I:'q'5a1#UK3n!2VV7!4GH^ǕhcY03LC(uܑ4^ ^4Ld0#`:QH -C@IDQIrb ~R1DG9gH 1,7"pTZ0rWYsFbFstα"V)["J f(gah4IM&iQ虞.p  '`vhnjfWd[z9iR%,Gz3 MG;H#|p89e@.`%aenUV- !dFm)Gn#'#kTkQS (:`0 {Wdwz'PA; (PhQg6a\5xHji,H,D4L)"#cA"GF _Y P/uȖ!(tȖl9^(6"qZ@ +2A H.05kd941\u E9'P@2ZMVq UFJzba.ٌ UI"Hr|I`,QY %ܕT`a6ѡ]T7|%4fS*i&ЃF sfC` IGƞ8' CapTj1'>@0٫b'e?%4H4yуG$RI Afԡ"AGVu`Nɭa4GVo,pv"+8˂1DSs/0$ LAa-EQ V ( vI IZ+ 7c{ 9 %P+ddhj5)" Ȑ';=MXN~BtT1V$t$q!K̩DMC?1`Qs1b `4AYZ *gMs Cz 諾3bQyRkE"RH(B74@nRqz!V"1(`hy5{D15O%d#dE@HK:@w+h4EPPI QQS@I\l%x=P9Ҹ s*+ggz/(BҔ OEX5>@'ceQU|k44`uCFΣau14PE{ Eɐ Fh.QC#vJ Щ6(ޚhmkKƙ!:2>)q#*Y)B볘 8S8# Gl˒{oHwH0{ƞ`eV]lj~h^gͰjagk&3LϘjl!(&989Brp7*Z?̣zt޺e 4a7QFn;@apE~sb"Gt# oP C4 whOGХ 4mR 5@kY " aFCXG8Rp?0V 2j,p^ uF,@䵩C!Q;sĞa2 M 9! r 9hC'-2p~4oDDVK| };AhBKQq kNXA PgeXIFp4X jx27(cG< "o~|V0]UJ(UiC#U`J [-HR ~U><1M7&'z)Lꉴ%q_T +TǫMP: p o%[ޖH\*MtK&d HE 8x@^y+!|׼5|wE~K_t75/z_p|?0d6xbstEք E#֙6{|R$i3'\ [S\vE\d헭)G]Pq[Rp'"x u[BfL)+Z~}p*6AOs1d<-^dS-oO1+P %,)s_,LW@ )z榥'kO}qr+4Pr*Öj|۪A H7rVGC/)+tY!'n*?v Uu<$bЏ8G IN# x;Bz{h~:|dkcyvWcO~Ј'|sT?VVOuhEC9'C#cdQ(SC# ?4yw7w2ss%kz`n 8uKRr*,w{m24s`sf|=wn7rCaFrl0Hh0~!mpZWwuB }wAV;6G?' 'C7 V|!YUMxtz&Bvw+'? '?22 Gs2M7gmh64t+r' .BF%*h@? ]T0 /|m ;0 #q@$&W)OЂFp +C;fu%tRt0ơ;qVM&@ BXqģ'Z~U`xq">rW(<~v"Th2Swb,352DsX#$h'K1gWY-;c32",#RpSe,T%]s- %sTs%5]+2ve8>bW!⎁v;'Y13%36B#vT&(ֲ7Y)E!pBO1H7we$F"E6b8d4651u4,YtS0:s3_R-"AbJC@6j!6Yf9Ƃ;[1 v#wIW]+HSReur"3GWu0L<ɔb$7~.H9@NH2.cRr(B)d,"R0Ib(i0S0rJRcq'R.(O+Wғ$%%E<#Vyj 6:y8YOs;ac-;iE="ES7sgO/3/Zm3b ZɜAmY;#6.܉*Z:4&UF2| 19(9b22EF2*8NczZJS)Qhr)2M)c2I:*w1Zb3<u~ٚy,2U,m/Vi5,v7RbH&8u35ɞo.h.Sh[/jja^J~I3"J7(X%"..70c'b@*"*Tj;+/`bSb)C:gY:`g:8;%㐝6Iӓٖi4k27$p2j}L/&8&-$Y=If@L3h$+Rec mx06   -H @ o0HK Po뱲 Ud@0Pa@ :J8 OiC@ ~rb q @ 0P` `  ӠP p`+P  հ {Hs4g~ R zT `۸&`%@ , 3bV&bus>hF`pa%p Z  _[w ˰ Πȫhod4a% :` " s"QyߐhJS 8`[d[s@ ` {q pO{`n+GZp`+; !"UWf4rhpv:$,pU%пҠ~,h x@{7bgSir{1,?Y;N,: ŐЈG|԰O,c;{R<5!aLR 0k*ץu|{z;3;; ,&i|sopI:qK ǶgT@ŵwnl3|F9N :;|ˇ\:KȦR#r+ ?n3``+[¶ ʠ ɐ0a`~Mto& p k lˈ\b| ehj"@sz6|t>ɐ`S@@`\uK, V3o` [P d :`v"{*d(gAul k <_  d #L:HIY0= l؆=vF'l"@ s@M`KՌD<0؀ ( `np3 Y $SP P ۮ``k-ۃP@4s9Pˎ8:-=stӆzP\<C6`C ]ў ؐ ` 7w@ = XOPͼۮ  ] _p @ƕ Y8(ѭO m~p6ޗ  >l̋ 3P9и|i@23*{`Z #t[F"" _P؜ D@ o  3No̒@֌P=-p C^Di  c%{ݨ003dL9l M׋8 P unwҋ}-΀`np * ?r@R} z  r?4"%  {`4=pD>h׍7]43Z%KT4B r 0k>}@m[M< ^ n8 щ-0 #mqΐBb%p BA Z@@ o ̼%w0,?g \p Ț8!gp~Ԡ t <ڰc 60CMPVPK 'p@ݺ@b?p ^0!2IOpne`; w@Ҁ>՞@ ` j Z u> -=P@=9P Onp; H0O+oYBp ,cS"a@ t0OjxP(`Ö-D }t^A6pUJWVBڶys޶y;{4Cona¥/6M+ ]EN}M0dC1D!BF/GgHJJ]5xK+sl86;sZΙgIDl雦 D"Fp7R<0"=&ھF~3#bƕ+1!jG~c.-T4R4DisvPxP7]5tKlOyىޞT5_mYwaafx#6l bGd<㡈$l=,^[]~VUmXA>CPb j'Cck45kHZ?.!aH&"% @V8\׭$^wG'QQba!+@4\sJ -JPmu`|2g|m'mzID{g,<䡵ky\3kUZ H{DLa`c.EL7>(@P@* x4y]Sc9 Jn2m$h`J=1OLшؐr38VK YȄgC2Z.@F5d2IZݻ MTAQ++x"HU& aV+c$phC88Zb_8VKO c!/crGdlU%J-1yc'F(O+bBlcx fC`@*NqVnr~'v4#,1kS"؜Lb:WlR=,Z%0@ ]7"ɂ 86W@,Ca) hNWMP#n6H̐CyIEy, a(Z"'(axܟ9QbDcOjP h!pͱHF2O 5tI-@E?3Hp} l@ PR`&8:yhVy+ԣ(l 2PB4(E_zjVg@r ;P8ͫM )+? O*,c9 Çv0\`Wԣ/˨M8#Z@qxDm A%45AV0f5 bCrT>˿Y^^,¼H?Ć4PC쁄tlmA,VM9woD.B7`QEk\Zk&rY> ԃ\@ I"@I`{-:aը;xa@,P$ W9hlK4 %P3eFs]@ $BvU|h"2Dn1`] c!/g9r2K;4ш20tR"+z=yז@(.,Yek5\~?9QnXx\隡G4wĤʜ^.nr/\Bm(@>CVDHl_v؃ =ePsLe:2bJ13]QG4"Ze˩0»VX? w86PgHC)agF {L[4^ 3jX]X 8QWMbhQ}d,VivװZO7Yb{W< IhPMn]?7H $zK80ěцU:ifATj]mCBCΤnzaMS((`C^ďONm҅:B*E Ȃ0Ѫ)CІe򃔕.l~unV$`]f8,yhBohBIQ\c ".tl:ډLkBIHk0 \@5 ruD⛐Nl_.]Yx9̲@.쳝kȅ+0]{_XRxTxQͶs8_mO&$/2D\ G9i(܉ R˅C%eAti8І)VOhp E5~"&IhISoȂ]0{Jt l?<>B 2ǑX<`O%+:6WWZXE+H׏(枌Rőa&ȏ@@79b6۔4M L)>\W( ]=YlF ].m(ab\#,S7")S1wނV{R &Q. UQn䛀9>b [  Fҵ$oUF}X8i%J2^(WElb8}}_`Dž[vY0CHEO^ 7Ԍ8)qu]O-O4`qO8@" J'zo8Xf2 Ϧ H,9ܟ\R@J9ݦyzx-s23-'g<_<2 /yH*X1Ѓ_k2|,*+l,08Q,Ѭ);s%QإH i^F}Y .3t@F ~MDP۶ͫ8y0Na9&Jd܊>JD ?$fμ_mrB8?2_̠ehP7 ao3sON 08s ]rEz(ِEqbҌ/f#E$Ϭxڔ>|k}x&e"T72>hAgF<8C b@-'ÚͰ [i{ȪC-|U.x[iܾ{ōeqܽ{:0 MR꬯ ) ğ9PJy6N- 6' ,u 3á*H A9]gQw`?Ac^S`5-ĸ6HASR8?؀ f7D*82 6(dÃ9 A>Pcr*^Tw![qaub] 4QO)\CF|f?SJ:jF@ ژ7 LCR/"6C Jral9ޜqtEޱg1# *E4($l0CXL$ZjA`lT+rbZ[#\c/4{/~C NP#:[!+²~vQ`aO=m/Ȥ!#$1p !F{g۸ n.,berRtCM>q(oy %aDž r2k`-R6* 1Գ@ȘA4O>t٬rrC89`0z}5W,Fdsm9A7iP2>SbM) cqAQP] `5[c;9,Rj4r '"Q-@B%6@tFSzr˱@sIk'>it#EtAm|`)KGC#-lb&~8Q_!6Mlק\a<5q.A*r Ia 3Ydbڃ0A/\/xfbzԳG C$AXp1j-fr6c֨l0N#R@--v75}Ω8P9`4 Oډ?nД0LC(' 'p`F=8mQAMЩdC= D#&Dm>H)`)H!kM@ޖ|(+bx )G300&b\`kb+}ш4NZ"  e,#T@4TAh#f ޠ C` !2=g3Jf"x}l!%X@ B1Jf( ,H>za2B [x c0 _X*J͐9$]@` 2qƉ0D<`} 8 |b G..JVnqZ@ h!3*caMn 4i5FVǒ%o F F:E/TEp$$(C;RJ2'4#v;shC_ hq،K!7O-$R k%&r Qd}=[vs"Ђ98am"8:Ɔ !`'@qTCֈz]*Ty6o Ss8==zaXZf}Wxp]n P!CbHy\RkNĩ8ĂԈE>Xܚ`%D\ ; T fHaP{G8I$dP }CqztiuS:KAn$ha)5!8X0YW[䭗>qAr1}%aOO@@YP836Τfn['9:-1ţ}nz \KpIve?:ٲ)noz?⭽F,HɵQ\Ljay2-](>3hݴN!lۻ"!zr,Hltc'K^t[fEy\rD =q)WQ~w>B8Esk!m-GNmp;Z(L^v!&.xRidz7>7 ﬍KA~uCɳ<]~aOx%t=?z‘ml_~8Ƕ-3ӻ;5'R5yD%SQ$ͽ9 `K6P#(0DBS|98#&>ֽCߝ9Eݑ7? H$>!8l"J!qɅ92ڛ:6SUџ%CS,C54lC*$\22e:R/z}͋"h |:X ¥ŌAB*dҥ ]rql:4Ăd3CH\%_Π W>:4b84G6>PCS=ű߶MfF߶ ؍=:>fr:M$'P B(7M: JH`˹6$?@;<0$P0|zc?T b9~[%aE4 >D40HC5Ă;4HC,h5DCDC>44A>Cfx'fn|i<4;O#@3HL2|;8>E?4#9ā

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 () labltk-8.06.11/examples_camltk/addition.ml0000644000175000017500000000441114121053726017467 0ustar stephsteph(***********************************************************************) (* *) (* 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 () ;; labltk-8.06.11/examples_camltk/winskel.ml0000644000175000017500000000607714121053726017362 0ustar stephsteph(***********************************************************************) (* *) (* 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 () labltk-8.06.11/examples_camltk/mytext.ml0000644000175000017500000000422714121053726017233 0ustar stephsteph(***********************************************************************) (* *) (* 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 () ;; labltk-8.06.11/examples_camltk/text.ml0000644000175000017500000000364514121053726016670 0ustar stephsteph(***********************************************************************) (* *) (* 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 () ;; labltk-8.06.11/examples_camltk/Makefile.nt0000644000175000017500000000362214121053726017425 0ustar stephsteph####################################################################### # # # 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) $< labltk-8.06.11/examples_camltk/fileinput.ml0000644000175000017500000000362214121053726017676 0ustar stephsteph(***********************************************************************) (* *) (* 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 () ;; labltk-8.06.11/examples_camltk/fileopen.ml0000644000175000017500000000376614121053726017511 0ustar stephsteph(***********************************************************************) (* *) (* 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 ();; labltk-8.06.11/examples_camltk/helloworld.ml0000644000175000017500000000341014121053726020045 0ustar stephsteph(***********************************************************************) (* *) (* 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. *) labltk-8.06.11/examples_camltk/.gitignore0000644000175000017500000000010214121053726017323 0ustar stephstephaddition eyes fileinput fileopen helloworld tetris winskel mytext labltk-8.06.11/examples_camltk/Makefile0000644000175000017500000000745314121053726017013 0ustar stephsteph####################################################################### # # # 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 $< labltk-8.06.11/Changes0000644000175000017500000000702014121053726013463 0ustar stephsteph2021-09-17: ----------- * Release labltk-8.06.11 for ocaml 4.13 * Disable -warn-error for users, add all-devel target for developers * Add ommitted labels * Update ocamlbrowser for ocaml 4.13 2021-02-26: ----------- * Release labltk-8.06.10 for ocaml 4.12 * Fix bugs in ocamlbrowser that prevented exploring types in source files 2021-02-14: ----------- * Install camltkwrap.{cmi,cmx} (report by Pascal Raymond) 2020-08-25: ----------- * Release labltk-8.06.9 for ocaml 4.11 * search for X11 headers in /usr/local/include if needed (freebsd) 2020-08-24: ----------- * fix config/auto-aux/hasgot for clang 12 (MacOS) * update ocamlbrowser to ocaml 4.11 2020-01-13: ----------- * Release labltk-8.06.8 for ocaml 4.10 * update ocamlbrowser to ocaml 4.10 * fix again file selection 2019-11-20: ----------- * fix filtering in file selection (OCamlBrowser) * lookup source files for Stdlib__* (OCamlBrowser) 2019-09-23: ----------- * Release labltk-8.06.7 for ocaml 4.09 * ocaml 4.08/4.09 compatibility: use OCAMLC_CFLAGS and Stdlib * include auxlib-in-META * default to -tk-no-x11 in configure (new -tk-x11 option available) * add fallback to -I/usr/X11/include and -L/usr/X11/lib 2019-05-31: ----------- * Release labltk-8.06.6 for ocaml 4.08 * Have configure use (GNU) make rather than grep to read ocaml/Makefile.config, due to change in ocaml 4.08 * Add "library" target, to avoid compiling ocamlbrowser * Update ocamlbrowser for ocaml 4.08 2018-12-20: ----------- * Fix browser for module aliases and polymorphic variants 2018-07-11: ----------- * Release labltk-8.06.5, for ocaml 4.07 2018-06-26: ----------- * Update browser for ocaml 4.07 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.