labltk-8.06.15/0002755000175000017500000000000014745615735012217 5ustar stephstephlabltk-8.06.15/.gitignore0000644000175000017500000000014314745615735014203 0ustar stephsteph*~ *.a *.cma *.cmi *.cmo *.cmx *.cmxa *.o *.so labltklink labltkopt Makefile.config config.status labltk-8.06.15/Changes0000644000175000017500000001040614745615735013511 0ustar stephsteph2025-01-27: ----------- * Release labltk-8.06.15 for OCaml 5.3 * Update OCamlBrowser for OCaml 5.3 * Add support for Tcl/Tk 9.0 (PR#28) [Richard WM Jones] * Honor LABLTK_{DEFS,LIBS} environment variables (PR#23) [Eckhard Lehmann] 2024-06-13: ----------- * Release labltk-8.06.14 for OCaml 5.2 * Update ocamlbrowser for OCaml 5.2 2024-06-10: ----------- * fix C2x compatibility in support [Jacques] * fix C2x compatibility in prototypes [Alfredo Tupone] * fix fo clang 16 [Sam James] 2022-11-01: ----------- * Release labltk-8.06.13 for OCaml 5.0 2022-10-13: ----------- * Fix compatibility with OCaml 5.0 2022-10-06: ----------- * Update OCamlBrowser for OCaml 5.0 2022-03-30: ----------- * Release labltk-8.06.12 for OCaml 4.14 * Update OCamlBrowser 2021-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. labltk-8.06.15/INSTALL0000644000175000017500000000636614745615735013261 0ustar stephsteph Installing LablTk from sources ------------------------------ PREREQUISITES * OCaml (>= 4.08) should be installed (5.0 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" These options can also be set through the environment variables LABLTK_DEFS and LABLTK_LIBS. -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.15/LGPL0000644000175000017500000006350414745615735012706 0ustar stephsteph GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! labltk-8.06.15/LICENSE0000644000175000017500000000255514745615735013231 0ustar stephstephThis library (files in all subdirectories) is made available under the GNU Library General Public License (LGPL). You should have got a copy of the LGPL with the current package (see file LGPL). As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by the authors, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. For the examples directories, the code is in the public domain. You may freely copy parts of it in your application. The authors may choose to remove any of the above restrictions on a per request basis. Authors: Francois Rouaix Francois Pessaux Pierre Weis Jun Furuse Jacques Garrigue labltk-8.06.15/Makefile0000644000175000017500000000656514745615735013671 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.15/Makefile.gen0000644000175000017500000000502714745615735014431 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.15/Makefile.gen.nt0000644000175000017500000000211614745615735015045 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.15/Makefile.nt0000644000175000017500000000470214745615735014300 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.15/README.md0000644000175000017500000000063614745615735013501 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.15/README.mlTk0000644000175000017500000001344214745615735014007 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.15/Widgets.src0000644000175000017500000022617014745615735014344 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.15/browser/0002755000175000017500000000000014745615735013702 5ustar stephstephlabltk-8.06.15/browser/.depend0000644000175000017500000003046414745615735015147 0ustar stephstephcmt2annot_raw.cmo : \ ../labltk/option.cmi cmt2annot_raw.cmx : \ ../labltk/option.cmx dummy.cmo : dummy.cmx : dummyUnix.cmo : dummyUnix.cmx : dummyWin.cmo : dummyWin.cmx : editor.cmo : \ ../labltk/wm.cmi \ ../labltk/winfo.cmi \ ../support/widget.cmi \ viewer.cmi \ typecheck.cmi \ ../labltk/toplevel.cmi \ ../labltk/tk.cmo \ ../support/timer.cmi \ ../support/textvariable.cmi \ ../labltk/text.cmi \ shell.cmi \ setpath.cmi \ ../labltk/selection.cmi \ searchpos.cmi \ searchid.cmi \ ../support/protocol.cmi \ ../labltk/pack.cmi \ mytypes.cmi \ ../labltk/menu.cmi \ ../labltk/listbox.cmi \ lexical.cmi \ ../labltk/label.cmi \ jg_toplevel.cmo \ jg_tk.cmo \ jg_text.cmi \ jg_message.cmi \ jg_menu.cmo \ jg_button.cmo \ jg_bind.cmi \ ../labltk/frame.cmi \ ../labltk/focus.cmi \ fileselect.cmi \ ../labltk/entry.cmi \ ../labltk/clipboard.cmi \ ../labltk/checkbutton.cmi \ ../labltk/button.cmi \ editor.cmi editor.cmx : \ ../labltk/wm.cmx \ ../labltk/winfo.cmx \ ../support/widget.cmx \ viewer.cmx \ typecheck.cmx \ ../labltk/toplevel.cmx \ ../labltk/tk.cmx \ ../support/timer.cmx \ ../support/textvariable.cmx \ ../labltk/text.cmx \ shell.cmx \ setpath.cmx \ ../labltk/selection.cmx \ searchpos.cmx \ searchid.cmx \ ../support/protocol.cmx \ ../labltk/pack.cmx \ mytypes.cmi \ ../labltk/menu.cmx \ ../labltk/listbox.cmx \ lexical.cmx \ ../labltk/label.cmx \ jg_toplevel.cmx \ jg_tk.cmx \ jg_text.cmx \ jg_message.cmx \ jg_menu.cmx \ jg_button.cmx \ jg_bind.cmx \ ../labltk/frame.cmx \ ../labltk/focus.cmx \ fileselect.cmx \ ../labltk/entry.cmx \ ../labltk/clipboard.cmx \ ../labltk/checkbutton.cmx \ ../labltk/button.cmx \ editor.cmi editor.cmi : \ ../support/widget.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 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_bind.cmi : \ ../support/widget.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_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_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_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_message.cmi : \ ../support/widget.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_multibox.cmi : \ ../support/widget.cmi \ ../labltk/tk.cmo 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_text.cmi : \ ../support/widget.cmi \ ../labltk/tk.cmo 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 lexical.cmi : \ ../support/widget.cmi \ ../labltk/tk.cmo 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 mytypes.cmi : \ ../support/widget.cmi \ ../support/textvariable.cmi \ shell.cmi searchid.cmo : \ list2.cmo \ searchid.cmi searchid.cmx : \ list2.cmx \ searchid.cmi 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 searchpos.cmi : \ ../support/widget.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 setpath.cmi : \ ../support/widget.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 \ dummy.cmo \ 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 \ dummy.cmx \ shell.cmi shell.cmi : \ ../support/widget.cmi typecheck.cmo : \ ../labltk/tk.cmo \ ../labltk/text.cmi \ mytypes.cmi \ jg_tk.cmo \ jg_text.cmi \ jg_message.cmi \ cmt2annot_raw.cmo \ typecheck.cmi typecheck.cmx : \ ../labltk/tk.cmx \ ../labltk/text.cmx \ mytypes.cmi \ jg_tk.cmx \ jg_text.cmx \ jg_message.cmx \ cmt2annot_raw.cmx \ typecheck.cmi typecheck.cmi : \ ../support/widget.cmi \ mytypes.cmi useunix.cmo : \ useunix.cmi useunix.cmx : \ useunix.cmi 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 viewer.cmi : \ ../support/widget.cmi labltk-8.06.15/browser/.gitignore0000644000175000017500000000005014745615735015663 0ustar stephstephocamlbrowser dummy.mli dummy.ml help.ml labltk-8.06.15/browser/Makefile0000644000175000017500000000201014745615735015331 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.15/browser/Makefile.nt0000644000175000017500000000242614745615735015764 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.15/browser/Makefile.shared0000644000175000017500000000473214745615735016613 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_DEPS=-I ../labltk -I ../lib -I ../support LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs -I +str -I +unix INCLUDES=$(LABLTKLIB) -I +unix -I +str OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ fileselect.cmo searchid.cmo searchpos.cmo \ dummy.cmo shell.cmo help.cmo \ cmt2annot_raw.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_DEPS) *.ml *.mli > .depend shell.cmo: dummy.cmi include .depend labltk-8.06.15/browser/README0000644000175000017500000001475214745615735014571 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.15/browser/cmt2annot_raw.ml0000644000175000017500000001515614745615735017020 0ustar stephsteph(**************************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* Generate an .annot file from a .cmt file. *) open Stdlib (* to hide local definitions *) open Asttypes open Typedtree open Tast_iterator let variables_iterator scope = let super = default_iterator in let pat sub (type k) (p : k general_pattern) = begin match p.pat_desc with | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) -> Stypes.record (Stypes.An_ident (p.pat_loc, Ident.name id, Annot.Idef scope)) | _ -> () end; super.pat sub p in {super with pat} let bind_variables scope = let iter = variables_iterator scope in fun p -> iter.pat iter p let bind_bindings scope bindings = let o = bind_variables scope in List.iter (fun x -> o x.vb_pat) bindings let bind_cases l = List.iter (fun {c_lhs; c_guard; c_rhs} -> let loc = let open Location in match c_guard with | None -> c_rhs.exp_loc | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start} in bind_variables loc c_lhs ) l let bind_function_param loc fp = match fp.fp_kind with | Tparam_pat pat -> bind_variables loc pat | Tparam_optional_default (pat, _) -> bind_variables loc pat let record_module_binding scope mb = Stypes.record (Stypes.An_ident (mb.mb_name.loc, Option.value mb.mb_name.txt ~default:"_", Annot.Idef scope)) let rec iterator ~scope rebuild_env = let super = default_iterator in let class_expr sub node = Stypes.record (Stypes.Ti_class node); super.class_expr sub node and module_expr _sub node = Stypes.record (Stypes.Ti_mod node); super.module_expr (iterator ~scope:node.mod_loc rebuild_env) node and expr sub exp = begin match exp.exp_desc with | Texp_ident (path, _, _) -> let full_name = Path.name ~paren:Oprint.parenthesized_ident path in let env = if rebuild_env then Env.env_of_only_summary Envaux.env_from_summary exp.exp_env else exp.exp_env in let annot = try let desc = Env.find_value path env in let dloc = desc.Types.val_loc in if dloc.Location.loc_ghost then Annot.Iref_external else Annot.Iref_internal dloc with Not_found -> Annot.Iref_external in Stypes.record (Stypes.An_ident (exp.exp_loc, full_name , annot)) | Texp_let (Recursive, bindings, _) -> bind_bindings exp.exp_loc bindings | Texp_let (Nonrecursive, bindings, body) -> bind_bindings body.exp_loc bindings | Texp_match (_, f1, f2, _) -> bind_cases f1; bind_cases f2 | Texp_try (_, f1, f2) -> bind_cases (f1 @ f2) | Texp_function (params, _) -> List.iter (bind_function_param exp.exp_loc) params | Texp_letmodule (_, modname, _, _, body ) -> Stypes.record (Stypes.An_ident (modname.loc,Option.value ~default:"_" modname.txt, Annot.Idef body.exp_loc)) | _ -> () end; Stypes.record (Stypes.Ti_expr exp); super.expr sub exp and pat sub (type k) (p : k general_pattern) = Stypes.record (Stypes.Ti_pat (classify_pattern p, p)); super.pat sub p in let structure_item_rem sub str rem = let open Location in let loc = str.str_loc in begin match str.str_desc with | Tstr_value (rec_flag, bindings) -> let doit loc_start = bind_bindings {scope with loc_start} bindings in begin match rec_flag, rem with | Recursive, _ -> doit loc.loc_start | Nonrecursive, [] -> doit loc.loc_end | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start end | Tstr_module mb -> record_module_binding { scope with Location.loc_start = loc.loc_end } mb | Tstr_recmodule mbs -> List.iter (record_module_binding { scope with Location.loc_start = loc.loc_start }) mbs | _ -> () end; Stypes.record_phrase loc; super.structure_item sub str in let structure_item sub s = (* This will be used for Partial_structure_item. We don't have here the location of the "next" item, this will give a slightly different scope for the non-recursive binding case. *) structure_item_rem sub s [] in let structure sub l = let rec loop = function | str :: rem -> structure_item_rem sub str rem; loop rem | [] -> () in loop l.str_items in {super with class_expr; module_expr; expr; pat; structure_item; structure} let binary_part iter x = let open Cmt_format in match x with | Partial_structure x -> iter.structure iter x | Partial_structure_item x -> iter.structure_item iter x | Partial_expression x -> iter.expr iter x | Partial_pattern (_, x) -> iter.pat iter x | Partial_class_expr x -> iter.class_expr iter x | Partial_signature x -> iter.signature iter x | Partial_signature_item x -> iter.signature_item iter x | Partial_module_type x -> iter.module_type iter x let gen_annot target_filename ~sourcefile ~use_summaries annots = let open Cmt_format in let scope = match sourcefile with | None -> Location.none | Some s -> Location.in_file s in let iter = iterator ~scope use_summaries in match annots with | Implementation typedtree -> iter.structure iter typedtree; Stypes.dump target_filename | Partial_implementation parts -> Array.iter (binary_part iter) parts; Stypes.dump target_filename | Interface _ | Packed _ | Partial_interface _ -> () labltk-8.06.15/browser/dummyUnix.ml0000644000175000017500000000235114745615735016232 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.15/browser/dummyWin.ml0000644000175000017500000000175014745615735016046 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.15/browser/editor.ml0000644000175000017500000006156514745615735015535 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.15/browser/editor.mli0000644000175000017500000000213614745615735015673 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.15/browser/fileselect.ml0000644000175000017500000002424214745615735016355 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_path_list ()) 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_path_list ()) ~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.15/browser/fileselect.mli0000644000175000017500000000304714745615735016526 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.15/browser/help.txt0000644000175000017500000001447114745615735015400 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.15/browser/jg_bind.ml0000644000175000017500000000253014745615735015626 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.15/browser/jg_bind.mli0000644000175000017500000000222414745615735015777 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.15/browser/jg_box.ml0000644000175000017500000000576614745615735015520 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.15/browser/jg_button.ml0000644000175000017500000000233514745615735016230 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.15/browser/jg_completion.ml0000644000175000017500000000401014745615735017056 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.15/browser/jg_completion.mli0000644000175000017500000000236714745615735017244 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.15/browser/jg_config.ml0000644000175000017500000000364314745615735016165 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.15/browser/jg_config.mli0000644000175000017500000000200014745615735016320 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.15/browser/jg_entry.ml0000644000175000017500000000243214745615735016054 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.15/browser/jg_memo.ml0000644000175000017500000000253114745615735015650 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.15/browser/jg_memo.mli0000644000175000017500000000220314745615735016015 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.15/browser/jg_menu.ml0000644000175000017500000000372314745615735015663 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.15/browser/jg_message.ml0000644000175000017500000001061114745615735016335 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.15/browser/jg_message.mli0000644000175000017500000000256614745615735016520 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.15/browser/jg_multibox.ml0000644000175000017500000001421614745615735016561 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.15/browser/jg_multibox.mli0000644000175000017500000000321214745615735016724 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.15/browser/jg_text.ml0000644000175000017500000001005114745615735015673 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.15/browser/jg_text.mli0000644000175000017500000000265414745615735016056 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.15/browser/jg_tk.ml0000644000175000017500000000240214745615735015326 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.15/browser/jg_toplevel.ml0000644000175000017500000000237314745615735016551 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.15/browser/jglib.mllib0000644000175000017500000000017314745615735016011 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.15/browser/lexical.ml0000644000175000017500000000730014745615735015653 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.15/browser/lexical.mli0000644000175000017500000000214514745615735016026 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.15/browser/list2.ml0000644000175000017500000000216414745615735015272 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.15/browser/main.ml0000644000175000017500000001123514745615735015160 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"; "-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 ~auto_include:Load_path.no_auto_include ~hidden:[] ~visible: (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.15/browser/mytypes.mli0000644000175000017500000000257314745615735016124 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.15/browser/searchid.ml0000644000175000017500000005016714745615735016025 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) | Pextra_ty (p, Pext_ty) -> longident_of_path p | Pextra_ty (p, Pcstr_ty s) -> Ldot (longident_of_path p, s) 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 = match get_desc ty with Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) | _ -> ([], ty) let rec equal ~prefix t1 t2 = match get_desc t1, get_desc t2 with Tvar _, Tvar _ -> true | Tvariant row1, Tvariant row2 -> let fields1 = filter_row_fields false (row_fields row1) and fields2 = filter_row_fields false (row_fields row1) in let r1, r2, pairs = merge_row_fields fields1 fields2 in row_closed row1 = row_closed row2 && 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 get_desc t1, get_desc t2 with Tvar _, _ -> true | Tvariant row1, Tvariant row2 -> let fields1 = filter_row_fields false (row_fields row1) and fields2 = filter_row_fields false (row_fields row2) 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 get_desc (expand_head env self) 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, get_desc t with `Exact, _ -> [t] | `Included, Tarrow _ -> [t] | `Included, _ -> [t; newty(Tarrow(Nolabel,t,newvar(),commu_ok)); newty(Tarrow(Nolabel,newvar(),t,commu_ok))] 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.type_interface !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.type_interface 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_effect (pat1, pat2) -> bound_variables pat1 @ bound_variables pat2 | 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.15/browser/searchid.mli0000644000175000017500000000330314745615735016164 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.15/browser/searchpos.ml0000644000175000017500000011041314745615735016221 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 rec parent_path = function Pdot (path, _) -> Some path | Pident _ | Papply _ -> None | Pextra_ty (path, Pcstr_ty _) -> Some path | Pextra_ty (path, Pext_ty) -> parent_path path let rec ident_of_path ~default = function Pident i -> i | Pdot (_, s) | Pextra_ty (_, Pcstr_ty s) -> Ident.create_local s | Papply _ -> Ident.create_local default | Pextra_ty (path, Pext_ty) -> ident_of_path ~default path let rec head_id = function Pident id -> id | Pdot (path,_) | Pextra_ty (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) | Pextra_ty (path, Pcstr_ty s) -> list_of_path path @ [s] | Papply (path, _) -> list_of_path path (* wrong, but ... *) | Pextra_ty (path, Pext_ty) -> list_of_path path (* 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_open (_, ct) -> search_pos_type ct ~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.type_interface 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 = Load_path.find_normalized (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 get_desc ty 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 when row_name row <> None -> let Row {fields; more; closed; fixed} = row_repr row in let row = create_row ~fields ~more ~closed ~fixed ~name:None in let td = {td with type_manifest = Some(Btype.newgenty (Tvariant row))} 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.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 get_desc ty with Tconstr (path,_,_) -> Menu.add_command menu ~label ~font ~command:(fun () -> view_type_decl path ~env) | Tvariant row when row_name row <> None -> let path, _ = Stdlib.Option.get (row_name row) in 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_fun_param ~pos ~env fp = if in_loc fp.fp_loc ~pos then begin match fp.fp_kind with | Tparam_pat pat -> search_pos_pat pat ~pos ~env | Tparam_optional_default (pat, exp) -> search_pos_pat pat ~pos ~env; search_pos_expr ~pos exp end 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 (fpl, fb) -> let env = match fb with | Tfunction_body e -> e.exp_env | Tfunction_cases {cases = c :: _} -> c.c_rhs.exp_env | Tfunction_cases {cases = []} -> exp.exp_env in List.iter ~f:(search_pos_fun_param ~pos ~env) fpl; begin match fb with | Tfunction_body e -> search_pos_expr e ~pos | Tfunction_cases {cases=l} -> List.iter l ~f:(search_case ~pos) end | 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, cl, vl, _) -> search_pos_expr exp ~pos; List.iter cl ~f:(search_case ~pos); List.iter vl ~f:(search_case ~pos); | Texp_try (exp, exl, efl) -> search_pos_expr exp ~pos; List.iter (exl @ efl) ~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 | Tmod_apply_unit m -> search_pos_module_expr m ~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.15/browser/searchpos.mli0000644000175000017500000000621414745615735016375 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.15/browser/setpath.ml0000644000175000017500000001363014745615735015705 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 ~visible:l ~auto_include:Load_path.no_auto_include ~hidden:[]; exec_update_hooks (); Env.reset_cache () let get_load_path () = Load_path.get_path_list () 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_path_list ()); 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.15/browser/setpath.mli0000644000175000017500000000233614745615735016057 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.15/browser/shell.ml0000644000175000017500000003201714745615735015344 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"; Printf.sprintf "%nx" (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_path_list ()) ~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_path_list ())) ~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.15/browser/shell.mli0000644000175000017500000000326214745615735015515 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.15/browser/typecheck.ml0000644000175000017500000001465714745615735016226 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 update_type_info txt = let open Cmt2annot_raw 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 () 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.type_interface !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; update_type_info txt 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 -> update_type_info txt; 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.15/browser/typecheck.mli0000644000175000017500000000217514745615735016367 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.15/browser/useunix.ml0000644000175000017500000000432314745615735015734 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.15/browser/useunix.mli0000644000175000017500000000235614745615735016111 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.15/browser/viewer.ml0000644000175000017500000005555314745615735015550 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_path_list ()) () = 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 get_desc ld.lbl_res with Tconstr (path, _, _) -> view_type_decl path ~env | _ -> () end | Pconstructor -> let cd = find_constructor_by_name id env in begin match cd.cstr_tag, get_desc cd.cstr_res 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.15/browser/viewer.mli0000644000175000017500000000271214745615735015706 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.15/browser/winmain.c0000644000175000017500000000311014745615735015501 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.15/builtin/0002755000175000017500000000000014745615735013665 5ustar stephstephlabltk-8.06.15/builtin/LICENSE0000644000175000017500000000231414745615735014670 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.15/builtin/builtin_FilePattern.ml0000644000175000017500000000174714745615735020171 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.15/builtin/builtin_GetBitmap.ml0000644000175000017500000000057214745615735017623 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.15/builtin/builtin_GetCursor.ml0000644000175000017500000000251614745615735017664 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.15/builtin/builtin_GetPixel.ml0000644000175000017500000000062214745615735017464 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.15/builtin/builtin_ScrollValue.ml0000644000175000017500000000077214745615735020204 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.15/builtin/builtin_bind.ml0000644000175000017500000003011414745615735016656 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.15/builtin/builtin_bindtags.ml0000644000175000017500000000054614745615735017543 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.15/builtin/builtin_font.ml0000644000175000017500000000005214745615735016706 0ustar stephsteph(* type *) type font = string (* /type *) labltk-8.06.15/builtin/builtin_grab.ml0000644000175000017500000000005614745615735016657 0ustar stephsteph(* type *) type grabGlobal = bool (* /type *) labltk-8.06.15/builtin/builtin_index.ml0000644000175000017500000000332514745615735017055 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.15/builtin/builtin_palette.ml0000644000175000017500000000034414745615735017402 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.15/builtin/builtin_text.ml0000644000175000017500000000222314745615735016726 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.15/builtin/builtina_empty.ml0000644000175000017500000000000014745615735017230 0ustar stephstephlabltk-8.06.15/builtin/builtinf_GetPixel.ml0000644000175000017500000000064114745615735017633 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.15/builtin/builtinf_bind.ml0000644000175000017500000001031214745615735017022 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.15/builtin/builtini_GetBitmap.ml0000644000175000017500000000104214745615735017765 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.15/builtin/builtini_GetCursor.ml0000644000175000017500000000307714745615735020040 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.15/builtin/builtini_GetPixel.ml0000644000175000017500000000264614745615735017645 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.15/builtin/builtini_ScrollValue.ml0000644000175000017500000000261014745615735020346 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.15/builtin/builtini_bind.ml0000644000175000017500000000676114745615735017042 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.15/builtin/builtini_bindtags.ml0000644000175000017500000000111714745615735017707 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.15/builtin/builtini_font.ml0000644000175000017500000000011214745615735017054 0ustar stephstephlet cCAMLtoTKfont (s : font) = TkToken s let cTKtoCAMLfont (s : font) = s labltk-8.06.15/builtin/builtini_grab.ml0000644000175000017500000000011614745615735017025 0ustar stephstephlet cCAMLtoTKgrabGlobal x = if x then TkToken "-global" else TkTokenList [] labltk-8.06.15/builtin/builtini_index.ml0000644000175000017500000001075214745615735017230 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.15/builtin/builtini_palette.ml0000644000175000017500000000104414745615735017551 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.15/builtin/builtini_text.ml0000644000175000017500000000325414745615735017104 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.15/builtin/canvas_bind.ml0000644000175000017500000000325514745615735016471 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.15/builtin/canvas_bind.mli0000644000175000017500000000047114745615735016637 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.15/builtin/dialog.ml0000644000175000017500000000277114745615735015463 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.15/builtin/dialog.mli0000644000175000017500000000123614745615735015627 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.15/builtin/image.ml0000644000175000017500000000144614745615735015304 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.15/builtin/image.mli0000644000175000017500000000014214745615735015445 0ustar stephsteph##ifdef CAMLTK val names : unit -> options list ##else val names : unit -> image list ##endif labltk-8.06.15/builtin/optionmenu.ml0000644000175000017500000000311314745615735016410 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.15/builtin/optionmenu.mli0000644000175000017500000000131414745615735016562 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.15/builtin/rawimg.ml0000644000175000017500000001073214745615735015506 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.15/builtin/rawimg.mli0000644000175000017500000000201714745615735015654 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.15/builtin/report.ml0000644000175000017500000000073414745615735015534 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.15/builtin/selection_handle_set.ml0000644000175000017500000000204514745615735020371 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.15/builtin/selection_handle_set.mli0000644000175000017500000000060414745615735020541 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.15/builtin/selection_own_set.ml0000644000175000017500000000111714745615735017740 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.15/builtin/selection_own_set.mli0000644000175000017500000000042314745615735020110 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.15/builtin/text_tag_bind.ml0000644000175000017500000000326214745615735017033 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.15/builtin/text_tag_bind.mli0000644000175000017500000000045414745615735017204 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.15/builtin/winfo_contained.ml0000644000175000017500000000022114745615735017356 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.15/builtin/winfo_contained.mli0000644000175000017500000000036114745615735017534 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.15/camltk/0002755000175000017500000000000014745615735013472 5ustar stephstephlabltk-8.06.15/camltk/.gitignore0000644000175000017500000000004414745615735015456 0ustar stephsteph.depend *.ml *.mli labltktop labltk labltk-8.06.15/camltk/Makefile0000644000175000017500000000410314745615735015126 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 -I +unix 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.15/camltk/Makefile.gen0000644000175000017500000000502314745615735015700 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.15/camltk/Makefile.gen.nt0000644000175000017500000000211614745615735016320 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.15/camltk/Makefile.nt0000644000175000017500000000211214745615735015544 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.15/camltk/byte.itarget0000644000175000017500000000075714745615735016025 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.15/camltk/modules0000644000175000017500000000657114745615735015074 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.15/camltk/native.itarget0000644000175000017500000000073314745615735016342 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.15/compiler/0002755000175000017500000000000014745615735014031 5ustar stephstephlabltk-8.06.15/compiler/.depend0000644000175000017500000000213714745615735015272 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.15/compiler/.gitignore0000644000175000017500000000016014745615735016014 0ustar stephstephlexer.ml parser.output parser.ml parser.mli tkcompiler pp copyright.ml pplex.ml ppyac.ml ppyac.output ppyac.mli labltk-8.06.15/compiler/Makefile0000644000175000017500000000500714745615735015471 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.15/compiler/Makefile.nt0000644000175000017500000000211214745615735016103 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.15/compiler/code.mli0000644000175000017500000000233414745615735015446 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.15/compiler/compile.ml0000644000175000017500000011005714745615735016015 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.15/compiler/copyright0000644000175000017500000000212614745615735015763 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.15/compiler/flags.ml0000644000175000017500000000216014745615735015454 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.15/compiler/intf.ml0000644000175000017500000001533514745615735015330 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.15/compiler/lexer.mll0000644000175000017500000001165014745615735015657 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.15/compiler/maincompile.ml0000644000175000017500000003421414745615735016662 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.15/compiler/parser.mly0000644000175000017500000001643614745615735016060 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.15/compiler/pp.ml0000644000175000017500000000242214745615735015000 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.15/compiler/ppexec.ml0000644000175000017500000000422114745615735015644 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.15/compiler/pplex.mli0000644000175000017500000000223214745615735015661 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.15/compiler/pplex.mll0000644000175000017500000000435514745615735015674 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.15/compiler/ppparse.ml0000644000175000017500000000326614745615735016042 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.15/compiler/ppyac.mly0000644000175000017500000000335014745615735015667 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.15/compiler/printer.ml0000644000175000017500000001537514745615735016057 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.15/compiler/tables.ml0000644000175000017500000003217414745615735015642 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.15/compiler/tsort.ml0000644000175000017500000000552214745615735015540 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.15/config/0002755000175000017500000000000014745615735013464 5ustar stephstephlabltk-8.06.15/config/.gitignore0000644000175000017500000000003314745615735015446 0ustar stephstephMakefile auto-aux/hasgot.c labltk-8.06.15/config/Makefile.mingw0000644000175000017500000000037414745615735016246 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.15/config/Makefile.mingw640000644000175000017500000000026314745615735016415 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.15/config/Makefile.msvc0000644000175000017500000000125514745615735016074 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.15/config/Makefile.msvc640000644000175000017500000000026714745615735016250 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.15/config/auto-aux/0002755000175000017500000000000014745615735015227 5ustar stephstephlabltk-8.06.15/config/auto-aux/hasgot0000755000175000017500000000304314745615735016440 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(void) {" 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.15/config/auto-aux/readconf.mk0000644000175000017500000000020014745615735017327 0ustar stephstephwhere = $(shell ocamlc -where) include $(where)/Makefile.config includes: @echo "$(X11_INCLUDES)" libs: @echo "$(X11_LINK)" labltk-8.06.15/config/auto-aux/runtest0000755000175000017500000000206114745615735016656 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.15/config/auto-aux/tclversion.c0000644000175000017500000000226714745615735017570 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 int main (void) { puts(TCL_VERSION); } labltk-8.06.15/configure0000755000175000017500000002242714745615735014133 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=${LABLTK_DEFS} tk_libs=${LABLTK_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/tcl9.0 -I/usr/local/include/tk9.0" \ "-I/usr/include/tcl9.0 -I/usr/include/tk9.0" \ "-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 9.0) tclmaj=9 tclmin=0 tkmaj=9 tkmin=0 ;; 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" inf " use ocamlfind ............ $use_findlib" else inf "The \"labltk\" library: not supported" fi labltk-8.06.15/examples_camltk/0002755000175000017500000000000014745615735015370 5ustar stephstephlabltk-8.06.15/examples_camltk/.gitignore0000644000175000017500000000010214745615735017347 0ustar stephstephaddition eyes fileinput fileopen helloworld tetris winskel mytext labltk-8.06.15/examples_camltk/Makefile0000644000175000017500000000750214745615735017032 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 \ -I +unix BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -I +unix 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.15/examples_camltk/Makefile.nt0000644000175000017500000000362214745615735017451 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.15/examples_camltk/addition.ml0000644000175000017500000000441114745615735017513 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.15/examples_camltk/eyes.ml0000644000175000017500000000502514745615735016667 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.15/examples_camltk/fileinput.ml0000644000175000017500000000362214745615735017722 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.15/examples_camltk/fileopen.ml0000644000175000017500000000376614745615735017535 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.15/examples_camltk/helloworld.ml0000644000175000017500000000341014745615735020071 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.15/examples_camltk/images/0002755000175000017500000000000014745615735016635 5ustar stephstephlabltk-8.06.15/examples_camltk/images/CamlBook.gif0000644000175000017500000003550014745615735021014 0ustar stephstephGIF87aˆÈ÷ÿÿÿöݤö¼Õz›µ11RA8¤I›00ÿ›zÝÅbæIbÆRÝb0ÎÖÎ0(Rÿþ!ÿþQ­s‹½cƒç0)ÿþƒ÷s¼¤›´çssœc‹‹ çr9¼YÿIïI9¤Å¼ÿÍYœZ„î´öÝ­µ¥´Ý¤öæÅÝææ÷9rÖ„´ÅœÎjb›{„¥Þ0ÿ{¬î›´„YRBBBcA1ŒIBz ÷Ý¥ÿþ›¼AIÞIBýAZ Y08ƒ¬¤´¼0½I9ÝA8ÿ81÷9QözQæ“A ¼r¼“Ö¬”祭άÖÆ̓rÆ›„¬œÆ›”Þ惃ï›sï¼¥ÝÕ¤¼Ýݽ÷ïÝ8rÞJ‹ŒkR¤YQݬbkssö“Yç„kscc½jcÖbZZb0´Aj¬YrÖI¬ÅÍÞRjÝjrÞöµµµ´¼Í”jZ¥rkæA“zb¥ƒsÖÅÕÅ0Õîîïïï÷¼{÷Õ{¬Æ¥A9¤AQÞ›”î‹‹Åb‹ÖZ›æY‹î0ÿ8Õ´jݤzÖ0æ ‹¼´›¬´¼Å¼ÎÎÆjƒzï½Æµƒs¬‹ƒÆŒŒ¼›“{0!ƒ80î¼Aö´Q¤(¬8ö¤›î´“( æröj((08îAÞzRÖ‹R´YQ¬jQÿc9öbIö›Iö¬AÞYÖj“¬¬¥¥­11)µ­cµ´s­­¥½¥¥æIæYý›ý¬ö›ö¬Î8ÎIŒŒœ‹‹¬´ÍÍÆÎÎÖÖöQ‹öQ›½zcÅrjÞÞÞæÕÕ”””ý‹Å´´Í¼¼ZZZYbb{{{zƒƒ“›¤›¤¤¥­¥ŒŒ”)!!ýöÿþæÍÍîÍÅBJJBRR111199œ”Œœœ” ÷ÿÿ¬´))!)))æ0æ8­¥­­­­ÖÖÞÖÞÞJJJRJJÞAÞIöƒöƒ”œœœœœ„ŒŒ„Œ”!!!!!),ˆÈÿÿiÛÖO,p7âÉûö¬¡Ã‡#J”÷Œ"Cy3ÊSÈ1žG Æ y£¤É“(o DhreÉp*oÀœ™ÒäG:$C&LÏ0Ñ¢ýû·m[¹kHe<®©Ó§K•J••®jÕ¬¦CZ.]¹¯`ÊK6,¹rgÏŠU[¶mÙý´*-©°áÏ0C={­êÔ¿Z·"| ,¹Ãôk#·ø09z#CÞFn=ÊÚ gf™qåË•#~ì81éÓŽ)—í-¹~l»’Ëz0^Ïhd*SþZPS¦OƒÿV×›x¿ãê’+'þúx¿rÇÓ¾v|íó³ýàBw®îZò××zWÿ'U]ºèΑƒ ¦×Ëô N¿äà Þ5Ü3 ê€rØ<ôÌCŽ?Î3Ï6 Rf ( Èà‚EÍa 6¸`†åa‡†¸6$Tb‰C¥¨âŠ,¶˜—@.j3Ô6‘XcŠ2þ³!n(b †HÔC-$…ÿ,AäÎØdQ2Ú8â’-Òø"ŒQ¾e–XÚ¸eŽz‰˜ã”4’8¢6aLÈ!…óü³ ‘6Ùæ6KÌc¤6JEç‚)Ω$?5c^c2iè *Êh¥•0Jå–Œ‚©g™z… ¨ zúè¡‘ ö覛|^ºçm¥×’€Zê)ƒ‡::©£^:ÿÊ(¡Q *릢 j¦¥óhcà‘šÒØi’tÚ*ì§"ê馫—¾Š¥@P2iì®Sš9¤†¦šc£J+d àª¦a ¹i‡vV˜.ˆuÚ&ŸK(J㟮êæ@¯Âª¬‰0ö;é˜(Öøa¸#¦Z0”äþÊ¡‡z™ dQôB<é›CÍy&½ø>Ù(¾Þšhm–³škµçK°­ªÆ™á„!:Ü2©>Ä)Âœq™#*Y)«¶B볘 §Úîµ8S›²‰8# ôÀGžlï¤Ë’{äožü¤¥Hw¦½§–H0ÒøÞ{ð“Æž¼`eV]l j¿µÊó~h^gŽÍ°³Œêjêagÿk&™3¬ªªšÖL§ÉϘçŒjï•lÒ!ã¸(´§&9Þä¦89ÇÐBù÷܇Ær¸p¾úø7*Zíª?ÞÌ£zêßtÞºæeþ 4¬«æa–š7Q¥ªFnÀ;ò@¨apE~sb"„¢£GtÞÇ#’‘ oœü“ãP®€ šC†4 ®§ÆwhOÂðGóÐ¥ Ý4mžR 5üÈ@k€ìY " a°ŽFùØCX°‡G8RùpÇ?ö0ìV Ã2úÅj,pËè^¨ uÄF,Á@䵩CÊ!Q;sü£ƒÄžúªa2 …†M ’®â9! Îr ƒ€9¼ÿhþC‹Ô'‡ä-2p~ã‹4Ø÷oD’DÊÑöV„óKãöÂðÂ| ‰}ˆÇ;ÌáAhÈB–üK©“Qq€ÑÑ›ä küNàX†©A P¼geXIFÑp4X jxÒè‡2Ý7(õcôøG<¢ "o~|¢V©ñÁ0Üòœ]U¢õJ(U÷iC¿û‡#åõ°•U‘`JÙû¶õ¿¾ö [-H©øê¢R €~U><¸·à1M7ñ¤Øá&û'zÁ)L«ê‰´ä¥%qÉ_Tò¶ †+‰ÌTÜʪ€Ç«´ˆMP: ÿØö¶µ­íÎpÛÞúö·À îo%à[âÞ–¸H\ä*¹ÍM®t§KÝê&·ød HE á8‡x@^ñžè¯yÃ+€!|×¼ï5¯|ÏßùŠwèE~éK_tˆ7¿ö5/zç›_ØÀþp‚|?œ÷0d„6xbÖstEÖ„§å… E#‹Ö™6{«|åõRô$i‘Ä3'‘\ [Sƒ\vEËÐÃ\¯ÊÓdí—­á)ë´G]Üáö£PqÎ[ßR­¨p'"x ©u[Bf¤L)+œZ‘¬~¼åŠ}Šp*Æ‹þ6ÓA½‹OÖs1÷Ád<âÿ-^à™Ád€ÄãSº¯›•-oOþ1š+ö¤P %,ßãêä É)s_,LW@ )ÈzŠæ¦¥±È'kÈO}qrŽ+4£ÿˆPîrñÚ*Öj|ØÛªüöAÝ H7–rV¤±GC¶/Ÿ”)+tYÝÜ!'·§ðø®å‡nª¹³*?ÿÁÝv€Œ ŸUu<£$‡ÆbÐ8“G† IñN#½ óÔÿx†;Bz¸ü{¯h~û»:¯”|‚¼¯d´kÃc€îþÌõyvÖÔï“Wû«ò§cO~Ј½ÿŽä'|sT?VV¹ÂOuhECÑÚØõ9å'C¸û#á÷cÛdîQÌ(—ÈÆS×ÎC#òó£ ?Â4yœùw7 w2âsäðs%kzÛ`nÕð 8uKºRr*Â, w×{ò÷m24sþ`s“f|=wnÿð7÷rCaFrl0äH’¤h0~!ômÀ¤pZWƒäwuBú }à÷wÿAŠV;6·òG?' 'Cê7 ßV|!Y¥”UMxtð·zŠ&¿Bvƒ¤w+Ü'? '?22‡¨ “Gs2M7gm‡h÷64¢t+÷„†¸rÎ' .BŠÿF‚%§*h@Ûà?ô ]…‰TÒ0 Ð /|ÏÀmò Ëð;áê0 #qÚÞ@ÞðÂ$³&W)ôOáЂïàF×pÛÒð ´²+Cá;fu%tŒRtê0Æ¡;öqÄáVM&@ BXšqÄ£'ðZ~U…à`xqÅ">áàr´ÆW¢( <~¥v"T×h2Swb,352éDsÄX#›Õ$§h'Kæ1gòW£Y‚-;c32",Áò#ôR‘pSeÉ,ŒÒT¥%]²·s-†âŽ é%sT¹s%‚ã5]â+ê²2ve8>bW¤Ö!ùÿâŽv;'òY1ò3%36ÏB’#vT›&•¡(Ö²7áY£Ã)°E!pBO¦1ÝH×Ò7wÓe›ã$Fó’"¦”E‘6bé8òd“4“‚â6ã5–1uò4‰ò,ÃYtS0:s”¦•¨æ3_R-°"˜AbJÏC@ã6j²!÷6Y¾f9Æ‚;”ã’[ã1’— v#wIW]+H˜”¢°SàRe®urŸ"Í3…”’GõWu0L¢<É”žãb$Æ7~.H9@N†ÂƒHâ2.ócRr(ÛB)¦’™dò,»"–R‚0ÑIb(i0ŸS0¼rJ¸Rcq‚'Ræ.¨´(Oÿ+WÒ“$É%‰%E£<#V–yj¡ 6ªé:óy8ŠYOžüø–“sžŸ™;ac-ž™;ªi’E™’=ó"ESŸØ7s³gÄOă/3/ZÙm¶Ó3b–œó ZØÉœA³m‚ÃY;#6¤©.܉¢*Z:ÓÃ4&˜UF2|ƒ ©1³9”Õò(è9bÉ22E•F2¤½Æ*ì‚8Nc”zƒZJ£ ÉSŸò)›Qêhröž)‰2™¥M)c—Ö2¶I:*Æw§–1Zb3< uƒ¤Æ~ÏÙš¢y,³–2U,m/Vi5ªÖ,Úv7Rb’H&…8u3¥•â5ÐÉžoê.ûh.Sÿùh[/jj£úâa^© Jƒ~I”•3ŸŠ"Jù7ô(X¤%".ƒ.7¹0c'bŠ@“ã*¹æŽ"*¢Tj;©+˜Ê/`b–ÍSŸb)C:gÀ²ðY:`êg:“8¦å©;ªš%ã6€‰¦IÓ“ÒÙ–ú˜iÓ4k27Ú$p2j}ƒ™Lº/¥&8&-¸ú•$Y®”–=If@ê L3h‹‚$+Re÷º“òøcû mýú¯Åx¿’0ƒ6ä  ò âŒ-H ×á@ o0ªHK ý °ÿPâ‘oá ìë±²ú¶ ¶U¶†‰dþÿ@ë×0ßPÛåa@û³åð :›J8Ù O¥„iC·Õ@ ÕÐ~¸rbðªÐ q @ 0P`¶ ¶` É Ó ÕP Öð•p`+ÊP ± Õ° {Hs4gÄ~ R z«úàúTÀ‚¶ `Û¸&`%@ , ÓÈ3bVÇ&ˆ¹´êbuÚs«â>§hÉð‡ðF`p¶a»%p— Z ±Ž _[»w Ë° û Π·È«h•ðodÐ4a°ÄËú»% ¹²»½:` " µÿs"Qy¢óúß¼§«hJÀ¼S 8`[d¿Û[»s@ ”` ´{qð ú°p—¼¬O{`n+G½ÖÀZp`«½Ù+»’«½¶; !‡"ÝUWf4r¾¬hæðÃpv:»$,¿p»¿½U»%•Ð¿Ò ~,À¬h x»—@»üÀ¶Ú{±7bgSir–{1,?Yðžï;¿N,»: ÅûЈG|ÅÔ°ù—À¸O,»c;¶Ù{óRŽó<5¹!‡aÄLRŒ æ0ûkÂ*»×¥Âu|–àÃ{Åz;Ã3¼íÀÍÀÀ;Æ;Á ÿ,»–&“…¹i—ÆÁ|sžðopI€½:ÅqK¶ ǶgÀT@ŵ¼wÅnl3|F9ÐÅN :°È;|ˇ\:€KäȦúRãâ#æ»r怂€+ ?n€É3`–`Ø+¿Û[¶¥ úÄÊ  É¿0a`~MÇÊútŒo& Žp Œk †¶lˈ\b| eàÄhÁj"@sz6Ã|t>€ÉÃÐÃÐÉâ`S@Â@`\uüÉ€ ïðÉÀK, û ¸ VìÇ3À¼o`¿ ÁÀ[”P dð „»:`µìÄÚëv¶"ÿ{*d(gAšul€É ÒÌkæ  ®<_ Öì d€ µ«#L¶: ÊÍHÉð€IY°0<°r3p•ÐÆçÒpÐÀîPC€\à -@ak -P „€c{ L¶€àÎc<¨R$OfLJ|t>= l؆=æÀvF'l"@†s@–M`«®KÕŒD‚<0Ø€ ( `nÎpØ3Ð Y €$çÊSÔаP ¥P öÛ®``k- ÛƒP@4s¶9PËŽû®“8:Î-=ûst‡ýÓ†ýðzPÑÎ\Í<¦Cÿ6`»C œ]Ñž ÚØ ÷` 7w@ Â= X OPÕͼ”°½€Û® Û·…à Þßöð º] _p˜ðÒ @Æ• ÁY8(ªÆÑ­O ØÔm~Œ–p6à„—ÿÞ—Ýä ÚÌï°£ ·ð>€l÷ýÞÌ‹òÓ 3΋ÛàP9иò|íiÆ@23*ó”{À¼ŽØÄ`Z #Þt°á[F"" _PÀØœ­ ŒÚD@ o ò 3NãoÌ’@ÖŒPöÀç=¾-pæ ÀC^äDÞiÿ€  cü%›{‚ݨ00ßæÐÔýÓ3°ždL9l çöžM׋½8Ñ PÝÃàéÐ unçwÒ‹àç}þç-à΀`è†np ÐÀÊ á* §?rž@R}å ¼zà Ð Ær?ëž4"%  íÐí {€÷Öæ`4þêòÒ=¾î¹Íp¿­ëD>h×7]ªí´Àú4ÊÂ3 ˜ôZ %ÀåKT¨Úà³4Bà r ÎÞí ð0ã­k>}î@máÌ[ýMë<î ¥°ÒÐß^èþ n8 Œÿ Äщª-é0 ò#ÐÔmØ ðqÎBb%û³áp BAÿÍà Z@ç@ýæ oç Ý ̼ŒÀî%èw0,?àgÿ \p ¿ÞèîØÈšå„8!gpçì–~áîÐÔ Õ t ƒç<Ú°ôc® 60ÔÐíàCŸM•PçVPéÌK ° 'pøÀ@ݺ@öb?ä¯p“ ï†^“0ó!¶2¢IOpðÅÜñ–nØe`½ÿ; w@Ò€>äÐÈÕžâ@ ù` j îàZ€ u>ø ¡-ýé=»PÝæÐ@½ÿ®Û=ž9P ¦OänpµÜà; üûHª0ûì O+àoÖYœB±p ,ªcS"a@ t0±OŸ¾jŽØÌx“Páæ(`Ö-DŠÙ æÄ·…õì}tõÑ^ÈA6æ´pÅÅUJW¯V¾äBÇËÚ¶ÝÄysÞ¶y;{êä4ç™Con™aØÂ¥ÃîÈÚ/6öý»©M+ ­]ÿEÃäNš´}ËMù³0áŸdC1®D³!ÜÀÍBF/G®´gHJŽJ]5xÙ±K+sl•8°­«6;sZΙg¹ë†I©Dl雦 ‡D"íF¿p7¸R–<†ÿä0"=ƒ&Ú¾F¢Ž~3#b€‰ãÆ•+1!±´jG~¬Ýc.-TŠ4¼R¥«4D¶isvPŸ–—ÜxP7]—5tK’lòO›yÈÙ‰ÞžTœ5_mä™YäÁø€wa¸‘afxà‚#6 £Øÿˆ¥l²üÈ ãbþGd<»ö㡈˜$l¯=§„,^†[]~°Š•VËì­U¨mÀ‰çX£ÿ†A>’èC“øPb jû'ŒCck45òkØØæH¥Z°?.!aªH&"¬%¡ã @©V8‹¶È\×­ÇÛ$¯^Êwç¬þæðÓGÀ'QîQ€–ba°ý¶!²Ê+ï@4ß\sJô¹ ¨-ÝJÇPÌðØÁmuð`|2gÎ|m½—'mz§ÿ€üID{îÁgþ,ƒ<䡵kïy\ûÇ3”ñkUZ H²€{ÔâDª°€…ÿLa`cº·ŸÚÝ.E·³Lýè7¹>(@¢P@* x4ðy]SÆc¨·9 ¤ÁJnÙ÷ð2mà$h`÷J×=1ˆOLшØr—38í¬VK˜Ÿ é÷Y°âÌÈ„gC2Z.Ü@F5dÈôž÷2´IÀáZÝ» M€ŒTAQ+Ë+Îx"HœUÑ&åÐâ aÀ†VÀ”+c$õpÔÂÚ“îh‚ðC¶ô8Ê8Zëb_¢8¯žè¬VîKO ¸cì!/ÜÅ–¬crG“dÃö lU¯¯Ë%Jð½Í-1Žy¼c÷þ€…'Fÿì²(O+ƒbBÍlc–¼ƒxà fÜCÌ`@*NqŠVnr~ƒ'Æv4ä#,Á1Á‘kS"ØœùLî•Àb:”Wl‚·›R=Ý,ZýŒ%0£Á@ø°ƒ¼È Žâã‹]Á7"‰•†É‚ –ƒ86W@˜ƒ,ØCøÆaÁï)Î hN½W‚MPªü#Ín6HÌCy»IEåy, ôaã(Z"˜¡'(axåÜŸ9Qà†bDc’ŒËOjPŒ øh!ìpÏͱHF2öÀOä ˆ5½ Çtª­îIÀ-@EÔ?î3HœpÓ}›‘ l@ P‚ÿR`€&8:yΫûóhVyÁ+Ô£…(l‘ 2PB4(E_ z´ jÔV¶±g@®r Ÿ;PÞî–¦8Í«M êÙ)+?ý OÎ*ÈÌ,c9†„ ä‚ÃÇ¢v0\–÷èì`WÔ£/˨Mª’Á8#ÿZ ƒê¥@qxDmá ÓðAÈ˶ÇÌ%æ4§¼5AV0·f5 ¹õªbC»éŸrT‹·>À¬Ë¿¬»YÝ^á‹^,¼…HÊ?âáĆ4ÄŒPC×ì„tlm˜A,üÖV¸M•9‚Çwo·D.ÿBì7`èQE½„k—“Ú\ØZk’À&r‘Y>íÃûźРԃ\@Šþä I"Æå@I`{-:aÕ¨†;xüa@,P$–‰­ Wë9hlK4 %áPñ–3½eFs¼]@ $ଊB–€Áv‘U|h‹øÈ"Ðì2Dnÿ ‡1Ö`]ë c!Ë/¢g9ø¦¨rÆ2K‡ƒ;4ãшƒ20t†R"+Ìz“„£=§yÀàÊ×–@(.«€,ÀÀ²YeÊk5ôâ\¡~õ?Š˜9›ÀQ‰Ên–‘X¸Ãx\éš¡G4èêw÷ÿĤʜÌÆ^Ò.¬œnr/\B˜æm(@Œ>üCªàVDHì±lЀ«_vÖ؃Öà Öâ=–eP£ÞøösLÅeÀé:À÷2Øb J13Ë]QШG4"ÓÕZÀeË©€0´Â»VX¹? w8Ð6P†ìÀ¤gH®‘ C)ìÁ…µaÊg€F<ž±vh¨Üqe©wþ›ŒðYÂZ—pYÎM°H@®Ðˆb9Œj»zåo“¾5¦ K€¹øbVOQr⃣¹0Ä<[!,c4RÌËüÜÀ-{€€;‚aƒjD§l½ÂÑšðk–n¤Ñÿò{;ãǵ&á2M"ï€ žñlñ0”ÒCýIyðŽXP# ÖÊ4§³*ŠV8ÂJ‡B¢SŠHDc,¿pÇ8„¡Ÿ!5+ ˆC5– 2ä#DH°@YêP€Cà =J¹hÙ }ˆü‚„¼‚j±—‰€JaÈ·xÀŠg›—Ëx¨)#mP‡i€@ºоýa†)V¸¬]È‚Yƒ5X»gˆ†j°gè‡( ¨ës‡‹„¨‡50„l)I €ØÁ»†kø¿Ù»ÚÃ=!‹v;s(ƒjy؇hÐT‰†½ó-p‡jho¬f zч¢¶ÿ¬‡‚È+Ó¶¬’„%°ð(QØð{(±4 ‡ ÔÐ l¿rð $i‚q L»„X€D,B‘#,‡rPBY`ÂR9~Ð6¸@ CÒÛÂ3@@¢h€óÛp`¾Ú(¼J{¥7ùu¨†F¾+“¸¬,àƒ;Tg 1FèI€À*‡G \–kq(‡m‚RX„„ø€LÀ†—Ù0ÄEé L”uoP;h€(w ºù£¿Ó[(ØiH 2P泉žÁÀ„à mð{Ãj‘˱ëÊ.,Ø‚4`b( ‘—óÿ0Ä#T”f!½ (……¸…lˆ’X©‰©Œmø?LXj)º‰Éù‡Gq0…ÒAƒòòÈ‘E4D8¤Â uˆX +ãfÈëb†àI !¨€We1Ü {¾¾L[ …4‰^ 3jXÓ]†X 8QöWèMbhÞQ}d,V‹i°†v¼×°ZŽO<ÎeF z ÜXÊYã›…R|h‡=$·è ƒ{$‹}ˆy@”"Ö;.R¾…(]XÉZ!!؇}Ѐ]’"Ÿ,’àÒÿçÍeù5g{ágÒ­Å¡àŸ 7`€{˜5hA阃hˆÝØvÜŒöÔQSV‹èVÉ• {ñWÒ(!‹8èæà'}è)ýÝ°Ž~AzÍ í\­ˆ>7‘¾¼Ybøè{WÐ< ¬Ih…þPMÉn]Ù?¨é7H $zK80ěцU:ˆiƒf˜€î¬ÈÿAT«j]ˆž™m€•CBCΤ™nza¨MðSð((ø€‘®‡Ô`»µ»†C¢™˜^òÄO‘NmàÒ…:B*E‡¨ ƒÈ‚ˆ0Ѫ)CüІeòƒ”•ßÐÞ.l~ÿuÑn’Vè$`]f8«ö,yhBohBûIšQ\ÙcÀÎ îåÚ í".è”ÅtŒ‡™l˜:¹Ú‰ÙLök°B´ìI¦›HÞèk0ý …\@5Ï ru¸DÉð⛿NÞùÙlÉõ_.]Yø†x‡9ˆ˜€óØ̲¬šÃïÿ@Ý.ì³ÏkÈ…+0…]ž{À_XƒRÐËxTxQͶþs8Í÷©™ð_mO&$/•ˆÀƒÀ¢ñï2D\ ¿‰GÍð9i(܉ …©²RË…ñCÒ’÷ÝÈ%ëeÏÝAt¨i8˜™Ð†)Vÿ»•…Oh‚p‰ˆ ÌE‰5®ñ~ß"&IÍh¥IS¸oÈ‚]0ñ{…¨‚Jt‹œ Ïôlç…?øƒ™áë<>B– 2Ç‘ñX‚<`O‰%þŽðíÐ+•:6—ÜWšÅWZXEƒ+H×(…ÔÑ枌‚¶RÈÅ‘a€·&çœíð„ƒÙÈ‘Á†º@‰@79·ÊbÑ6‰˜Û”4M ÒL)>ž\˜W( Ø]¤=Y¬íàlF•€´ Ù].Ým(èa•€èbÿ”—\ËÕäôö#ò,ýÉS7™")Sçž1wÞ‚„VèÅ{ˆòR€ÿ‚ƒ &Q. ÍçUQ·n䛀•9>bµ †[… ŽŸ‰˜€ è€FÁÒµ$ËoþUFù}X¾€ô8i%J›2œàÏÀª^œ(òÎWEÙlb8÷Ñø}}å_—æ`„À…©Ç…[Àv¸‡Y0ïCåæHEO^ ‡ªƒ7¼›ÑŸÔŒí¹°8ô¨à)qéĬ˜‡»ußþ]Oúíû-O¿¤Ê4ÍÍ`qO8@"м¬ ›ÉJ•'z…o¨…8Xf2Ì ºÏ¦ H,ªµ9€ÜŸ\¸ÏÚR˜ƒ@J„9¸Ý¦yzxÍ-ìsþ2ˆ3‡ÿ-„'g<–_Ñ<2°© /˜yÚH*X1Ѓ_Øk 2|ä½,*…+l,²0È8§Qð,ðѬ)‚;°ÀôÖs–Œ%…QØ¥ÍH €iÁ^F}Y °.‡3tˆ@üøñF ~ÓÞÅû·MDP۶ͫ8ÜÄyÛ0Nì¨ía9&J”°dÎÜŠ>JD¸Ð ‰?$fμðí_¹mårBü8ïß?2_Ì úâe”¶œÿöhêPìº7ã œao¶¾ù3ÈsOŒü³N 08s ]ˆ‚r°«ËîÐEz(ÙEqbÒŒ/ÿfÔø·#E$ϬxÚ”>|kì}x&eÍ"Þþ¬TÛ72>húAgFÛ<¥Ïâ8ŽC ¶ØÙb@-À°'Ú» õÍ° [âi{ȪC‡Ö-¯»|UæÀ¨.x[¿ŽÉiܾ‘{ÅÉeqüÔܽ{Œì•:0ª MR꬯ ” )ƒ ÄŸ9äPJý£Žy²Í6¬ ƒN- 6'Ð ,ï¬u ´¨²‡3°Ã¡*¦ÐÿH A9á]gQwä€×Ý`?Ac^S`5ÅË-ĸâÊ6£HASR8Ñ?óØ€ fýÅ7D*á8¤Ô2Ž€ 6(dû9Å ÿ³AðË>PƒücŠr®óÃ*^Tw![q„˜aubÔ]ýã 4šQO)¥\CF|fØð‰?áÈSJ:jFôÀ@ Ú˜7 LÀCŸRÅ/ù"Æ6¨…C „ J§Èra™l•9ÞœqtçEÞ±¸g§çÐ1¥Ô#Ïñ€ *E4ê(³$l0ŠCÿ°æX–½ö©L$¢þÈZjáA`§¬låT+¹rÄbž¼Z[#\c/„4{/³~C NîPû®µ#Æ:«”Ã[Õ!+²~„˜vãQ¤â`·þÀðîaO=m‹/Ȥ™!Ž#û$“1ÿÊæp‚› »ü²©!†îF­{gÍÛ¸ ðn.,be˜rÈRtCM>Òìqž(oy’ Ì%aÇ… “ûr¥2k“`-Räâב³³µ6*£ 1õÔ³@ȘA´’4£O>ÖèãtÙ¬ìñÆr«ÌrC89ä`Õ0›z}ÚüÃ5W,ÞFd¿»‚ñªýsm9¤¸A7iÁP2…>¿›¦SbƒßM)ƒ cÔqת¨Aª€QÃùP‘]Û ñ`5[î«c;¼¡‡9,RÏjºÈß4r¨ '"ÄQ†-Ó@B%6³¡@ßætóFSzÎÜÿrÏý ‰Ë±Â@¼ãsÖIkØ£'>õiš¸ÇÒt#ŠEtAm|`)ÔÐKôGC#Á¡…-lb&~Æ8ÜQ‹_ô!6¶‘MlØק“\a©‡<€5qè.õA*Ör¡ ”œéIa ƒ3YdbîÚƒ0A¾/\â¢/x³fÜbzÔ³GõêÑ µÙC$AXp’1jû †-fr6äcÖ¨¨”lœ0NÙÃ#R@…-èÁëØÊ-vó75}èΩËÊ8P9°àÁ`4†‘ÿÕ OÚ‰Ø?nД0LC(Á'™Á '¾p¢`F=°8™êmQ‹½ÿAMЩdðC= D¼#Ž&Dm>§H£°)þ¨¼`¡)ÝH!k¸þÀM@Þ–‹›|(ÿ+bx ±±ñ)ûÐG30’0÷À…&šbÊ\Ì`•kÈb+}ш4NÂZ"¨€  ‚e,#T˜@•4TAÀhÊ#ö¡…fàš …ìÞ ¦ç òC¸ËáØ` ‚º£!2û=’g3Jf"ÿx¢±Œ}l!%X@ B1Jf( ,H>zaÏ2B [x –Œ™c©“ú0 ‡_Xãµ€è*JÃÂ9Ó$¤]êò@À`¿ èÿ2Úq“Ɖó0D<Œ`ö}”• ‰8‘ |ˆb ¼G.. JVnqZ@ú °™h!ùø…3š©*ðc¿øÅaM±•­nõ º‰æ4iÀà‡5FªVÎÐÇ’ãÑ%óo¼ƒ®© F F²€½:ñ¯÷E/TéÀEpá$$(CÆ;Rì€JÆ2„'4æý#v;ÛshôC_ ëhËq‡’ÔîØŒK·!‘±7Oá™-$R» k°Á¦%À&r‘ Qd}Å=ð±‹[vs"Ђ98a‰Œm"°†8€Á:Ɔ üøÅ ð¢!»œÁ¯ÿ`'¼Á»ï‡@„qTC¾Öˆz]*‘ñ¤Tœy‚«6‹ùÎê¼o ÀSs8=€µ§=zaˆÈXZÙÌá†fÄÂûÐôÜ}ð£WxÃp]Înô P™!C‹âÛbÑÐÇHy\R‡ˆ­k–ÔNñÄ©Ž8Ä‚ÔˆE>X€Üš`%D©ß\è ; T „ðæfHaPî{G8¶°I$dP }ðCÍìqˆ‚¬zÕtiuSàðƒ:üàˆ˜KAnñƒ$ha)È5ô!ì8ÄX0YW[½¹ä­—>q´µAŠrì1ëÅ}÷ÿ%±­ùaO·„O@ä@YP836Τ»Ýçöfº¡nµ[Ûîž÷³‘'9:-1Å£³½û}nz \àKïÃî­pIÊÝîÖv´£Õîe?¼›:ÓÙ²)noz?üâ­½¤Fèìì‰,ÁÛéíHɵQòŸ\Ljayä2-Ç](>¡3ÎåÝÍh¡ÜÝ´ø¼Nó!élç¬ÊÈÛ»"˜ëÝÝ!zžúír,ÛÜúîH‘lžt¤cÞ'¥·K‡^tÖÚ[fE¯y½Îî\rD Ô=îq‘)äW‡«ÝQ~w®‹>B‡8¸EþsšËÛæk×ÚÚïˆËû!m-¢G°Nñmpÿ;Zó(ùÄLÞ^v!&î.½üðxîR‰iædºáz›7>ñü7ñ<þxo{{ÙC·1Ka{ç»÷Ü0"÷·Ê¹>ïÁ›ÝôÃë »íå³Þï¬KA~u®C¶‘£ɳ<]~îaOxÇ%‰tŸ“=í?z‘mÀl_ó¼×~8áºôǶó-¥3Ó»ô‹‡;á5'Ráé5òyDÿ%¾™Üî‰SÝQÒ<øÃJ¹å5ÝôyÓÉÑÚq ^ã°~ Û™(pdzýгµ]äAŒæ¡›?ºá„ÃÃÐŒlÉÝu¼\zýØåò›ÝÄ-Ÿ` &Ì@ÿ^ûÝ?Æ fÝ_€B8€(Xï\Ö]¡¾‰aì!‘$_Ùõ`ÿi¾^ližæýC8xƒ:ü„ÄÏ<„á¼_ÍÕ!·éÉäéÒYœ¶½žÜ`&ŸêùÜÁµ·õÊ]íaÇ øÃ?HÃ3üCDÃøeD8ø8è üÉÑaœ³‰ÎñœÐ•Þ·  âžú¢ÙÕÄ ÏDøƒ7lFSôCSÌþ©ƒ?¨CË¡ éŽ0j\è¥_êõ Ç]Ù£ ž ÙiÍöñªÃ%^ŒÎ4â½Å¡.ÎÜ6Ýþé‰0Â[ñÅ[2]Ñ-#àÅë¡¢ÏyÖ±ºÿ_8\â ÄCÌchS€EC¬¡“Ø]žQ`ÐY¿Å]åÕ!Âñ\ãßÌ¢ >$ͽ´9 ª`K±â6P#(0DBS|ƒ98Î#&ö¾¢>ßï•Ö½áC¦¤¢â ß 9ŸEâÝÝ‘‚7ôÃ?ÔâÒøä H$À>Ä!8l"JÖ!ÎqâÉ…¡9’£2Ú›:6ãSU¢ õÑŸüÃ%ÒCSÜÀÒÀ,C5€4lCÒá*ú›Ö$Ýé\22¥»eä:Rå/zœÚö}Í‹À"Åhà |ƒ:X €Â¥ÅŒ„AŽñâ¢B*dÒ¥÷ ]rÝÅqÇlÝÿÀ:º4Ä‚“dÒ3„CHÃð\%±_Π W>„:4b84G6…>PCSÄ=œ¤Å±ß¶MfFËäí߶ äØŸð=‚:üƒ>fr:ÂM$'P §ÍýB(Š7ŽM:„ ÚJÄH`˹Õ6$Š?@Ã;<‚0È$Pƒ0À|zÎc?T¤ Šb9~[%îa‚áÜE4° ¼Ô>D‚4„0HC5Ä‚;¸4HC,h5DCDC>Ä4ü4„A„>´C˜fx†'fnŸöä|¦Ôi¾Ü<4¢÷…âÿ§;¶ÂOéå§ÖýÃ#@ÃøÃ3Hƒ“LÃ2|ƒ;ü8¸ÿƒ>E€Æ?Ä4ôÃ#Àƒã”9ĤZê©×x…ˆŠûËV"§_Ó¢­—VjVVþ[­*LH“f6~×*&Øö)Û°MÉ Û÷+I¶Ã ïãk-Õ:s]A‹ÔO±eZ@“Ž*t°g¤FÚ-줯²¨5_†*ù¥CiäPT¸º6¬ÌúÄvö,´jÕhýâvdÓ߶ý¹kYù™lØ£¶cœÉá¼³ã;+ZiðçÑ ²úÊeÔ³;i^8wÀ§µËÏwvj¹ÑƒVø‘×ÙGœWnY ¤jvŠè~#a9fœòñ(æ}ŠjŸY^Vé&¦—š™ê}“>çé­úmê&pzŽÚ+©ÚŸdH™¸ †¦–y%Lú*'®ÐZVd|1kmo‹úZ'¨œŠ—,›ÇqI_´ä¶•_‰¯~ûk>4z-¸±â²E†W_ª‡Áªê«Ï²¥Ì@ÊT¹Q¸ê»;Ú¬©K˜Œ]á°Wþl$›ª&¬ñg óÙð|ÿzwg·sÚ9ä™Wüž¥ñnìòÆÇiÛ‰˜Õ ¦o%«òjøŽ³—ºõø2Ìûy(~‚eäŠ;‡ºRÓÔ {,©íòâîÐ-;Ô·?F+L3ò7Ï…ëöæ´NC*a±œNír»>V-7Ö„%è0oi¸¶x-ŽJ6ÍN3mï¶9“Ü,}e(ÔÕ¹,Þ8ÜŒÓ-9Yyÿ·7Ù¡Âû÷ŽhoŽÝªó®Üg⌹ã¦C>ùêٱڹɎf]˜Â+k›fxÙ¦z[¥íÎÎWõ=ª£nzê¬'wí¬0Ô£éy7ÈÿÚ,ÛY‹ù±Æ.ùÜþÇ{¿ÜÊ—¸ìOì!§<)ƒ|V+'ðŠÞ¬}öuËŸ¥øV[Ýøª{œ»"g¾¢•,G5›Fåìôi NlmCR¯~3µúT+RSÐô‚ ïõ/€äk\0ÈÁѯ€<’hrv²Y Ë‚I ûÒ–¯’n0LãäV¼òðxüHÀÛ¡rý œ°~çåi-¹éŽ„ÂÓ3Iylr9¤ÛéB(Âáù¯‡Ããaȱ&ŽM…Lœ­XÅ4Ù1¨N¡»à%—E¬mÑ‹á‹›AÈ?2þHj¯»Ó‰¤D}ès)¼áü|æÇŠxáâ#ƒˆÇF–JQÆú]þ)½Sí*,Ü (-¹±þ¯{`¼šÉÆÔ­ò‡¿øŸ#II"Þý…[@ßÃ(Õ-%¦}´,`+»×ÁzQDx c+ƒ9"ì5˜Çyã³|ƶHÝ̆|3#QÒø7*rRyc,&òNéCÇí‘•ß;e+‰ÂpÖr›ÝÌÓG˜ešê -žÌÌ2M¹N ¦“•“ôß»Ü9u \¢ÔTS£KhvÍžïê±& ¼:擈Bb])P¡u>œe,9ªQäé.^ fÛêI¿ÃÍq›EÓæö%Ï‹~äŸËìbMÊ™ ¼2 @Í£,cYćÊÔ¢[£g¦Š’¥:ŽR‡ìŒ¤‘9þÒÇñ4¨ÝhTƒbÒñÕªbÔé8¿èÊŒrT–pC£¦\U8Ýe®–üº½nY7˜Öy®riMS:´­–ΘÂS§ñHÚǹ™£á£¤¶0¸,e­4s»”!æÚºûQšSú¦eÆE¯Â©’õiV‘éYq¦óƒV-«*J¶bLTJuV²ÞjÄ"¬K±-0õG5ÀFu§éh¯Ú¿!†ÓƒD5,r«Zã§à#]< ´Pñv‚6Å[dzÃs>•þ,#ÙÓ‘0µÅ3îøþ)Tè.—kû:œ^Ku]je·ŒcAjUÅëÝŸös¨ÿ£;ãVÖ¯عë=­øÜkRþÖÆîl\»¬…töÖl^ëgKl«mM˜0ÀÜ=n¨zSr&§uo» ™¤ØáŽY\*ªô¥_k¥ëcö½/gvHRñ ×´ûU¯gÑš`è6—ÁVôݽrL[hj6V+¬1dTCrÅ­ª:SûÅþ28­»3X\¥L9n¢P·øµ²G×IÀcò4½¦$'@ÉšâçÙÈ‹ä°ŽÔÌgÖ öÊ9 o ­ÓWòÏ*N4tw„F¼®4wúo##Œ¿`õY‹]-gaï¬è=2ºµ'V¢ÜÖ°Þ‘9¢ï$ue/Ý×L+sÓN´éT˜A–å—Õ¸ö3oB+N6/˜Ó Žµ‘·zÀ˜þUd•îó±Ûùg@“6Ë»öpG,ìj+úKö€¼Nk`Iô¾åŒ6°Ž™Jö¾ú´À–d.´m×n»[K~ír)IŽWÐ$ô±yÃ:Na7WµéfÙ9:·'+…ÛVÞà²_fbW£V°ìí·ŠÁºÓ‚ºZÎÖ¾6˜º :!üÝD£_‡1þëû³Ú7p¯O.ët“üŸ8ô¬mØñ6}ä ‹q_I~`²¾|âWyŽî–+:æšž¹dyÕLœ;ý£ˆ-r°3®îfûU•éXÛå pæ,Œ¢ôt^Ó§Ó·‘Ä rŠÏúSªÚ*-:ƒXàbÚ¹ß_ïÌ(ñiö¾¯þü£>ò¿•{íÁg´Ùü¥;ºLm¶÷ׯDýNyò²™]y—yãÏ[÷¿ë†Ä\߯9 OXÔ)oåm|Ä!'>é]®WãÕ¯s÷ߥ·=µ¿œÎÓR~ª_=©nŽåGòö`}3ÝùÛ]™ºwùã å,߷·¸öôê’º¹êý,ôŸó­is&^üæF/Š§ŽbÀÉÕÉŠÃjöI¹Åâ–îêÍ2¯ñO¼a’ÛÐxmöRñg|g5ÙU~ÉgÄ¥QœçyÐZôÖ}nWm¸µa?’Lû‡€Ì´ç·~¹w€'k‹ÓdO¦èLËÅe\•LjþÇ\ ø€òVgv&l§j˜çÃÄ ‡vÂc`<–ozuvqÒ×i;˜‚ü7b]„×'9,¸rfwúv„jgnr¶„…wTugp^G”CJ…$8! p † à†PãpHă*Xb“”vkç€CåüÅ?»ç…»—hMÆt w]¿ÄT4·.ª±€ ðœxð‰0ð€  pàXàb=8gµJ%å}³çfòFu89®ãqAÈ:SXj0††À‰P”hpð Ò °‰þ`ðÞøŒ lXiÃ؃CRWÖ+r×k¼×i¥ç^ÝÄ/-ˆlº ßø‰0רŸ¨šèßxšš š0ß(Ž¥Ø ¢à p‘ `àl8‘|oä¥Gá…ÉGD™çeÈ‹esX÷ u؆ 𠚸`¤þŠ Û(YùPš¨#0 `‘ €Éù %PÀÀ‰'P‡“s\÷gäçk+Y0‰Cæx p™•!pty•XÙ0`”W¹‰@”ÒX‰ÉPþ‰ÛxÏøŽ¢8ЋiÀsxŽççŽåv€…8w—whiimk¹]¤&ð–q©sY— ùYÙ˜{y”J‰Œ€)˜ßXŠ†I—‰ ŽŒ™—9‘9™•9PFèešix/˜’D÷™¦—.–™k8 ‹©;Ù“ÎÈ—WéÕX‰p‰#" U¹“DÉšÓ˜•ÒHŠY”JÍØŒÀ0ŒÍh”0 Ðs( #) ‘é°‡çxÃöCVr{ÊkÁšKuÀ"à HŠ™¡:˜0ß™X¹ž«™•*É¡J©U‰ŸïùþÀŒï™‰¥È‰œ¸‘€Ç8Ž©ÁÙ[FZì× ‡Ø~½(¤ל‹h64© P(ºšXùI‰Ú¥v‰›Yy¢ŸøŸø@”C©Õh”ï£ gz•ÐH£œÈŠx4ªÐj¤9ØU†ˆ§(w Сzö¥é ŠÒ8ŽŠ{¹—í ãIžy7Y›*Z•ð¤x¢>iŸ÷y `¦ÙŒtYŠMI£~ÉŠ±y‘$`wR§œîès{ʧLHzhi¬Ö†¢pŒþH—Øx©Î˜‰žà”áùp¨!P•&  !{Y—0­þ¥šŒèy—£zâÉ,p­1ÊŒz­‡Ùž›H£0Cš–³J«iÙ„/¹j—¦«À«y¿Ú¢ÂJ¬ÆŠ¬" ¬Ìꬥ­ÒJ­êª‰×ššM©­‡š¢Ýú­áڬ͸˜×ù抮 yÀ®஺7}Ÿ9¯ôª–Þ¨AûŸÖ¸žùX)|¹˜!@”}©”Ué×j”&ê¡ , ) 0­F©´í©+¦‡éž ª¦™x¦jš¨ Àê‰ù¦›Z À P§—²f{¶ßó~“v¨‘ `Oz¡ˆ9¢ÒžšøšJ9¥“êžâɨ+Ðþ¡ßžI‹¦È:±‰‰ªà²YŠ‰Ú¸ÀŒ‘Y¹F©±Îx¸ï™•šÈ‰ÀÏ(ŠÉQ¤h›º Š‚2£l€£Œ€©Ïˆ›»8ŽY›8 ŽDk”កÃË ,ð/ªE+µ<Û¢¡¸¥uK¹ï)žÌ˜¦T{¦y ª¤ú¹ÒèJ¹¢x3©ºêk¤²EQº=Úu[vˆŠéù“ ±ú¢ÍZ°)ª¿ ¢8 ­0­Ã*;¬DË2@¬À¼I10Àâ ›àšš÷¹¬¬I£N9” £à[¹ÍH´.@Ái.þ¹˜*\ª”º˜ð‰ À®0‘ë{ÃT'CvÅWË“j9·¯¢¸œÈ›¨¢¬ÉŠ»ëé¢FÛž×êàŠiÊÂDûE¤¸¼3À¼1@ 1Àc ‘ÉIªÍ¨JÙ¥èE{¦•›¦©Â€Æjú±þš·Š-*Žsª€Ã† Í„¤0SÀ‰ÚiFÛ¹íy´áÈŠêŠz´ëG‹¸šØ¸Ü«‹“0]ü0ÁÜ‹Æ1мàÚ¼Îèɪšyù¢ Û“í™Â‹˜J®U©ž ‘\¹0\•Þ(³)ê•jhÇÜÌêvvùÊÈŽìþl¦G¹áYÉ—œ¨J¬ÓÊÉ„ûÀÝȽ~ëžÓJʦ̼© « ­œÀ°\²\°´<¶¼¸¬‰ºÜÂ}éË9³ú8Ì‘‰Ç±Éì†ÌìÌÍ̺Þ6.ŒQ)8Z®y<¼H;ÂiZ¹Yi¦lÑÃü‹•Í:#ýÊX¬Çˆk6p¦|Ê,P5À¼ ®7‰›fº”ßH3륟˜¡‹Ù÷ɽG ÊR«¦ÎhÆ‘9¬U{› ©È‰4Œº M¯,[¥¹‰Z° \°c¼˜>ëŒÊ ®‡ÚÕ iÓ‹¨ÓÙžH 8 ªáIÆîŒÊ0°À–¸Çë·&ý6 þÇ4-6;—Å«“ ˜e=Ô.±ýꞟ,ž¼Â:ùÉžë—µ¡hŠ!Ë®mHÕU «W- €­°É8­.ð­ˆË¿m}®€ ì·;­÷™¨4í·#ÝĬÇ" ýZ¨ú¨»p!À0ðbŒÅcÍÉ¿Žˆ¹ÇMÙ”wYȨšÇ¾uyžÛ±ø ÃJ9Š4ªŸ pãñÙ´zÕ· Õt©““Á{,à°!ªŒôÍÛû•Ë¼È´\°PýJ×X p'@ÕY…º¯ÜÊ+Vº·Û­Ü«®3z‰ûX”´ë°¤ª”™xïiÇ÷þ9˜íÔ•;£p¼‰PÙê¥Þا^ÿ¨êÍËê]°ë{³žæà)·¹n´ŸLÅ ¿Î±Ê¨Ô]ìÊxìÛ˜ìw¹ì…ÜuÎkØu™v«Ìd‡¢Û¿Üìà”š¦â™š;I;éþ‹˜e:­쯡hê$ Šð€8 år;å nD+Æc\´ù¢©š;›³ÍÈŠÓÉŠÚ]—yì½ÞhÌÄ.Ƶñ)»°±ɉñ9àü)–QWñ׌G>/bè.#3‰b›Œü«‰6óÝ·þ´ß¦\Às©¢ÁM¬°5±;‰“Ÿh³<ðÀŸ=pŽ®ø 8ø >Ö¨\çNi¥ ¬Ñè©­ ºoj—¢ßج™Î³}[ìK—G©´ÝØÄñ½QÊùI¾Ÿ;Žû"|`a×¾}n`¨Áà @ŠØáD !F`F ø"xêWÒcÄ]3!*„hf"V»F¸ÀâÅ \Ä ja«QJmhB(XP5mEéB¥ .šVJõÀ‰Ñ”™=‹–¸lÏ€uÛV .3¹ÕÚ®õ€š€F‘{'"jÕIò]pá¢Æ©vï6X@÷®‹“™~ZÈ„¿æ þ”rd.*É|>ìzØ!A GzˆÜ׸áBsjúbåå™\NeŸº>,š@HŸÔ¨‘ ^øC(» 1걈ÎÓOG’=¸ ªË_G¨T¯‡¥“îb`à@Úùô­µ&®Û·úõ7Óv^zñUÊ è¸$*…E‚˜b0ÆÙcJF™:–a–Òf}Æ™rµEPÚi¤¶Z­½vg²EE›m¸éf¡:¾5Ü#Äi`Ü"ɉ6È>À=GtšTWvÚ}Ö!à¥2R,9‚ ê±7H{ïÅW_–YÈe—^~‰èâ :¥Ô¶“”XR Ýóèþ<(H+PZÇ‚ "€` ÏÅàfŠnpÑH$E%Tº¬6„ª?‰~ÄÝu3¤”*Úiâ‰X²‹»ìÒ^{HA~÷wd:£HhAd B=Î-Ñ _eA%­H2K{ˆLÀ@þ βB/Ó%´Ü--5yM€8â8°â›‹mƈý´SÁ +°c & Î;Ý:˜Ôƒ 0ÔsvæŒByæö£ ¾#R }`Bm"¹Ò5öh†ðhà¼`ƒP/À:!0.&,ì‰ *»TEÓ( rñ¼Ä?¥ìƒŸX—,U!ÆÂ&Öu›1-õÀ> 3Ý‚È$ 4 ?=´–à t˜¿4Ž€á4Ý´ 8àÀ¨›í3Á!\wròÖ-Vr‚"ñyïtÉxr¶âï‚ÆP¢“NBÒ¡ÙŠðI¼ÖAþ=¸&hý&…ô !é“Afê1þƒ×­BM[Äi…-ŒDd'—)ÈcD7®NT‚uZé„œ(aKøˆ)Ob ì ¡ñÜä&‡8Π॥x4\ËÒ¸Á<æ9 '2›“…áàh!ðŒA †'U¬  í¹‡vç(N@‡=¨FwÔæLçsT‹˜/ƒ%ê5`pà7ˆ$8¤Z‡‡>%(žhÙ $#+* Ø…ß¾ÕªQ؃)ÚâШ‚UFV•ÊûИr ¡O0¥)V©H±¡ç?2dV ?É%qŒã…TÄ… ‡ì+cÙÚLÂÇì¨C”ÀDëx „ÆkE øA¨þéñ£} )Õh©‘lfŒØÁ ’Ôæ!°Ê*µ’¯üG,3AËËtê–¹Ü%S¼öKЄFÃŒ_èŽY‘dnD iæ3£9ÍÑ4çšÙ´SC¸éMp¦gœ“kÙäÎ Éœb~kg*JO“ͳ õ$?OÖ—ŸŠl36ÓJË,¬TU(CªˆªµÍ 9¾âŽ¤&uM¯tĤ° xþ¼›òä‡Ä˜:Žºãˆèð„vZ2¯mS £Š6³Gx!E Z¶§thBŽºz¤A¸ ô¬ÂNu’PS.Ç9 @”gíäñÖJÃæ9 z`8.àC49GŽâµ´€$­zo  l²í4SPš_y×Q¦Ñ ‚@f5Ç p€Åè×L '¨i/H :æˆDoÊGL­Æ¾ðð)r¬èf=Ná ×&¥39Î!4çΟþ|Œã.sžþ4QW0±Ç¦ sMæ¯.ˆUž)@€!Z¯‹<¦åeÉJfò “å1/)`À°€JÔ‘£H ‰ÓØxrªâU`NÈÓ*“EÌÞ\Æ\tKU¼fÜ>«ˆP(ÚæOÇX›D} #¯Ál¾ ²YC0$ è§èŠø!.qõP_Qµ†^gsªÉ.F`=Hl¥Ÿ ‚ÀRâÎ쬈aîÀ€Y±Þ¸"^±œI±Bïð †ÉR3žeì~C” X@•PQT…HLž@ïCp±°„¯ŽƒŒ&äuÊWz¢Í+8Õ¼üQ>ñ@b|ùé<2)LµþOdwLòLyj Ðüé.€BwFxÉèÈg0΄Æ#™Á óœ‘fú¯ïœ$ò‘㔀¶Ógt¼Í*’Bâ™CÕ#÷9Â})ùs!ÆT‚f†x@ªR x†‘ÑÒ `‡×í¹7œõk4à»ë!s=l¹'»Þ8¸ïE;$БV¡›êÀeAÂ's€ 5pzL>ø× d`Ró˜]ØmS‚‘ìÐj>VzŽñ7_Œ¾ v@tä‰CÐò ðå”yý?Dðvub“;•0°Š: ‚b~lê!ŠU¥m„Fð²j¥ã?Ey\[þú(A ¡(¦ŒºÌW£LÌDðn 8ͧxRç_â½ Ç1 `¥'ÖÅ.”Ô¯ סŠ­h€ÑÀDê@ÑŠºÞxëÇ”˜œ¶L–ÌÉ[µ¹H³®nloŒj€_ã+;¯yç $´Mò^÷ó'ª¥ððèFÏ]) °8™!G«€ ›à ›° Áq+˜ƒ11ƒ`A,&:†t`cüðŠÒ‰â’p ~t ­pN˜‰ t†`b`-Þe 0dÏãÀt¾×%88lÀ'ÂG| `|›À.ËW#à|Š É¥ Ôg}“}56Ýçpþàâ‡5ïP~$¡Áêw;®mîçð‡òG–bø·w ±•rþwk˜-x6)Q€"…€¢p| X9SF¦ÒHr[%:x ¸$„á½ô ¥‚Y”ãÂ9(H *XY°ç‚ Å6ƒÐcƒÒÀ<Ë“d¤l9”d£¨dnµ4Ìó]4á9 °8BaXÖ6 ^ªå .©Åcäî>á’ônx>ïˆð,ó=¢em ²‘ˆ`aò!oh)Uƒ= o¡ñJ—hpŒ– ^¡ñEOÁ ¤GèùN/@4p6³3 ‘3þ1.VTQDÙ£p ¡ ß±q}Å·Ffæao.ö0€“àaõ 0 „€‚°À‚ºp÷‚z¬‚e+tP`VlÕs7ÔŠ¿vŠàbs"PÛáebÀqcè%(cd ç@gv•usóE¤ þ·*3"©Áo_3) ¡"Žr¢La03–Ñwˆ7€Q‹[æ2ud1„°*?F¶ 9Á™ÍOSÅQ’$*ƒ5+¨`T°ƒy„ €y› XaPÅ —WY(y•UŠO¦ŠÈ³d2›¨˜CÀglƒ¥KÄDIñCíÆW–¹=Õy }"'uTGC y™@>SgKþÕy‹js1õ!“uJ?ä}ضR¯ö6¡×fy((à>4¶ 2"zG}µáËÄd‡o7–¯±…Ï‘8Ò!2z_ÿ°#€r2¡ €13Ñ:§3‘Ž³}!3‘Z:•(Ρz’á ëQG¢’i™yõE2U2IJ#ƒ‚ƒáÞ6Šd¨l­ˆŠã@s>3t×òH1ÁåxÄá{·S»ÀWå„'ËVGîPNʬ`|Àj™!y&„”–yv¡”Q©6U4/ù L,Bc¡WSùs?‚r»`húwùÐW1$–vŠa›ñ£4%ULhJþvœñôÀ‰“‘Ó2 Ðm‰T?îP*ŽòGóä2› ¤ O>q€:Ž0ˆ1ŽÚx5ã5ÙR*¹PH£ùŠ–*ˆÐ¢àªÉãª0:›7:s¾ã3€«ºú«¹5”ñ¬Â ¤…eTÖ¬Ûö Ëšà¬ÐØ1­·Ô”üi¯èæ ÚŠ¦Zøl®"®í™–æèÊcT0íï¯o´¯SÙ„¯éª~Яõ°4 °ÙQ°¡‡°aC K9 U ·†y_›ñœ“TV¥Û-+*´v9†÷\Ør²ßQ,H¶<-i£6ð< €Ÿ þð•;Y&¡ð>ýðÚ™mS×25`Xy¢.·dT2‚¡"€P‘ªjò dB!Ч,»à÷7QQ§ìh\‰=~æ¶ò#g„æ÷5}µ–5ÒË$o —áFd ßªX³V?´¨>/ '¸+I„Ç*ë`˜÷²*¦á¶à ’!K¤à¤ÀA(U12u2:h'!Þ+b79”RšÉaPZE)÷²„öÍ“{5:£¦h£Ð å³+Y^Â9N™Ð å„ Ïimy¢ é»e¶4“Ã.ó¬Û”êÀWû5rržóù0L仢„®Uc`ëeYE¼X*5Lþ¥×#þm÷q?ëØ~·FŽupçFŸ^RÁ7 8U÷ì@5ñˆô[^Q5st³ržøe¿É˜G2‘ça ;*¥0xçá@„;l2Æ&È‚Šv-à]c!ÁÍsu À3}ÜXÑ‹EI ¢•Ð.K·¼—œÃ;uF Â-s+€t´Û.$ÕZ¾ø'•’$1¥àÄð &æáŒÑ €QEƒ×lÚ8pãÊp—(q ³qÁ¦&/"¡{†‹…=怮:5Æä6ý(A0¤§³=ÕD¡¢ # íÔ9F¡¢3¬Ê ÙIüÀ"·bIÒU!=’àþ9Så¥rÐYw/  Ðc¨õƒ=d–žâu*’¬…í¤"€AIRج5 …‰Z}Št>K¼Šá…Ê!<*ãׇVØ5J—É;/g“¯a9P¶ûÊ­hוàÁg\èQÅŒa‹Ö*PÄTÌOwªÒ‹ÅgÛÛw·A$ªv=ZÁ&‹›iºà¦f‚ šó$#»¢]­¦Ú‚NúðÕ£€z‚ ´h3} ;SšxŒ’„û*P¢u±Ë«Ô§¤*dÆu$L»ÚÖ-e’pá²Ê7¾ª jž 7à Ö\N‰×“>  -\!ü׋±¤cOþZFçyÌ8 ܪŸ,R?i93¾d·¼%!X»@l'žŒf–’ào±KVó?cLŽéê? `’Ã'ÁjË(† §T µ@I;na "u€WñQ‘ÊQfÚ²ÔÙA¸ž žùS_a¢'˜;§Ófa–Ç×47ÓøE‘(? F m”@뺸”÷ ‹ØôaâÃ2B¼QZuËš'@`|z".+à“©À.ªÒGç«É*G\wÎãÒ2ÐnžfÞJÚyU"‘ó7hz Q²Î8/¤UÚ3v­Ýè ¬¯–in´À¶f)ˆÚ1êu¹ £ÝQ–ý¾ {%,cûþÖ-Õü&2¢—"*M WŤÛI…5fý IÁP,7ÁR|ÁÞÏfË<ßæÂô½5õÀWÏ©Ûà ËÖßÒÞ”Þ2$Î2> N ÐàÖy®ÙÝ2á× –¾á‰z5…Åáç` ZØw#ℶ*zyaâÆ­+Nã€F/ãl*AãK¸|ÄQìŠã ^<Þã ð㎳lÕ)Õ•àQM¤“¸€äsB+ÀäÍáähÇQ.'S¾V3e|ßQɉäå*æ›Qžg\W£â Á´âõÑ |Á]TÄûD·”šð|Q2Aé8Ç'Z£àøþm+€MC nŽ­'híدä³C>IuEàš5Ïv‰”Ì°n`¯Î7‚˜œžé”g+öª7"ñ($m‰ y™˜:é°\xߘ—sç(õp5€v±Œx}ªß¯@³e‚LÇcH–íq+5LJt:!ƒ;„DŽn ›ðâM榪ý Gö€ ÒYDCi.p[bé@¼âØRJè…•œ‘Ñ*1 ±">ÀuSÊPTÓç@.é¢ê.y!ëˆÜQu¢VìF¨×8¢¤føàŠÐÎÕûµ "(ÔÈ"^è$Õ¡¢Œµà[©°AŽñ\€n¸žŠ0Ñ£G…嚸QO€•Žo|b~‰¨F æ8ðnt³Å &$®5(B;üÀ$E¹I¬@ø›’™ e€ƒë(VV$À;BlKK¿{ D"Ž‚þ¢XJÙ ìB°|B|­Îr¡¥¶Ä°cäÐJ°ÃB¨ 5§l@Pð#4h†|”†’B8´\ä±Á np `gg0Ê3zÆŒºç(þaIFaà4œM*±@„ $€X+*Ü™‰/SŠP”ŠbE8þ÷¿u="Š1IªBJ—´+¯‘ :æ!ÎñÂZXJE ùPèGK2Š—œœR“ 9é©òŸ4Q'§Â€Qz¬`?u`²“1k“ˆ—‘´²©0ð3y”F¸'d, :IŠ ð–±möÕ ÛE<èR†pG*#’3yA!l1žÜG?*ydº•5rU°$-äü¶ã ˆå„± ßbõK×é­Sj&Á§$•(T` ¡+yª"b U®n'’Ø!‡o’1•}Åä­GÊk"zR™F.RÁShU0n]hÁ„XÅœe$1+Èé5C6½ØCGE1cò“¼AkYÌ aS¶H±d`Q¢bÉ ip ³L›v£:಄ÄU|ª2Šr“`È«²]D Æ2 ñ]¿“”9¶²•V!ülýlȉ´.x)®@ºž#¦;w›ªÀXÜ-ÊÕÔB†¶´=ÐR}äæ Í`-ÉS ,a.6aQg¤X•ðVYrM¼¡{ß5MDk ‹:š”Bß“ Úà $QyŸP*Ðÿ¢ ²EG!Uq.ëð½4N½T+P2òÂ@ÛbX]CVŠ`815¡ ôânPe¦Ð€0²F=Wáq9Áj‚ @L1àw•]†ÑJéq$Å|„ *ÐN£¾ðAȳR8Ñ4Ò ÁtÝáþFæcc1D a”+l@1<.2°’†sgPs&tX!}HI  Çàw À@PC÷)/ðGÀöTí%>K¡Á>žr+u ‚AŠc0ßÀW¯à{¤'%Ð 4`—U+E2$0T2E@<` ˆðá±€ñ 2¡‰Á]°R†… ¦7€T$!ez¡g„xüå°ä>ñm÷nEÀ §­²8³”-R¶fæ uäPL§†2)ÏåPØçP/ðHZátáÒ!‘4÷± è15™·/ð‰Èðsá€rÜþ1G**ðL7)rÖ +äV$w®‘ÅdpáÃ,iFxIp€>PÿtPbGF7U>°FV³¢ƒ§ÅP7ª7¡™Ø• à3‚ThäGIÐ<ðù‘%P–™Hy… (+Åòm?Bñ+ #(a+A/D¢X‡å!žòpTB1 K±ZŽP1¤-W£Q0J/0&÷òƒP:©O‹°1™½ö!Àtyv!•l‘d d5š)U–yF—4ù=5P'” mT_"äž·M“7ûñPþÀ3‘4qCc”Åtë§ s yÔ“R"-0…F]IC€‚òu$@T1ëy-é°UdI„EÓ!Ð!à_!`ßã=ËЛ?;‰]¤w Ð!hùŽæ‚¡¨‚ÄAZ¡âÅ'r×b~1¸$Ý‘Et±-+u/+•nã€0@]œDZVä>,ÕŠâdÆh-¢  /915­YÙx#âáŸÉ”Ùù*‰¤=ƒW˜~2)õXø¥ < Iep‡§Š¹¥4©”‹Ü`R…jˆP²Õw$’yGáBšTE@¾8Q":ÇþtÊðH\¥ÖÇt_ŠjD“žPÙrJûÆ52x86E†þ#Atg†!P›\õ̓} Záœ*¹|­eŠ óð)¾bÔ#rÇò<—rxˆ0p¥ªE1z!O" ?=Ðkh©«Ò±Lûe ¶ðÀU ÐE~¢´£=Z¬[Œ ¤>pEŠ}K–¤kåÕ¤ŒÒ5FFlSŠUj„Í€¥‹ ¥¯â˜.¤BYt…@¦7`¦“ÉlŠ ¦À¦n*tdrŠ”u:,§ §¤Â§RÕ!ŠŽ‚z„šzxq¨é¨÷I]ŒêçáÊ’ê)”j©"þ€©¤©©Þ.žº  zUzÑŠA¦Z,é ªÊªÏ’×Ю5 «WS«#p«¹* ùÁVŽ¥(¿Âê ^á)4 [ÅðTÉ _ÀRAàˆ¤ku@9˜•F8m…ôŸ…}‚t Á¸W›U mˆÈ!ùu)’žÞ…°5 ”†&QŒ†ÂP“‚>Е‘é¡£‘äÏúGù¥?"€–`«Q…=5€Dh„N‘€W¢ë3iR,’À9©_ú… EœaéÛWy3AEp­_¬ÒzÖr[ÜñTW’Jöpw ¡h”²*$suu¡%´ø ~¡þ …?° ²SŠ@£wÔk¨Ð ιzêŸOEzŸåQ!¥§Ëp*•‘/ ‹p k—Ù…Z:ç= H”´F¥ 4å7÷¯ã2E…Äž"ª4-ЙHZnfw÷1.+åp`’"w\Ww x¨>‘vA k9*­EµIågŽRUX•–X±Ç ªðf,åñ¶QkVhÉDQyåÃиV[ öG÷ðº`f§‘<"Ñ<aÄ}zôñ^á /J œÜ¡’Ð剈 úïõ{@†dHè½è‹u5åO?G"1<2`þ²RW#ŸèQ&AH”d-XB»kõ¥›_Æ )ëñ}…ÃãN!Nö–vëq 1ü´\hÇ·70 ‘ÐÔð¶x¤@° 'ˆá’* (q…HÐ!WÃ]ìÅ9Ò‘-:8¸¶.éõK5´õŸq”‘~ÇQtœ[D¬) ác¡·ßÑñ ûßã)¹¢²*1GÄ’<Ê¿P ¥2ȉðc‰ŸrPºG]·@rdxÊÁ°¸¿É…Ð ÿ”š)ò\xäà³oaJRTÁYD0Ðpô¦m´i tiG>?w´ÆKy+!¶À&þ– xI¹·”703Pò³ZÞÜáp-pˆhéôƎšU.ß|U¿$Ë«pMÝqÊ$Ä7R† ›”a>a,±‡I ®Gc<Ö2^‡á¡}ÿ5`†Š…& fªÖë ¢±›†ŸñP€7;æPHhÅ´‰èlÒ ÜQt«ˆƒ!_@ 3С¤çû+úP9‡ N—ÏøN‘ûGtKØry|L‡‹€}Éó4@;#5Ûef´¢q^ÑëZ‘èQ(¡s¿¶Z˜r@ ÑŸÒ È9TyO1)äõ#wuÔ!-å6¤YƒfÚÂ(Z¤×Œã¥þ;%è|ûÆ׈|ËE$BçÉ´PÆÓ4°Õ¥±îñ*2øØ Ú9òÌ#ñ™€>18m 5)øU yŸ0µ*%*+!ÝÝPtý´Ïà*©´I-ò´·•_̶Â@ØÕ>ðò½OuøH*xˆ€º¢4Zü>ù/#€‹†ÜQoðØÉééòåP-òšzq Ž­7ä@?ð“DFg·™K'[¾avÀBS»´äÙ2BÞ¼Z •Àæ[M†±3kWþ @P6p#³°‘âͱÄ*âí"!27™mÒä¶f¡_©DßÖ¢¤]9wTèZQŠ ÀæFS¼ô¤¡†â‘à!õP ž"~PJ1áþšþ¤Y’Âá(qJ}*Óö@â `â†}*Κ¢B§/I2^ëlã*€ã:¾›üÊ?¾‰øélQ^4F~SINáMþä åàR*TÎVykc!´å¹ ×óå^æ21æe¾=;ÇdLªlîæp~N2çY/ñ)xzÎ|>w~Þ¶’a'Aè$³V‡.Š®kÒèÜé÷(Ù rßY™©)ŒþF*ÝÀlð÷QDgfV]ž©ÔPÓâ_6¡ÙÃH”†¸&¬ï„›Gö|* ù¬ Á7àäÍ€>Ù<ЕÙ»\Ïç<µ £t!NAS›7 <‰_0$²À¶ ”‚s7$Ö`î!ìÂ<ࢠN¦(ŸæMéüÂËp€ÖÒŸ8tC×å¡ ©"Ù4Î2Àæö Põô¥2wòs%tšú‘Þô,2Y.Òx¬7·Z¾@/u(>åfWdQÊò‘Á-Ÿ‘›!Õ_V:°…v¤«†Rk´4‰Ý_ ?XA§Ü‚ZTa—âQF|<;YP,0’ó푵÷iwþÉò‘ª»‰>Ù!%+ +É›d}Ï÷¡ÔÒ>Û†¸1ð†ðô04A,_Ø,šËe›™E2‡ ÌÜàÂ×~ømŽQl 6Þ—µñÝ™¬˜‘”}-:HëàÓ ¬¯E€"Ø!!!!h(ÑIXØ’á"RcX(âØò¡Yób*#£ÊRQ©¢¡bè!ˆXùA[S£Áâ+è"B*LŠé(Á’úÂò "(âã“)r*S£"«áQMëè#ááÑú1+¡¢¢®R¤!‚úrCäÓ/¢a"@øp§AÂGý|ü¨á!Þ„%2n¨ÚþtéP¸ ¸ÔZ/Ä8êJ–Ô€Yˆ AÔiÁ²‚„,X®!U´ÉÀ‰²Rwb Œp¡ÂQg ¢KC9ZŠ$ÛdˆÅÓ  E`ÕÈÃ…½(ªU$¹ Ô6@xj¨]‡¥„0Õxz™Ks‘I"Ø"‚.K*u€0÷)*o"Tù5ÎC… Ž‰˜¥¡Â4œ<`MwïT ¨Té0„ÓPˆcæ0½ AÄ_¾@€ÖB]Mc[;¥óÀ"\An©RÂE5x˜Ad¢Bƒ§"„‡~-ÝR$üÒ8E€¥q Q\æ3ºbÚ¦%a*Óäáþß]sNQËQ~Ù¦Ž >à´'0Á(a²<H²QêÉp@FIÀ 1Fl#5ØÖˆ‚"óÂE"- -·¥ÆÜ_o f AÔÃ!EP·” Ò‚s!ÀC2MXAi…ÀÊ0ÈÏ#iå22¤‡R,‚±'’ ƒ)w‚Õ5ªè#\{A¼F 5d³_†·aÄ#% ’mF¨BƒÖ#õÁ$òÖœ5*Q!Š„ž,¥²Š7/È ‹½˜K,ÓœåJoI ÓS‹|Ù˜˜æ”éÙû„(Áš4´ù¦0‚ÈéË!uj·jy‚°§ }’è ‹`hDˆ*êì¶O…ðh¤“fW饙B²i‰qyŠq3ȤL›Y§Fè骭ª&Žv±ÎZë­¹îÚ«5À–)ð" )²Ê2 N8GëÁ´ÄX‹­UÚrëå·W:".¹æ¢«.qíªð.9ò&GïˆÜ›þﾂ­æË¿\ðÁªÀ0n) »âðSC0qeÓ*jÖˆ`ƒ /ŒìtN2Ø0Û~Ìb˜Ì‰JÊÍYÅzs—/i6 žäÜæ «É¯¾È+8BPµ× #Ð@Ci2)$tµÔÃzWl'eãˆ75,& *þÃ:¬³6Ç5¨ÁsóBë«MÌ*_í$H1[&e°J_‡GIГ%Œ€(*i×´ü´*%ÈO1ÒLÐ3›!e,Ί‚tžìBHÚù€L¢R-‹MèpS ‘›¢]+‚Ü÷úµÂHÈ×4v²ˆTä„= !ˆæÙþaÂiT‰ìáÞíGoÈ•EPF¨Nëª`:Ô§ý\ä}Oz‚˜‰9q"?ˆ ц" Æ#’ "p¸*­K’ 4§ÏülÆf… ÀF5ÿ±'²; Z}W 6|ÕŒGF€[Üä6·Эî#!¢Ý´y·:â=o"Ô»DÀ·¾ùmãñc)OxW ~Cæ| OùúðÀ€«(² ¸Z­rñÉPFãñH„¨ròFˆü)Ç€ŸWþ 4¨fñ€!áþ >Ê$=À—ài6!¡À6ÆC±Y*ѧµ åKè5, e<ùð&`SU @èt´SW40"³ò ’t‡Œ1R‰ˆÚñïíápQ” ãr s%34b%fVVâ Ã35ÁqB=2—eâ&)ô -YròóUÊÄPôPÅR!ëP!z¦A”û þ8x ¢º7}r&InÒSÀq&ñ+&±BlG „6ÖàN1Kž@b¥ƒá¸«±<ŸP.Nò2X¯Ô‚0k\ÇA=a•@„nÑŽ€L¯$Pñál¦äuB&äD³‚+ýxYT53p2¯Q ìÇ /E+ I°ð­õb‚0eׇ€³Kˆ ,3%Ä3Gå ãò.ÇQs­åàaQÐÒĸB<#ôàŸ¦ f¶Î%nâÖ#@s*@†q—ªaRa· Ð Z«‘Õy›pr5Ù€ ’„Œ €ÜRV%¡ÛpdM¸U¥6ñþC0af|ÃDsø=ÃS ¾”eHf†©Àhxñ)ÉQärŸH‘°_‘`‰%€—ÓG @kFi–S’GBÑ=ðJ¡I S,¡†ëã FÐ?´³E€ƒ30‘†Òé†áñ€¨R~W! Ö‘Ñ%<öI¨€‘N¢{©¥{¡Í(?evx I2g†ª Q qÌ>aC =œÆ2=ë á¦UÙqM€²>õe3Ùà—´Q D€F¡° ¿(«2!N)$Q1±â€òA€gÍø~ðJ¡= 7¸"=‘M2È|3aW5БFSb/®þe¡΢C±Ž*)À@‹ºA ˆÝQ£ä7)‡T%EñL‘èI›£Iësc…G+È°Kp 3,p‡­%R,1OV[ŽÀBPgC;bÃ8å‰ éÐøO;ášð𠟈Ö€ñÀP… Á%3HyBä h0(Q,4@#pÒr *° ²È²‹¤\>€!åÐZø1ê°>’\Á DâDjr&( ‡1C!Ôpý(=µ£DÖ ¸À6Au"¾ P©VŸ“+Î…!0`h((° Ø4§Å|‰`t z—þ“x¹ «ü€fl àcÓ ÓŠi&«ùÐ:lj«)‚«úpc™Õ«¿z"›§ËåžÇšnÊšZ+4H¥1 ÷ƒFÓ 8Öz%’s±… 5çšßšáš ãªåº,P‚®‚‚ 뺷íú®&¯KQ¯÷ºL±¯GЯÒ°Ë"°$¢bú0_•°5°°а<ð°wkÛ?T±ôËX4×±ð±#²•Á8ˆ7')»²WOLBP¨X3ûJ5˘PFa§µ»š/´q9´D§´¹p騴ÔÃDMë “E±Ñ:6pFP³b‚!³¡E>q ZÁ:­ãþ†2€ %Eð–)F H°Ywe{¹&^ö&#qÎÕú +Àf‹` ,¡¼"•š¯µ*]›G»g“"b2ÃyD€”H–-p¬’áQÃTwºáL )¾0´h3Ãp ¡E,ñ&›ÐF’aorŠ[vŠâVš<#’fÖV¡ ÂˆXW±?TPôa Zªý@ pÃÙE¸*ŸÐiiÈá<š ‘§•PÅ ÆÐZ‰ÿÀC‹Dp3œûU#EQU ø×»­:–W÷ ´±,, )V„¤0’ éÃfAS|@#¢I¿†þ„ Çácö:D°_„v‡(+4A˜1+ò-¥ «âH )¨ACPÊóБг b`œ<ÆË©¨>‹â›R‰l,J05½sÇÂ^Á¡?­À#A¥,%0\á±#³% ’Ñ<.!…J „àÈ¥¢‡üHPCø'aI0]Žhç(q^¤ÖºáW¾ µpQàèà&aüJÇ)ð ÉÑT2¡úü_UR˜Ýq á =ð–`òõÅÐÄΦ)Pè éä»gÁydƒü¦Ð´ÿq4©Œ@Uvd)²Y¨oA<³ŒCðþˆ‚g-x¬ðˆ"¹ H\S”¡ŸÀ È`ÀÐqp!I0“"ÄáPuÅ>„²#±ÈȉÍ ³)™@ÕR-% Td½²À#ÎØ|Š"Ø` „&Ê td0AI0lfU1cè$°±‡`©U‰V\ @ƒ«Ò\ :À!Ý3ò fY)Eð»¨âþ Ø,EÎAÜÆ ×°gEsƲ¨ËàU“,×Òµ3IÙ%3|ÑXŠŠpÍMÀc}ŠMÀ5§Cà'„20Ë›¤Q< ÎsÑ,UhXœáAéÈ Dp¡ÈTaº«á á ÆóÛ‚ðR9BKvìœp·„ Ö{ Y-‚å„h!wnADiåUTš)¿–µÖ2C=¸iLl7æE§“\sñÞpX7@0±½òë×@L¦gêÐ{¤* žÝ\Š4fYŽFµ­g•ÀPEñ%$`ŠA ÌP ªG€%ð>·#ãþ–nk†G¾Û$/¢ôCÁoÂ+ò.‹$ ‹¡.‹L@ê÷ƒ1še¬›Çd2ÓÆŧ”ŽΩ†PË°d”î‰R‰RÁ º› 3I}©AjöP‚tBÞ<]ˆ‚~œô("x…±*Æ°± Ãä*´*)³´RþT^*VŽåz¡åxe?ô¡³æÒ áÁ2G±å†àCÛ1)œV¼òZNl ¤Bç*`çî=X¼çLíç”èÇYV…±˜è‹Þáá~N ta|,›–®LÁp k½é³¹#§øé¢ꤞà¶W¨Ô-¬ÎAüà³±8þ³ŽC”–f5£9å!Éë˜Ù¿^ ™,cö7Æ`쀖 É~Ëîz$AòŒÑ.¯Dí±RØnt‰#¼:ˆ¶iœ¥ôðø@cѱBï$º$ٶר@+qÆ"¥-1ºÌ@Ø ¿>Z "›¯š‰¶¯•Q‡¯{fK ösÅy™G€àG@¤^‰Ž{Š±è¸'˜"PV­™;¹ÑßÀb ³ïr^Ç<þ ‘ÈÞ<àùÚíXšß„ê"^¨ŒŒª¶¿glûFR<sa}£7sëS-Xa½ïÝAU}d1-<#…Wï‹áþ†=`tß2³œ…È/ñ0HüÄyÔHª äç jŒIÆê€Ýa‚ƒ>-…--**„‡5/I2DII>!>AA2¡>¤5>-A00D7F*>CCŽE5C¨Ÿ¾¨·“*’>¤>·"5š³ -Eäzé`«2H5*ÒAI$>¢¸ƒÒÉ@âF y@¢DI·ÕÆ©hAðV"BH(R+AA,Xp"ÔhC xÐðaþD! D á!Bˆ 4Èð• ¢p& "U/<ÊQƒiY™\9 ÊêH¨x"dDˆP#‘Ì ÆJñ±¬E‹©è °„ ©îMjt´PZ¦É¸JfúHá1ùD5ÒBI‡Ê?>Ù+äAÆ*>>X ÕáD-ª¢¤Ö¨ð‡ÃÆ­P1D¨d½Ë]ˆf‘4;Yn‘G†?B·¦ðƒ'Ye>‚––.¦7ú:ƒ0®Ü`nV´ø1ž %Eª-?1ÜüˆE<¼xA¤ÅmÆŠTÕYA U5 „=\–@T1!DF2IAUUE•ÁPDÝ"“0A þ¤<èá-2$ ” Š€èŒT0¼@,¬$)\ipW AˆXÐS†Ì5HGdÕS"ˆ7D|¾ðTH7•àQИ¶ =¦ÜB)AÜ ¦ Ñô|í Á)‚uJ5±¹h¡¹ÁK$]5²R5Ö,6‚p$S qÉN/ñ%ÐâpD;%xvà¨P„y4•àA-ÖÁR£kü„*YüÀÊ2E ôÙ[>|ê›ÞâÈ)ÉNM8ç\ Q½åA ÍTX !Ôc!¼!ÁXAtrÏ”6½¥¬ "(+ÈB(+‚1^UàÁ¸£SÕŽåƒ bʨ¤L€YþÁX €°_YJƤBp5‹$`Ì€AŽ’mSsi§\¥“Õ²<+Aa*t‹,|*a"+AÀ©2 Qº7¬£ÌŽMz fO¦JÓ`ã+Ao*|@ÐT!ç k×Ö6S‡´€ )ÐÄ'œ¼±6 Cè›ÑƒWX--"¢|4äTútD öùGOd+„üÆR?a4=AÿúWªðäÈx„vê9 t 6"x„ V Ô °8(ò%mÝ#˃ÖǦp…-dÈ Í$ÃqÐäUªÊ ¾r˜‹ð;?DÇBDƒ1>Š„À+×ÄÌŠRì\¯¨é‹^”QÇHuž1klã mGXÎud‘P¤¦ÇBŽ\ŒP#ìÔèFرƠ|3 >…nf†„ŒðF´€’|zD¬s4DZŠ&È™þN|ŠãüÀ=æhFI“>m5ˆý6€Š"  >{Ò8æ³ÛDª—4QB YlXÄ6žù©ÖF6uŒ…c1Å=fXˆ‰¤>@9eCБ,¬Œ`z·ç°„ylAÔåC6ÕH¬DèË›±zÀ€¤¦Iezx.²XH°h  áD@ `ØGJá¼ 1 ˜Š ˆAx¬q""N’q8Ço©+‚Ø&öÓ|„Wsj&w:EL`ˆ˜4A„Âq¯I™²NÁšMøRU𑦟ñ”,‚€„Kø€&‹(z#:YN†¸G‚Ë,`ÊElQ„5i–€ë¶h N˜Â È‡[æ`I(±” %#¡T0SÓšß „P22í)§ …‚ @¢å Šjº±‚pb³ðÇ©þر,´m1Ÿ”r¾[!ƒˆäÓËz0ÐH¨MÀÁ PÏ$DKùXÇ-jp=Å4VL/Ç>Æ´‚ Õ ¶SKÜ„ÊÌ Ø…qÂBšL¢F…Ù lScĤ¼- A ™Ó&(°Ü9Jå&AÂÆ»×j>!¼n°@L®¨…ÞR×mÍQ^éfÀ~Ö­!b¢Ç¾Dj¡cµC”À8˜Ðe?2* ]!V¶¹F5К“Ê)…Ñ ŒPÚÀÔÀ!2Â:ôÚ$‘FkŒ &lqï¨Ïþ@FGi%R< Á FLia6°eÇ™ìÄþ (D¾Œi¶“A^…«å0PH»¥:°‚hâ6ˆ{Ü@Ù$1u20‚ÊLEªãx £H-‚‚Ç’„•X•DHHV°‚Þx¦×‡RÎÃu0„äŒrĘÃTÝ_ÝÌfùÆ\ü󌳖7$•À:Vr <Ê&Ÿe>–j8ǪÑT’ ”ò”£á"Gö3Ä8="+Ä¡ çÆ¡»v@ÄcÑ€êÜ=ˆ €›uÌQOFÉ4‹ˆ!©³Š~ bðE@”Rš $I :ÜuÞ W¨¼Ò6ÚIg²^ñ¦'¤%2ä'M†g¾p7{[Q`oÓGÐ2ð‘B¸þRAªbAP#!U+0é9Ç`(%°E®Vx!ó"#<‘5 +¡ïá¶R` âµ*V¥¼S5±gf„QÕ,ÐE`EÀ2ÝpMÎA%&•Y0P#"Æ ÈP!PIè ˜—k‹RˆÀ|@Q3 s(%"´s0`cq# B Ð8Ð7'¡B¡  -÷.,ÁFL:ãLqL2WRó'ƒ#÷  ‚È,PÄñÝSDð:PÂÿG#A1ZQ wr— Dð+ °†…ŒÑSá› ò$¡H_u†ÇñR2YÐ 2ò+4Uðþb’x%1 Ñ y„ƒ¸T"ÆÆUg U[ Ü +XKSSÛ! æÓàH°%Ê2P ±'ã°Â…,ÒQ\n—?ðRakgÁE:èVmB0„pM¹ÒpL 8ØF“²nG°Jж6sK1ñ+²R1#TK…Ë0“%? ó}! OREƒÁi Á%ð8 !@ˆ…˜ˆH’pƈŽq<‰’Ø”8 –8!¬‘‰é°‰œhžŠA Šèu¥(4-€Š“°ŠEЊ(G43‘²\´X¶¸’ÐÑ‹$Q76ä±{¡÷FÊqŒÅåÊøþ!ØdÏRÙRÕHv•#Á,ˆßXMâÈvåØ•\·%ê¨ íY2 ó(D7`Ë‚?“ ΑBþ8™BGi+Ü@×°ûãL!!}DA‰,"2¢ YLy3+ð‘!I[df‚ d C0CÐ}arQ¡Xpá ÈP®† #¡'Ò0;ù:À‚ §òˆýP¸i·UÀ@H7+AÃ1B„# Ð=LGË1A³)Îâ "pýPËñ?6?Á©U À]tV§ññx$àªâ‡’îp –r5À‚or¹%òEþàí–·8Æ.îPî¹Jü@éP+Ð $l…ó,t3Ù°5Z˜çÖ"Ž -ˆô„ð×edd¢ÇT#·0C<ð+$Cò ¸i} q †’Á2GaVŒw`…VʬáatùAõwÇ8& •°YÐàšbw¢wIP {²r°á5·Q¨³#é°8ôtƒKä0¼p-Š bóA*wõ* iE Px_ÞQ2Ç%} 磠µ¢c'y¸b1Žšvu€oaI¡®íx`æӪѤ2¸% *º'?þÏ*+¹‘Gï¿DkŸrW”‚WR//b!  `CÀnsSÓ¤!!û; 20øØ|ÀÂñA Ô‰#gJR“F*öÐ, pu†^á“+>_äÊoU¶.ÁÍpÁ&¾1?RI0aE*1"wpG¥U `>…r 0&!€qšàCÂsdš-¶C-7¨0.™Ó¦~Æ!«š¨›•,›E–%ëêÅ’|ò+©yGðTô—FHÈòïâW#öBd7A“A…e¥àÂBX¢ðq÷?+!µ0.×7 [XG Ô #°vÐ#0høþ g&’ÇÇ|%ó"€RäÜãKfZ¼E4 ¬Xdq:‡Ù8Wú“Hñ…똱 a‹K9üª,èµG‚cD;å§ -i4Ð É)°® D&CBñƒ o¢=GÁO¢WñµÀ1àg¢+6­Å7bAÁ—†‚¨qµ»'b:I‰[•wdQu ²O‚&—ò ”,„±áÍx UrD?K ! ave‡Mª‚2Xƒ©RaÇc!³ † Ý#·u#2ã@ …]±SŠP0c ˆ×`%¶)¹Á/@/`’þÁ="å‡Hè2sŒËÁ[2üQl ÃoÈ@œÍð¢34Ýi}2FÛÔ$Æ°G„ ¼ ˆÛ Á²^+w¢e‚æUIŠ&ƒ2{‚P&ì²²uÉÖ ‡ÐS €½´c‚à d ³¦ª~(¤•Q ”¯{åvLv±ûS(þ`–ò_÷ /Ã7°\ã(´ƒª? –ò‹¡Çæ“HKP9FƒÐ,ûq*PV¶“\!€É#ÐÂS‹=5!•uü¥P-¬á}÷â \aA(‘éàEBwE|Ñr•Ã±ÁŒXÜü+@œB R© mG\Jl`ïñ*> Å!Åž@–U\gWœY4üó]],˜`,ƒbl dlÆp!B¡Æ*ÀÆnLU6ô sL;`\¸Ð%¡Ç|ÜE 3Ï7È·Pȇ¼žŠ,ŒüŽl,ÉâÔS—|3š§ œVAõÉ’¡™ `tqpõpœˆÒhS2Å]Ýa¥&¯iáf("·Ð^s1-—΄$W•!»“ª67¦gõ]„.TÚE<¹>¼^ŽP²¬A4ѵG4áÊñňþßYWA@à±ÚŽ Ê€ ÔÒ‹¤°¥¸Ð&^(3¤°x7¢2>¡«Šq„Yå•%¶) 1FP7•òY"sB×Ð0ã‚8@ð£8Äöm,’‘M`~È0îô9ç‘ ·áYNK1ð‹XBGœsH0‡" §äO±±€ •Z'mD2@tK¦›å} á!ã ‘‘/1ý€Læa( u.!ˈ³J&† $ô­{µ“åí}>q•Qh¥: ¼„”Â?c Åò:d²ˆúÝe“BîàØ!XDmJƒ+aT+wÞôPÄa²4Ñxõð±‘ޜЂµìS,p -0çÄÉÛn6Ôµïªo¤{Í ,ûþðÌ$õ¶7GRfõ»±ÍO U…]#“pÞ@TËmRM @)ŒGly#bGt¦"Fd/Ô*K/‚v „pñˆ°óˆ…f4Pî•@tq/ Šë\Ïí£N¾J±ÀÁÉ?ˆîW7r¦kQÄÀT?ùÒ*0üÓ‹ü32°¹ŒFý¹™±çÞt$ÆÝŠC²¿½Ôe…iË!‘ß0näö2ê@_òK1j”¬FyÖE@j)à á3Ñ™­nÑq}-Àz§2œð^Uã˜3ŒBGü'Íg@-˜f(p.¼X27W¿ 1W€PT¤þ!¡â"!á±!â#ÑÒq±!éÓÒqTÔQR¢¢ñ£R!"â!âãºÂBSSórã*òòò©Ø±8ä##ssƒ(Q´8irc“,]M]SããC$Säë1®¢‚Ô´­®î‘Tƒä±Ù.ƒ¸Ù” 3î³é‰ ã<øÐ`Ѓ#…JáAÈ\‹ &É5dˆ»4tèðaÁF+þ…hTqž¡$&C|hQN‰’#>*¢„ MH™Y"HEz”𨆑m*x8UÂc„cH“ÈÔ”ÇÌ'Ox”X5óŽ±Gœa1¤…Œm!¾ù Y3Á‡þ®BQêÁ„ Ž&*åk‘ >*Ž”ë€øƒŠ ÖþðÁ©9pk‹Àì[Èï¶rqvbˆ3‚5I$ jÔ¨"…Diº°ƒ$)'C ¬c0bEH@Ì2eA˜9kÍZµiײmëö-\‚åÎ¥[‡”ô·xóBÔ»çZ?Ž4ˆà†FœøÙ"F58z9oÛH %ó9ÂJ-½ÓL5Ý”ÓN=ýtDPCuTRKä”VQMµ–mW‘ÕV]}¥BXcáPg¥µÖ?nÁõ\t‰`W xéÅ—_'&X"„¦b5-ÖX(rEÆÃdTYVÎ"˜Âþ™gÎ@"Ú"¤™†ZªÀšk°É¶‰µÝ¦Bn†x)Co ü&%#Â%$žÉð‚ ÌÉyƒUÞcL-5ÀÖ–6® ±Â ÚÂ,'M—Q;Ñâ ˆdW>'!B©F—©`L䨠©AE|pHAHÝàhqCˆ°„~îÑèZ›@òª#—HREå”C‰˜Žr„XMtÀC¯VâÔB¯½’ ¥AQ³%tPMT(„ AôtS)N‘DV†u½®pƒÝy§Í–%€Ð"—áXÔMˆ eHw¯Aɧ‹ü@%C&ÐìP‚©¼%Œ#Z4Aâf§m%=|þk%$À«õ2O0´ðAM Ò].Ÿ€Á@³ ãCF2q<¹HÉ"ˆ@„6>ì¹"7ÀÐ IÔìh/¯¬UУôtÌ+êxeœypkÕK,Á~Jæ[P!-`­B}UÍ*Ù>·†LOÞ!„+nµæ´$®¬ÕW|dÓm 7©ÐCÓ"f´!V°p…-‡f«æÕJý b%bNa壯y¹"ªƒ¬ã¨• ¨`*NO”€D¥·ª`#ÀÚ`·"I @Àá“*­W%T²U?ïùª"0çÎ;IP±(u‰+\*ÂBq…²§l¹€°–þ$3%cç‰?I‡Ý13ˆ—7”Fi8µxIo>»•*©0®Ã*º}ãiÿ¡ËžÜwrä§'Û#Û!8å25•-I0]¾ìAê¨ÀKô Ê¿Ê! h!Éײ3ºb•År<˜^z2“&«,?Â)J Vhx*TUðfZ-PbäE?ð€ZðÎlâCøc°â·›Tˆ‚XA`B9Å™¦3JrÄ&Rä7Tª%Aœò˜lC|«Ú?``›MT”’D¡‘€%22=˜€—(R‰ï# M-XÀÄ"QÉÊaŸ„ ÿ(šþ~<“ ·|ŽTß°M2J¹«¨Œn¥ÚÓ=âÖ!ÂA‰Aã†Í.©‚f¡‚rÜC(w:ŒFè8 Ö A)#P%Šà+tô Êñ*Žp9B^~5 Å­K uF#Œ]LÚP.)âTm° ¹p”gÌ:TØ ´ðŽyç–G•Á«H)å'ti]cä2€ÝÈôÌDÀ%Œ(DABç¨ÂD4iå/ –þI„ÌÂ\Å«SŠP³¼Ex‰ ‹,;sñ)<ö0ëóƒmàD>,쮉1wa­. i¥Â„”Œ„r8ÄdOÖaŠˆ?”0e¶m žÓ;¯%µÈ ˆˆ03wârrê%>r Ô,XøQ Ô6zðeaö«Fh¹€Ÿ¢èxð´äE,A !$,ð™ì–‹»Ùù.gÂëƒñZÕf¥äïP×Û^pØL"ˆ/{ç›”úÆï$†Èo8øëßøeþ…)N ~6dðàžJ¸Ò(A†Uô3‰ S“iÆTkâƒS&>qŠ}°þâ—ãU*ˆñ$f¼…h3Lf§˜Ùh6VÖÜfo¼YqžóEëì\<#AÏ:ÁAŸýh)ÕF³,ïyáôVÝlÛÑÁÍ^­ W× Ù8ækÕ§£§ìe/™NÂTªÏ, BÈò'WÞ£u HnB·½Cb+#  @À_jdC¦¶ð1–¡Ÿ… ½D‰e c£=Ö22‘ áN36]Šà’’ ɘ=³Á»ÈˆßÈ•£+u‚¥†$_×Ni±…ƒÀtZSÊþ=†ý2Ø°¸ lò©“qÓ&(æ<6F^uoÌKŽ`ØŒ… MøAcÈñãˆì‘›,ñXc!Á^õˆED! =;6ˆ ÷Õà"ÇxÑø&ÿ®C+š7|Qòžá:KvA‹4êfÆj¢£S&WQÊKfMFÜÜÒP^:#LuzÒ>¨A„tCN6iÄø3R!PÃslÝ\]àí"k-¢é 02°?à> GPÞa5' 6°ÐÒSºR ±zÍB «DÁÓBÀÒ+òoŸ”jÌ!\£;é€ ¿0?Íö7«pCÐ99[“À!þ!D‚0F´ÒÒO…Ñ+cÑ% 836ºE[EÀ1íaR‰Q,8LHH Ç“ë ¯ÑS¡d4GJoâ¿!¯±åE êgßE±'Ô_±+Ð(7ðTÑ]ÞWÜÃ^7{¸ ÖKãGIò4@É°^>ð ÿs=*éU¯ð‡‚|Ú3f3 ƒ×8¥`b®!©"¿ ~wÒ["WJEGB /0bGÂ)2Q%3a!pNçºC‚P®@¢Ñ ›00çJò?6u&¹QYƒU*-r/Θ~S!ˆÓ+‚Ó+=Â$f½#ðþ,ƒ„$SQ£Õ~£ ’LàN°+4Ñ+sØ5@oS?­ä'>°t>e'F0“'Û`0§¤?ãjfE4wÒQñ7?aƒICðd'£r=$^*CAC7,0~BPvãð ¯#ìgPŸÀHp „ G“uò }ø 'q7 …Â]!ôê€lGðÒQÓÀ… àdÃ;ã“ÀÚ® r0]çÊ%/%¢w”… ™SÌ ; 6à#B®B“P L¹L0@t¬"=~[/Öb†±ä”5X ±ceÑŽKDÙøBȈ׬þ0¸°±ºJ@P ™P°9% ¢S5à&×G¹P3„å“éUHÇ_»÷¢Iê×S,I@“!°sˆ x Åà“ÿ¡’OW5ã°'K1KAð‘ä9ÀI*`8^…U‰îRȈá’ìÇ…è}GÖr4d"ID—jÿÐ 2Õ }b É0!1` 1© Ô`BS^ËBfÐ_óP @6ÓâM`ø=àWM`oÐxP1# ‹”W‚µ -p: ý"„/iF€$à †¨ ÇP?0^B=0$$3 ™IÐ~æÓýÓRX+@þ[W 4YMpg¤€„+0—N1êpã4= ™›Ã@ (%3à›Y*♥”GÛ š¤é ,á>© ª¹š5КU ›F ›C³¡‘~Ĺé(»éS7ŽœWEœp2‡Çi.Éy ËÍéÏi’A ¬Ræpù’î3v ê*ß9 ´p3ÃQžCpžéé}ìéž&§EòùD`ŸÖ•ŸŸђZÚ,Ú#š ± .ã jÌÂ:eš¡Õ@ú¡!:¢%ƒyÛp¢)j>,ê6/£äD£1t£‚:Š <ê£å¤BJ™wV¤GšjJê>õ¨þ5u<rŒåÂhÝõ¤çõ ,'S6£~̇>Æ S›Q(ˆO€W‰&”"]’6ÁÐ?:•Â'óó"+)Œâ÷¹=» 'ÜA r§QEò³d@ƒ‚ô‚C‡7Д¹ ¡:Jðo¥^r,@¯¸XNÑ Pij!J7d•‚ÐÐZ¹WEÐ? Á;»³—Ç=&³Y–„QC„3£¸¨^$'=R%bÛC2d @ RÆ&E”/…#¯¥8eq•@I˜Â㌠\£ª8N¸:*@’Ø{î#4Ë”nÄt†RgSÌþ×{— Â÷šå%|ûµ°,ÁKd“¸ñó@6Š ®0^JÕ¦“p(B *ºÁ­`0ýCˆVE‚…°R»QàdZ½ç/Yuø‘qaé°%—aIÉÐS1dó抔*iàñ3’ YFÔ“ê@MØ 5¡²Èvy414À~"v³ ðO³0ÜdD7qž¼"8p·R,‚3@*iQ,“,ˆ\$X'¦w—7g<ð½E²¶sé§%;Bø„z1ˆ!8³™

w2‚,§2èM|²A³jÇÁJÕ<Æ´¢–¦À_ÅQO×þ}˜$@ÐÇ 4V`Úù4’?4ç†0K„±0À¥Q’#'!XźóªM†3qx³é¥_ÇP !zŸh[·‹{dy>Â1[¹˜ÓРq‰Aû#Ž2Ò ‚5'l† îÈ+4q1}Ü"]6o·Â[&,ƒ³-ýÖDx:%ÒBwñe$2"á‚$@ž•¦,ȸÝEqï "›à=Ê·ÃÝeäô»g´²–Ã=Ñ¡Áùò½Pq*x@q#?D>î³àP3·›P&zecq‡À¤R‰˜äVÔȶ[BdŸ˜Ô¡ŽÏ*l4°Ì·7ˆl /þR7ðY‚pPD‰03]¸”"Ô &ELjApÐÓ ?ZOr–ÓÚPT =ð0#ß$˜ !2J0‹ [ = j¦ð-»ˆN8ÊyQ¤ì•'6Y£/±]2‚ƒP°L`?SråÂË䪷Ý'kH>ÛUS÷csXJ {683g8daÛ(G3XtaÔvû°qU±r3³¨3Ó&Ηž ~l2¤rα“ð¨’qÓSr Uƒ„ ëvßóó&1šñ w-Ž'¨Fó}~bW†q ›GZe]ñƒÇ“m0E‹|6°ç2E þ°Cð€¤;-pÄ$sZ·± O7Û½€Ü”0Ü”$ï7´ÅV˜'óŠÜ„gò?xg m,:Q2ÿ£$ôƒÅÊÉËõq†)âÜOÝobwÔm5@sÝ·±Û½rÞÍÖ†°…ã ”aÞ­£ÁÛj'Ýž^ÂLÚßdKôM3ߊß'§ßü}Z¹‘4[ ÃYR‚ÊÐ « > p3L5lU³pá>¥~Ž˜rõ_>Ù"Nlà;UŠ€¼(Žµ-.äãiaZ DGÛ°8ÎY&f<îã}äÌ äq 6a9†ÕlJÎL¾ÚÄë\@ÙRÎþ•Æ‚Ê©|4×­kx^ð0?+gqž’_ høÁã =·?D q3Gó U‰Ó1ä¥,H±ØäI»p|‡Á¿ éŠ0\Â!ÌaWFà‚mB¡Ó#ð¡!ó™ lõ(YC*=+ô²]§U7>”ñSð„­! ± @ó 60ets ˜ò“ zD Ò?:5!z-@4¶î²1À>¦]µ§àW¥Ðn‚ðìG–1B‹À|Û2XñO¦yW"vÆ™hô1A¢c‘ T./L@™ÒEïäº'>µ‘ä=Jßå|ö³_?sØï ¤vu:Úþi4—û jÏOW4Ê ~ KöYV3æÇX¸ä…újÎ1…'þtÌ2ÀY°ð 'røÇؘ+Çã ¤¢ ½€ ó:]‘PËé~ñSži×”}²ÞÓa4\ ñ ®@'ÓÐó~óÑ…¾“ó-°dk412@ˆê )®ª(@ôÝŽ‡àâWF{FÓáðzn»â8TýP‘õßT|ÜÚØB ´ÓcgÂKç«9i÷ J«ùS\(i 227I5>>A5A25"*’"AAH++5H">’‚7–A£ž£>!5‚I«D!² ˆHþH5"/Š‰¬D¼¬I¬2A>‚‚¿!"Å—E+A?**?B*#HÓÈ"6D—Ó»‹ *,ƒ*“Ý0200†¯!>"Cóó“Hƒ7þ‹C†tèðAÄFŒêMzA„‘ˆ‡õ|°hdÃÆC’6@h¡d`‘Žð(RäÈ$óÕaE#JÐàïÆ-Ùù ÄŸK*Š´àØaÈŠ}9$áÃICÖ !ÙAÈK–`R‚ª’#?„lR„Lj>$¨háôC<â1ÂÏ2" küªÁ01#‚à5d‰˜¡cXÝXZX’$yÝ‚˜¬AáH•XÆ¡Ä5þ–ùHl$#—±ú|èb#{¾˜J”Q‘†g Í~Pò!m$ Óž²RqhÅ "•H9Xc’Œ7 ÖüŨÆw€£Ž:프š7^Ê:pDu/ü©ZÅê°gª% Ñ <#´¨¤¿’ z%Â+¯á&I`±ÅEö 2Þ >¬5Í:ÜôCeE8õMRxýRD”o;} Bý!xD&uÐÑNL˜T‚>AÌS $”Ð K2`ÈÀ`Éh2ütd#¥±_uD|&u«„xØg†ÈFT6Ow‰ rHÓ0sYh{V‰v˜"£½æ Xæþ•s5b$^0À'Á.5¨ÀŒ /Ì•\WE”@œiµ°Â‰–|°Hb‚Î@Ä EŽbÇú QŠÐœ-ˆâ!ITWC@dòô£r‹&•adD'"$‘Ä"—Êbšiv ÒjH`u¤Á†Qú£ƒ2„PÖÊ8)‡]ER ñÃP…ôA ˜$A¸G—”z/Á<#c<׊,šôUMàÀDuT<4Q‚%¨ÒKo‰tdª5À“DCkgÚ;0¨F̘ŠÌåsȼ&Ë õcI<…!‹‘ð`‹âHi‚ ’Ð*sš6& „¤ù&+vÁÐÉ1ôþÑvo²òƒDŽ*Ì#‚-Œ7ÄH|PB\VICŒD F:$B Edð‚ 3Ì`›Ëˆ@Ä /€ _€ãÉ%AÄ@ †ÂÂn)Ñ FZhÌsƒÉˆcÈ7˶äÏP¤JÈ_$²Á°àO#áÈp7ðeÈv„xàTMá?C|%#·= d?Áà $™EÕºìò Ã4úñ7P+Q‚%òüí“ÒYJð?Ä5BL ©1 ; qšªp]±¨#’±]§"ä²!‡œ8ÉŠœ\Êv+w¾>žËÍ{†ÎÓNœ’ôŽŸ5«6ÚþŠ&ƒ£©EiLsÔ¤F5«Y"kEØÚ;&õ°‰lf»Ú^Å6·­¢PŒÅÑì†7—éo*ð›æ7¸eëp!Sœ=lÐ8ëÜr-œ‹(g9ÌiŽ9û‰D÷Ò™NR©[Ý Zw„×µ ±#íl‡»gín]qù ‚ç¢áïxAH혧çzÒ£žõ°§=K Â7ˆÂ‚0…—Ý;Œ Bvó °Àl ŸüCh¬C‡‘ÀC|Pˆ¡ j1rc„tЦ´£e,Ø zÚ#ˆÒ¦'=ù…>šcÇfÕà\2X`Sºã™¡ç#âÖH…ËÄ… ÝhÅS2þád€þ¨ÎúÑ)ÀÃ0mZ `ð2 $ÉÂ(Â#,!‚ÊÃ3A`Fb~&·ØÔ l6@fZ˜–ËläŠÈP,LU¤"jT „ð»nù“»bì²È;Ћ øŠg†>2’þÌ«ãÁH€Ð³Èh(‚!Áv„'øˆ?¿ìL"ƒþ¸ˆ¢øbH€ƒØq0·0M!’ðLëÜÊ%»Ž D„ø”I–XÊh–ˆÍ%ƒ™¢ È<ªs$Dê!¯M?†ä2Áè 6lÅ®²Y‚èj)8«‰4k âœ@BGL*–vÂS(`+BŽ†€­apgÙ¸NËŽ´þ9õ­i=§q^Lf?gàÁÑábd’‡ ®,1Š]8óÕ€0§´ ¤KÀ-R……r2 Uʨ„ÜÅ 8ÀÂdÔŸxA_‰W¼<Ï0A%­HxЭß‹XLn17â‘™%ÂÆJÔæñø1M©Ú• Í,- Œ–ZA{‘án ærŒRê)I¨ 3‚… “µ"4ˆ¬E)´Ôˆz¨…F‚;;$`( èŠ"Ü• L¹ ÉA·Ô¦‘äxIˆŸf" úTîg‡Í€ºTRx¢²a`²EYþR!c¬LnXÐ3’‚ÿ–ĸJ ˆkI`d¢¤a³ų9Ï&`B1œ¢àŃèå6`ðš]˜ðO%¨@EþlÑ”ÀZ¶M‘#EÑN°ˆ ¸øEˆoI°F´ ¯I@y{¡ìÔ÷aQ²£!tõš$)b¼ÈÐ]p¡—KឥaSbò24½¨‚|œ“›ùLƒS„Ä©3rJi®™¡…À(.Ág’%€ÄŸŠ‚î?ãr;OLè„>p 6E¡4g9ô<`x""o+§z| b‰rëd†?hС;ž,‘Þ‹ižé™Z¬§HÈfœÙ§þ´®CÑ%<’%ä’$Ô‚~¾å"°\+ƒ(AŠˆ§„”â ·&YWDs{„~¥ˆ8Xr<=’dè³yF2HT]Å‚ßžõ@ªT Ÿ‚J²#·N} ±^¦z“„VD{,±¥E”bÔ!´$â$NQ1z€a4¨T•RøØ»ÚÉkLF "¸bC[S‚9Å–R‹X^;§LÜÛX‡€è£ºnF;-¾iÁ€&’‹ÃÈ­† ÎÐ$À]™L"„ žšŒ-3¨lÏjD1±_ä}œ ÊG¦±@]%á³kÁ¸♉Úuø€€SFÔa‘”1ž &GŒ×[áþk¤ðzB—•[É®Š7iP<Í'€*ã’Àþ*‡Ð’jèÚ%0)á+Ϩá]ÓOóD0‚æ2»y€Š‘˜;Â!5øù|³_àû´Å=Ò£ú3€ß霉º,¦¾]^]—Ýép×3:ÿ¯‹Cì&;%|'µHBítçn÷l£‘OsWw»²byG |—þðw¤p8‚w]’ ¹0 Žx$qe[ãxa”Cy+`yN‘y›—xàyý’x.e £'pÑczM€z< zýÑz¢e2ƒþ²ƒµ÷-¸—º7 ÆðYÿ|$ŽWs’cIW'«!|òq%£þvéÆ>Ðd>ò$R5_›ãG# `2•1tëñ ‡aJ§¤6ØÔ f%/v ¾‚vQ÷¢% l‰‡pR&ª2h>°ž i×%îq+ë1 ŒÈb 0`Hp~,pO Í‚àCÀ ¤°€f§Ii’ ;±—²B±otueqÕ #Mf" y’rfP(F`KM=peÑ0¦÷\]F_ñK_!/Úó C€T1;f-¥Wñ&ø 0€o `¾p Qƒ8Œv v'H2·>ž‘+%ã|ƒ_c¢%h¥j ’,€%‡P8ˆfSóhÏ÷S‹þÐX1)a !Mš5 ~ƒ‹#*LÃ4q¨ÃP!WÆvËÆm" „V ŒpÈfUð0pª0#Ö L# 7GO!ƒ):E‚Wè]zu ÏvæÐ,A´*QD’¤‘B ÃpEÕ-Ã¥—£Ý20#ð(ðÒuo-0Æ“!0\¿•PLã"ø²zÐêBfJpa¶µ$‘9>F ¯–š—yVFZþ€{D„¡hš1)É9!p4ˆóh>¥8þX.v{á6Ù…)ÙTj§a>˜*ÁÂ6ŒöMmw%ÚUë¡Ì€œõ@P¢p9O^ìþº…ŸôlîÁ>Cuf'µB€’”ÒÓPTQ8Q+Q€RÇ}Äó@L¢! ¿p(’• ’)I¢D³GÅÆl±–S¹‡ßÂÓÐÄ£q15õÒÄÃ4WÔ"µå/N)p/·Çk<Ða< oWƺbŽ+. uÀ6â†iWx…á2z%Í`3&5'˜ˆ'ÆÀ 8d™U Qb~ò – » 1ÚÆ}-Ç6Ká à0 3 ЉÌá’îødró0*‚R`á¡åD>B— ~Á hã‘ô±ˆˆÀZè os›ó@A"®„ÿþ+Ú þc>?¡4ádn‡4!v„5-P–À4‚¢+E@qÕ „žCWî$5s–$±sMŠ-ð$§üR-B= )²–NYÂOiª¸Ã§"ña¡V`q ¦`‡¡•"•'ñ`8•‹•$­ôÂBsDÀ*G²W…q -³+Yõð6¡á?•s—à÷‘8Ì×±„‡–ÀrSr -Z0W_Íé3ˆ@*A¤8ôÄ º ‹°N]"à£AS i?¡Y~ayҬщq4å3–!.Ù’°‘=• ±¬(d7þšngêÜpE×âU§3Ùô§'˜QùÀ×ø% Hq*`k¢\ñ(Ó Š„rÅ-ñ.ý†PèI³Ó\´l¬%#22Xu¹Ÿ™*g•*Ì`Æj BBÅ »2€é7Îç&Íø—ëá‰F Ò*tNÇ  Ð©Æ°SMdŽ‡ƒ AB;+J’Žå3.{r=¥i„PV„Y’„@ !pZWR+à+ž¬tâšÐ&&Q15 ëD3?3”À·Ð kA ÝäXôü€žl«:ÏNÆ·*œ¸;6‘'”W4ICHèé<Ÿ²CÁY.È~#*rF°þÑG;0Xѱ‚-˜xAÁ#bÑ"!±k$ÐN?ˆ¢²ÇÁ²ƒà²‡³BIöZ³7+: }’é³H´'*‰£hZÒ}GÛJJ±´ºpZò´@²òJµ…á|W›µá°µÐµQñµ|¶ôD¶®f g{)ÙiªÐ¶ññ¶Z3s[·‹Ã·{!Ø€k2‚+M4®'ƒ¸ó™ :Cà¸ð¹ñ–4“+•›—›¹ð†¹±Ó¹M“¯º50º¿Zºð„ºªËºjÊ ‹»í-´K,²ƒ»Í%/¼ë»$QŒÐ¢¿9Ž‚& ’…`ƒÐ1Ÿ ›‚ Ç`þ¨ètõh„ &‚dJÇ€‹`ÙgiÄ0¢ôZ8œ Sƒ@(÷T—-Ó õ4kl‚ð3PzäÅ3 ‰¯* œs¿;q 2t7öÀ¶c27-Ö c|Ìà316 ?£`†+QAvzQV`¢’Å€ˆae¸ñA€Ló% @þ6BiI,ThZ¹¬.Lù-Ø Q.YÄkeQ DKSº• IÐ=§ÓâO™”XD<¿E![åò£Ù°<ò‡6PI­¦+UÉ Y7°K $Å ‘[ÜݼŽš—Æ`þ3A »þbK +¨R½È_N/`Gÿ#¸a·rèåC—"7sqð®‘8æxÏÖMMú6²úø€Ç†Ð‰äˆà4Ç\÷ ÷‘6„,ù ú°š¢ð^· 0)r¿ùâÑ%i(«t¹Sƒ6ls$Ó`ÐæÅ4h-ûZö0ç`0IW”-™<â/P ñ–ŒM ;¾ä[€î6<&ÂÅ# Lð¹D,Ø Nq)Fàx¶%7>9‡rN‡ÓXÐO7KpéŒTŒG!7èÅ %²P6°Gx) ¿àû¼%`˜&Ýiþï»BˆÑnç'9’t _µÔ %Ù±bÂ5L¢'ÌÁÁ'xìæ–têCtR¥ª0$DÕ,Ÿ† wÊz23¦wKAÖ¨O«É9òâŒ5-¶Îà™×l¡Pl±qNÙ$„ܹfÜ’Qr5 ñ5É؃Šâ”_ýÈ´Py&qË4iC*= ¶–L0! éæb"#†ü 3ÌAsïH}±Bàtÿ@`’°vWK Y+÷â(­·· ášz¬0Å*V|ÿ0bò&Ï7¿¨«…À m·äÊÏÔM‡`¢Œ¸~IþÏøõR.3±:4Ì ;'lB›Yü)ˆð3bhv?s‘47ô± ÓÙ%Š àÝë—yð"»€*T콂AÁªó;²Ø0.àòYWÓ($¡mÚ]‘- —2":¨®ì¿Mà^7°P&!ß’/í¢¶ØZEèé;Ü­><•8ˆrC ­”*€×͆žY¯.¶Á(0žÅªÊm”I$$î…}™åð€í³&ý7«§Ò½àpìN¤,~ñ6§&1û“’I¾ k3ÖÑ ±Êæ`v¼`0•u‘”°´õˆ¬ùkc{'0=•@Î:…í›üDþg OX„ÖqqåÑùÀ‡`#s‘-cO†þ"EqñÄèŒî"àb-`v¾rEòí/ký4Osúéx` I°ósáóuôA0ô  ~’ô |Î?ÇáôPß2R^‹Põö„õ¨ÂMYÂõ9î_ïa/ÅyR ~3sª‚öðP$ñÀ&›áö¨ʯ1÷uïåxŸ€PãSCXèRrx(¡"BôrCITs#”(#S"¢X£yä¤Øâ!äÓIDôÚy㪨rt’!A)cããÑÒ2Â)ûzêññQ$ÜÝCBÒÑRT”P}íá!1-ÞòáãstTbdþäQÄüÝQ¤¤T¢ÔqÔ14TÄsîßAI‚#d´õ(D‹Íö©ðÐãG§ ™’L$"ã)ŠK4Qüu#‰È$AX$Q„ B(Ñ$D†$ê2ùÒQÓ #$=R ™ä¦Åž“(Y씤F§¥5Ddòˆ$HO˜Œ ÝäsPÒO ˆô¬´õÆ+*ù!hÒ›å< ‚„¡C„•“ —”Ð$0`$$¢¢D©fª@"H`N”nhq‘ˆÀ‹¸yò"c\n•ÊxAħ%$8Fä;2°¢ q˜àâNƒ[œC7°Å´- ”ð­Ãa-ôAƒÖBŪîþcø¡×zÜëw\É=GH0)¢"¼,|LF;ïáI@QÑɵÒR"35v,#Iã$K’”(¡Øw(¨4D &1&$‰´S)ÜHE‰Z2QEŽQ¤&7döQ&KyâÉMêPTƒOqƒ GÕ•TX…!FìdÈ&ƒhr IHØ` –l,IЊxy@ ! Ì%H²WždVŽ"6Ò¢B¡å™‰±P¢XbŠ™§!/¤bâUiŠ'Í— 4‘#pS;ð0„\;ÝäJ !T‚Q&! ”@ Á…Ä‘Aè^×ÜÓd> 12´Ó‚<ÐþLÄ0ûð œ5„猇W48PÓC XÀ‰"D¦RC8›âA,Dì„É1—À苯Ð@ƒ/A4Ð@PC4Cà°‚90Û E}aUV…&RZAÄ"BXõÙR~áYF ND‘HtÚ¯êT9RRNŠåÕ+yÈ.!šÈ`Ĕ⠔žlå”L-B ë5J /FÊiA¦HdP’"ßþŠ‘,Üø ›¡LöHºFøtC²°è‰S0dâ"Hôp­2*Š0„GÉÜK ú)oH&ÓC>\Ï©¹1‚‘×<÷N'ÌhRDwðì£xaogþШ wL!C7ÿ•ðƒ&ƒYÃ<"•CDZºDc¢@D°€.%°À4ƒèGеÁ•?ÀÄÓV°‚N‡× Î5VP%eHà*àÁÒ't8ð)Zt¹ äV*µ¥ ÊÈaˆ€qŽB^ò×À݇]ý¹Á¤b•ŒÃ÷ñ Šv‚„ÊiïK %¹”×y¶­’õÁ9e@¸H 2š`°"°>aþÄÃ"xHŸ’Éáª%·S®§ÑêuˆœmdÊ‚ÇDÌã”ü-"x.l«-<#Úâ–•Ž)Gf¼„Px–¬c 4Ò£#oˆXE¼A2“ ðÅ<ªÁP©äCØÔÎ=ÎÞM$&zS¾Á¥6° PUÖíAÙšB†ÁAN ØQ!ŒêÜPÛ~€'Ú’d2Ô&¦¡}@àôX„ÒÔY¸¨Bú%6@@0TI sÓðaTÃiE aóаVLèvÐð£¥D¤§¢ÿQLp…à9ÈB4ÕsFc,Co”0$`ƒ6˜ÀP ŠvQCó·=ö A0[a!9fV(ÜÓ.ÅÕhFÐ[ad9ö"b!˜ná0eÁPn§UÕ32 S”!êp<¼…€LG¾C H *æ4 ®þÖ*ÑPAOQ=,Ð]·#C@ ÆbhH0,FøBrRT¿²8‰vuWAp'>r 8 3’"=`æg5_qt* K? kô hJP6Ìp*ËT’6*ŒÚ”(=0KAHбH‚¨m§ãÔO¦–Ced®KPc-À&À pƒßhƒ9€`E6re!è²{E”HûaH±X ã=q:áÃ(Q¤"ê@4”ЗðBxZsÖD¦Æ%2!†› wÊðFF I™ ªh,Ówgu” "&sÝs€á @“¡ Ôñ¨þÖdh„0@JÀLD¥@2÷ D@M“!1Qä$Ô¡  rhÑD«D>r%WÆt¬@UÀåh,Ö¥50GÔEáph  —H!0<0IvEÁ"× †FhŒñPV%0% Á˜*!v×ÐvÐhŠH—`}“ÛØàøâ¸ähŽ)ÒV`´ŽFÑŽ§!ECöè$ø˜úhmýH4‹!2!?v)CgY"š#?ÜÒŠ‘> ‘ÛÒt¤épŠ™- ù #)%Y'™’+Ù’f“Ç0“"P“èr“E“;ùþ=!âtdA)”À`hèb”€”J¹cÈÔNù P)•@,Ðu•Y¹•ïÑ•8ð•ay0¼X–,p–Á¨–lé–p)—tM%¸Q^•m{“Ž1[„Üh ‚yƒ)`hçhbt”ð‚G„"±¡ìˆn±;''QÑIØi#±]vd¨Š63 â £E}L”?¥ÀæÑ‘á>þ²\2Ú hqHðNr†—FW}Ò{  ‡q“ó2Àx¢27h¡p¿ò7½Ù'o2‘<'”¯0Èé}7àICà} ñ0R‡u2„£#1/Ð(´U"¯þÙ ûPÖ070òð±†`$¶ ×`Lç@‚@ *PNàmÙG€‰Ç%ÐG0N^Ö¦s,>²û‘ÊŠƒ³¥"`”"'Vñc± %ìFªØ J€&…X¾²ý¶‚RŸ£"}äDF¡õä;3w/§P]¥pœ³+‡@GÌS`R.Ó“‡YÑ ”t< ]pkI}ù'Yð×BPæ ´Ppž˜å…X0€3i±€»‡_0‰Q”&oE?ÐÿGG‹G’å ¾J4ÙwÆé~JòðB ’js]56EàVY>þ ’R7æSaN’’r$°M×p 1Q$™ß²\¥jª¨Z)€`ÜR†.Jao‚˜¡Sm– Š—‰@( ³7A?Ûh^…b!I±úƒ$;aô´Ær†sáw[©`lÑ1s–"s[Ù2¶Á€\óâ ¦Mp]ðOà$O °Æw{·×°LYò*1Kvåâ ±€JòŠ.VÁw– Ðh˜€"š $ÊEH@¹qXyzh>" Ý g‚]Þi(ñG4Á€ Ùà`B°?D)Üñ?yd6À‰¨àmð ŠbA«2s#÷ÐLo§È€þ=ÿÂ#$¿"¡a³Šª:»QQ/ãw±[S„9ëX"£ ÆòJ0 ¢‰ˆ©n( ê Ê00Ú×1œÈÐt—Ù-s4"æqG!YNÛG¥F ‚!ÈB€ÅY‚J þ<À±r•Y‚ZÕz0^»hñ9#s y½UoL"03 ÿQ7iø2Ï[eÆ$KW ©ÿÑU< QAA0iRWó¼\€Ô\ÐüÌ©|w Rb aÐPð`0c°WÀ[ Šd„åp_ž EÑ“FÈ#e úE_ÍPÜ` ØÔNâqJ!°LfwUc=£*ÕD9Hlx"   GˆA¶ÞÀ·ÁÊ0*D롱öpEPe\rÐC"‰pÂÐ ½ÐY¡9e´µ&_”mÑ®ô½Ñ]i r€"%„AÒJ¢pl„JÁ°þÚbÛÒƒýÒ„Ótó·nl"s/â˜eièriÁ&ʽ?°d{x RáˆE0à5¥Ò‡‘½C–‚–"@(WsÂ\¿à]¨9IÐ –<Æ#² U‡±„Ú„ÁðØXD˜ý‘qÄD¡ÒÈP}€¡PÅ…G®@*Ž³ W68)À,ÁËhù5“ëT6 :fó`(ØÝROTm9:2 ž@$’HgH"†”.èé`O²þÂ.È’^hÉ$hÝVì5(h ±^ZÓ,[ Tàæc°ælÕdÿ欬æT`ñþJa0çn~Ôw»D†»Ýc]§—f^—²UþiÀ¹/dj×ðÈ$ ‚fy ¦ž=XJð˜aŠŽÜðAG]rZæ1àNȼ@ ÑÍ ?ºÆ %Qõ/ñ@„ÉÑ@pů Qùp Á 4ÉŽÚ¨ “Ž¸2_§öÖO•0Vq/J‘^ù Ññ€ÅSbo D²my Ña  ´ÍM -pOO]Õaf€çÿÕ°¯æç\ÐþçÀOÕkÞç[ð( 5‰¦šVø«°UìÀØE9«8 ëåíôPSÆVA `ŠªBõ€ÅBɾ-Í…NITij9³dŒÀiÐ0|T… ×`S'171eÇQ)Æ]«A‚‚>5>>A5!2ˆ‚F$ ‘‘”••“9 &&#+¤AK7>** #?E$<%EJJ-?*KCC*A*76Ä7A>!‚B7ÃÄ6Ì6 ,,7D/Œ‚/Õ0FFØ>HH2D5"ƒ¾"*H-EEòçÒ6-ï*µðEBI2*í<á‘¡H E2ŽÙRÂd‹˜-ð¨H$#%L˜-[–pþÙB†L™0T¶xñ" *`0^Ie̘(dÆl¹rL‘&Z¨Í Îl¼xñì íT@h‘რ7’ùpȃ’© y¨¤ÆSE‚¹÷aD°GŽ)ñ¢0ÈÕ`fdƒC‡Ýâ ŒƒxCHI… "$´€ ašžåj„õ°Bˆ ´(3C¢S‚„(Q¢BÈÀLÆ7f€Ÿ2zº$$I*¥H¦Ò™L)TüøáÄC@FŒ8` ª$x‚„ #´"¤È%H†J­ô#>d$I"ˆXg=mÐ bD„ "DòÞ AÌH#A¼É aþ‰ˆCâ¨ðÎ!l à=T^ °Âð¨‚Ä >4„:2¬ð †ð0„KZ Áe” ©Š0‘!Ä+>!cUTÁ,&QF…Gd€!%xàÁ=Ü@zBuÄ eC¸£B1µÀ  0 ÷ÎXÀÜ`ÄPñ‘ÆÌ=ZvO HœâŒ5•Žg5À22h3#!ø% ÇHB,¶žI€L-´ÃÔZGÈ3‚NA„À * @Ph¢™iT7¤öTx2´öZ$±Q2[m”ÜÖ€ªºñæpÂgr[-×ÜsÑ­CuØiwÃxžxþäazͨǞ{w"3_}÷å÷ þˆ„€Eh š ²çƒBxÖ:Zˆ¡†2p胇 ŠH¢‰¥¸…E,vôbŒ3Öxã9îØã Y‘F"©dPà õ ”SRi%–"h™—^ÂC©˜dú`æ h& æZm6 §œC$&Aw.¢§?Èø¹ >J¨¡ˆz¶h£îTB¤L Œ¥ÌŒ«ixPŒ7—DX Un„$’T"€HÈÆ°îæ„ ¿…2Ø 1lÚ ñÃ; °É×_óЄ òÌÅ!f ¾A„35ÞCTÄTqÞ3úáz—ú0Cþ‡ âç*ü2Õ!÷,ÅàD‘„V¬^|‚ü¢Ä_g VbC-H„ER„F(rÅ2†ÁMháÒŠ!ÑTBeTA…sc„a¼0 AELc€a…Lh>¡D A4kC8e„C´ AçºDjßD|yÃ5ËàŒ- ‚ò  ÐxÆbûIÿ@uƒÐ´%2aÄ!"ˆà.†h P h`F( ŠV„(òˆ1‚ð”$x`€ºAàÃÀŵ¦R%èÄ!@âh@ª 0)XâˆHLbxÐBäà%Åþ,±ÿ‚8Â7 Ná§?ãÁøê3„΀>ÅÕ{ˆAC# r‡H„¶²S„+´@DÓY<àƒ0¸¤EPy$•I§@ Ƹ#| k(Gt„½1x! RhÑŠ¶Ð’ì1/ !ÙÀ°£øˆ"Bèˆ.RR„Ý\a8(‚ î„Hà„<ЂP‚&AØ 3h@ƒi=£Xã Áx‚ ôµ`T5LU6 Až ¦˜*Åô܃'båTcÀun€ ø û¤˜ÎU@HÈzp„ÈC Â5&&iÝ€Ú˜ÝâØ(`í XbÊPUýþ²b'ˆè (1€ˆZq èÇ ‚0|Ç>DøÔ! ržÎ'>L“.EŒ'<ˆÀG‡`xÐä8C@_úø¨#ÒAä%_É"(Y.AÅHB#¹À5€! ¦ŒÉõ8’0ð`w i‰Ž\…*”a ' ‰KœçNruLèÂX¶Ðšt¡ M¸Ž¤`‹&@a®3  cè/ Ä iO| Ë_ ¨é;„øøÀQšÒA6>öI±ï1Ä žü„:ˆµAD1F9¤=‡‘6DÀ3€À JtÀ 2 „(ð-(ÏÏ©DØ4ôþ¸ MÁ/UA€t°€$¨í[dyd¤$=#ö󅌔2¿EÎ+ïéNHaE ‡ ƒH7š´à8‚¢’v–=?nÁ `ÐM>°‚ï†=Ê Ê®g+øî‘T(ƒ‹‚$‘ëA ó’h÷;2à‹ ÷ú'Çp…Ú²R&.±¤ŒÀÐ….<©.~M`ÜWž0ŒY5[™~= ü**Ñ<ˆ”˜(¿ñïEè“dŸá•Êµ@äøÉ\B5Y¿È`È‹¹@2!‚!0(4 š¥%ŽÐ,¨Á= §QmâøaBªPäÚù ªàA$(p\ ¡þÂD>ÇCëªÀHª`‘ÓE·Ààñ…Ç›„c†çpìõÂàS0ŒÁ -°Èn²³ AGKà¯K®P0€á (•½’àg<ã‘%¨P#¯†U"œìj…Ãp… ÷ÚD-Òž ?fo Ú£ )ÇÀg»¸ SÀÈLT­"™¼µ <˜€þn@îÔN…øF墈C@ieO)Ö}D ²n  © æ3oà‹$¡|Q¹Ô3±ˆ$À@Jði¯š>â*=Ù1Â#¨F1¨>` xp@™Âª€‡G.  7È=ÃD‹3ãâ3¸¥@Dš‚R«`mþ"´ àáÁäç¦VEæ< I§5cÒ'~Œô¹š” FCÀÀ…+4A‡¸‚Ð@É“ÄDÔc€PÐTÍ«CH%ŠJd"*€’­BõŠ¬ †Ž¨×lg^@“ë1a&÷`56†€É„­¬þ»´ÐI‹X#!‘QdÔ xtàÀñ› ¦k& ˆ%!2ð™1”sÁptÌÿ9Ä Œ7JIÍëàYÍ<ðsÄGJU™’7HûÇúGê€|!f.¦sq Á=8^Ÿ"`)ÂÈ‹ “c å._9,\žç˜Ï<¹6Çù"—)–jÀçŠ"ì:„ÞÑ¢‹ë‰Pþúv-çtWoRê®®úÕ³¾õ®[ìb7dgv=ÁojU%¢a!ÑqçGsWwdpw^U"zÇw(âw€×‚Gx†‡mÅ[°xçx·’GyæryÕy†ƒ œ×žz~SLÌd$ŠP|ΤA©ç«×zCðz:Áí0{µ'·wY<&%»|írÀ×ÂG|Æ·‹‘|ª`(Tíð,``!’@D prÈEE”7Ç•»ÁL •LP!7ÛB”9ªà âP9w˜ ™³-{˜SZô ‰2•$mýu<A“×V@Ÿ†`a{ça-t?þà Cã5BÍ` aXa*AU Æ÷üÐÕP9?æÊ‚n‡à.üs Z²h1ÒLñ€q¾p  ¨`„I† q“OOñ Ћ1@ H°Äw,n4P%P@P#P$@ V$†A”D €}°5J`g •Ôáp¸P!—hˆ$tÀ7™,‡¾°bw™£EeuWUr'àëÃ?9v(-Ð]Ò7Q ]'ÐÍ”(Ôà˜> ™  ª P†9% DÉ9†› ‘‘²…º†Ôá¼ÑCB@þo@ð†š;À“jE‘° ›`Å&€ÐE) Q¢@~®VŒ×ˆ¬f©ä¶*ÐIÛ£³x0b”eu[ )öj=Т¦ÿ¥ŒEv{ EðRðu:®w$V&QŠ#µXÓöi$6ww= mÚFbÕ&j-&®\@/Öª!S…‡wì .æ-öbš;° ù¤,üŽG &d‚’pFÀG€¤òpr ÌöŒ2òPÐðà=ø4ä„ѨA}¢·ðâñd"P:KQ 0À°e °° %0 `¾3þËœ—Ú§°³Èņ¼1N€¿4S D 7’Ê ðKQ" °òã žÖVŦ=ÛÐ6žv0yËiMІ˔pU.¶$–«=àP0_VPq4±&øw¡¡cPŠ2áU(Q‰˜X‹XÕUŠÃ#/ºeÕŠ–‡—)±=ž=LÜVWðpùŒs9úiÄ{G@;0`勺ÔáC±FA°„ÀQÍäAÌDXiñVI0Î!ðꢇ&5pP¬p º1-WW0,–!8p ¹&YÐÈLàÈã{¾`¾þ諾|Š©+[‘ïÀ4'6ôk¿B€¿úÛüÛ¿$ À<<œH€À=ÎÑÀ¤óÅìÌ­ vÁÈÆÛÁ~t ,Â$lÂE€ÂW ÂOÀÂaà¶ÿCÃ[`îÆ`¼æU;\#]E?ÄøRx@ŒFü_.A¬Kì€ôJP<®]0ÅU|ÅY¼Å¯äÅ1±x` ƶe|ÆiŒSlì^oÜqÌ“<@Ç]`Ç`šÇÁ°Ç}¬\1‚LÈ;wÈS”Èj°Èœ¬Ñã»ê;É%¾sŠ©9@A€ì»É E„ ’) QG”ù[©‘€Q•ê†–š§ ,@þo¼%2 ÇÓoÇLÜ\ µÌTbàÅ(º¤£Ÿ11)Ál«Ä0qLÌ:VΣDuS`\Ð[Ru=&J?=mWfÐ<×XÐb°Š ñÅ(F\À4Á÷BhË-âa!JN u W¹3®ppC¡#1`Ð@0i1%àFÄ@CÏ1 íå…¹Eã¥LÖÕJ0®ù÷¢U§ukáeéT”‚\›ŠcPpð}ˆ¬ bàÂÑb '@œ à É}šìûDñ›§gÐ áÆÛGdQÏbÀÜ°@ ÔI©:½³Ò%Îþ!ôv.1W^×(Â#+òKœÖH4qßS¸4±Rº[Ŷ ¶^Pf»•‡§w×m£d<2a<Ì#œQŽ'lÄ##^0MÍTE0J`u^ň^ðHeЊ"îx…m<!¯ÐxWÛúŒÐXmV¤às<¯†Ks‹ÅW ?ÀPÀZ #=ãÑ@P—~Tm$¶x]7Ú I |â@¶HðvËVM°i Ò­b0W< ÑY $I7_sÜçk¾Î]‘ €©:+] u°0NÀÉ|’T²Ðü]¶\ΦX"§(akÇ#Lo+¡þžÄWPx&=1P ÖÓü%<.Ê:º”¦ëlV§/Q#±"“î€÷2>iŒÚv[€fþ½"d?2¬$ÙSV+áx–®#&¾­såbÛªŒR «ÃÊÍ•¨ãGC #ßóV[°WP¼u”í”ð4#Âó¢ÆZ¤Ý±A0yrG²êú Yç æ-‘@´g°sJ ]%ýæ#MÒЧ¼½ à u }þð ¥ÅG² PÁæÜv'±"µ(UaÜÓVmŽ·dàeë•(a‘huLàvçŠUÆÆx[Àwâ,O-þp<%ºŸÁê ¯ |ÖžFòÆFÊF8P–˜jHŸvk=qía‡§m—~â0ÑÞ.Ï#åód ¬ñ*Ȥëبm¹]<0WÔjõ>"—ë pÕ{˜éxE¹Pð*HTÞtÛÇݹ²K» ØIÒZ‘¼ý5O@s°à%ñ”_3wÅK² JZUŸ0QªÎ`Zåó-Q0dЕhBàõñ¶W¡v÷ËpeòÐÖöUÒã—§ÔŠ…·"žUÿ“ܬ¤D:YõuÕ,a&áÞýÅv&âiûù5׌¯õ)‘RÍq=¼CŸÄþîuWàA-Ðz ¤ïÚ¯æjoµ(ª#M€rG¯ìúboµ®è¿ì)ÎT²ž€ðtÀPPX8P¤¦†åÄÄ”Xp¶“sÙ€™™ÓÐéy zIzrbùd¨Z˜21áT²*;K[k»ZZpÕtuud ÀEE5FEF66VDFmvLE]=Æ FÖ’½,TÕ½µ¥¤T$Ľ†<ÖÔ䥲Ö……U6¦•® 32ð–)#SlÛ±t›qIF™+Ķù“­ ™pܺ…)²L²oОl)ÆM .]”ÅÛr¤FjÕÈT9§e ¹gÛ®hÐТË)]ŠJáÒþÌŒ]šìX¶ŒZ,Ëü) Ê–Mž<):ôJ:.dÅbä"ˆ*DŠ9‚$ ¥¥r%0À‰u„ú j€©[†r¸zekdžL ÖE·Öâté1)‚q¬<ªQÓÉ)R„“ •+PÃ`ã¦3›?cÛZ£Ç“"a®ðà¡tH_¨e—RÆ‹¨øÆe 1Lº%Ƹ¨îy¬ê609ým¡Rææ¹cWŒ¡ŒÆmÛ³-A‚œ³òO .<ÈX1¶…nñÇ  C†ƒŒ/G,xÄò1t…P]1õ]>-•y1ô/c}ÑD¤I<þý5ñ'µ°àH`D2I%Œ²` @€,)t¢ãaEÌxËdv)–•b«DrEJ\±äZ0)ÖWq4ÑTÕTUP¡Òm:…A–W`lÑÃKT¡Æt£E¡D Òu¶^”9³¼YÑž€¹• ¥£RG`(^Ë8#XTX!(ELÅM"a´ÌMP¹ý€‰†j™bDFQúr ®ýé!¦ÏˆÄM5¥7Æ8dUðĶG‘ˆÏþ]!H[p££]–*V4Ï5ñEVdp!Vã<ד¥É5ÒÙЂ0ÛXeþÔB•? f’1œà™‰ µ +L S×R™š¡l¬‰cßQx,µ%Oe,k"3Ö6RÐDd =P…§öÆ–BHÖ Ž\ "éøÆÿ€¦³f,Qe¨Ô?œp“•lå9!K².ÌÇ+ÑjÂS ”ó#@g:i!ÄK°Ó9€§*äIO{âsúägüùÏ€Ô›}B¡P†:i6•(\acQŒj”£KHïDR“¥´ÂJás,ïÁT¦Ö²BMËsS¯üg§=­ÆO %TÁ*£¨G%CRM™‚¬i®hŠª/©’‚ø£Z…[W¿šM±–'eþ­*Zu[¶þ'kŠ++Ÿj©ºVá®yE _ûZ>Àöj°O(ìai”ØÅ6ö±ùŒÜINäà²N€(ó‘f HsÅ6+‹ÓÁ+ðì…™Œ±UaJW8õ““ 7Š]¡ñ_?BJ Rñàdlƨ€ÌPƒ,"èÆÄóŸd(ãyU¡Î{¨  áBœÁ(x õ6WØO:ÜÁ0ЃÑèSÄàÁ$%0!¢uê °cpÇ›´QŒa ¶zÊ“Ž.Üã*XcüŒ¡„ÛXÁ fx*H2´Ê~ô£3´PÞL »2£aÂMš@04 H“þÂ4†Ùj  H,Y²N(³_A9ÌàÏÝÓLèÄ2qNLØg8+(‰ ì >ÊW?yñ…hS `‚À@ œjaI쀓/³@øgöÐÉD¼„òhaað‚œb…Œ*LD h€}x°„©@ !a ñAP²âÛ‚n:%Šl©Ï¨ä±T°ŒˆÌ9d!ÔC2U ·ñÀ4ç¨ßIzò›bÔ$qÏ•4bHŒð€ ¾ã†žkÅC6ÖÆýœ&ÅÅÕ&P I–’TZ䉲ABÐP…aò€]Uº ª 3vé(•WŠ²…®L² <(ÂþašX d`ìŽ@'xà‰Î(:\^6ÄB[ À‚\Q³nY¸_²1¦%bÈ:ɤ7M oj<&‚1&T5è8[Æ@_Àæ-ðË ‘1.ˆÀ kðyšA†#ÜÇKX>Æ› ¾Pe¾8܈XÐÖ…(táå:ûˆƒ½’„Í•|]×À4ƒƒhRœ0-éh y¦Ô²œÃƒJNmSàÆtâËòàšjj3Òä„.DÑ:ÒÑ$†úéª SÏŠÁ¢¥—=œ;è‚®"Eñ:±ÑöMwPdA(°c—’I r¡þg÷W)é`L ¦a âñ »âVÑÐ{Õ÷mÍsdàÙ'T¥’s Ù *a `QÄP ûHáÐ ¤ek2×"(h ŠP° "3yaC‹AZäI…[Üh8HðÈ”#c¢”1'MÔ*LSB9HAE”Ëœ1WMJjL/iy5ê”^”)c.Yñ¬À£“ßRÜb%‚VŠ‘¦¸ã&ÏšZX¿õ#„ ‘ÖvþÆ"µÃ‰[”.Q#LM1µÃ"gÜÝCì&4­ ÎÓaJ—®)¼Xñ”ÂÊÌVŒ‹Ø…4Áòí ¹…')Q•P)ºÖt ÑœCU5MÁzÔ7c¤<Ù¼T”¨K+#“Âë€"Óœº¬ì Î/d¾CˆÄ [ô×”²^#p’DA‹8n¬iã3†)ÊT ]‘²5ÅŠ¤©ãž¡AE–”¢àNŠ-EËö. u¢ T‘´ÂJWðpÄIpá\¢XPT´ÓHŠ\%D"ö55ZjŒR\!Z±eÅTBŒ’Ój)¬ÀÈu'ÒP)˜XBVèrÊa5$@BBw"…¨“ÂPEÞþ˜Vž¸ö”^CuøP#d±$V{üDY‚/|《ˆå¤Ým˜ãåI­8 Å%E§ØòTW¬ÀQqÕeM8Ä4ùè@IÊG@¢U×iDæäÉu¨1CJ"¸HɤZéR‰†§vÐ(SAyQÍ(G$#ô‘ÜA”&â<ðŒi‹W*šgÅWƒ´r^6tÕU/hFÐXºÔéL ¾80•XhÐÏ~î´]'»PDÙY]#Ö”¤‰0÷ar ee—†<@ $†Œ\•Z‰DV8O¦Ur$*“¢¤1È¢òRSG˜ê©HT ûp£}sžV3¶ëªVÅÅj«‘þ‰d¬êÈSÐŒ˜Ôr«;Ù E­ccA²ÌT¬BQ@k0é©‚æTPÔg¯YÆKóÜUca#º³ÂdÚ-R 6Ù¼Åî@ñ\¤"P:¨f@õ¤+=sZ\"uªÒ‰*åӌ٤PbÚ¤ädE³D_…¬ìôÏUKyÍÌ8m·Ýë5/ió“X™ž³>;Ô6/1®Ü|]¤81l¡…c¸÷å³ß|ƒòÆÁõLhŒQ†$Ö0s,Shæh”ëÖPàt¼‹@íV é^U¡[¢‘Õ€¨Ú¤Ñ¥Ö©¡n¼îT¨D2†Å½Î«ÊyŒ$sö"B†O$þËIvażҦ¬’eldåe*pét¹ '²FE‡ßxƒ`êªSÄzEúžd….,mU(ƒœäÔžlyå.h°EY43( BjBHA „°AE<ƒj…hAÕ¡ªä4º;¡¡ðF<ˆEÄ2ørÌ°‚ˆQhG²QÒ¨&¯gø]d?þQ‰ìý-K•SÇD^𑹤 x¡“èb¥ÀÎ=« ÷ËF6jV‹.*2…Vàp¡—­€2ºK„¢“œ¼båi²d2+·`íñѵí„wZs† ÅÆj4,d”öÒ±·ÁÃ-¤”`aDŠaAôŠÔþ“<"Ab^ýH#~Ô§Fb!1ሶq›¥„pÀ Z×…¤  G8]^•Ó=¦Ã+‚… ùd.ŒéÄ Ä2-ä¬1L9b¢€,±vJ³ ‹Q‰¬¢j ‚eµ6%GÀÛMôN…ÎONê{‹¨Òë2HÄ|<¼ê†õ"º¡t‰ZcXA^c2Ç(ë­HÎL_aJô¥‹‰ãgÀM\g ˆù†DsZ®( §­8]bК¶²Èê'êØ ’°ˆSÓZ!Ä9CcT­KÅPÖP±’oÚÇ9jÆ<Õs¤"R!8ÆðÄ<è€ØíwüP„X '\!ÎMÀœ+„êªòHžj6K\<*t†èNûtk¬ eƒ(.\S¥µ2 ¯Ð•8¿ÄD;~‚"PäËdŠ+Ë‚ .4Ÿ]xG®élƒBþ&tB(q…¡ÑÄP=ˆÄãÏV"«]H¹ö!çz*t¹m|ÂT d€( ãÛ8Æ!à 00L÷ÃíÁ­òI€g[çPL'rš9ÀÌBšºPZWìK“:ÆcÕê=–Ö§2t¶FÝÅ’Ë°]ÔÔ–JÈX€…6ÀÐÁUÖ0k%,!ñLOv—H}6nÕ ÎÒ”-V äïDr„<«%žGh‡¿æ•Ð) w*†ÀdütúžÎAn0jR{:HuR=cp JX®<Úñ€a<¶8Lì„VD÷”#pÄ€{)'‘ Œþ¸ä2É¥ŸrA…mˆ*ýé@8»´'–®Ûè„k Ö)'Z`8àZj¡g¥#3)Tˆ #|lŸº»Ý°°ˆj;5@6£&H)±Yõ¡D¨x@R êOƒzÕHµª?°jŠºÓ€§eŒ‚ Ìà ˆj$Ü å¹sœ…véDW¿\jEg†À„d^:2Ÿ¥²îÐ2eîÒóxB! ¸ =Ê54-À,¸Bu½üÌ ÞéÀ[áB˜H#d*¦¶ÊGkõÁU»87LŠZØi›šÕ®rur¾Õ-ˆf ƒc¼âž¶xŒ ÷Dþ<à{Å1°êhœâ¥þt 0!ÔºsIÁ‚Åĉjy gA ‹ÓǧÚÐ=´LçÒ)ÍË2©Ñ `…¢'{h ACÍFÐ8Á,à@B€‚“h¡A©L¦i‹-]\ò)à„}šœWÇ3@}WˆÈŒäêØàmß=V M  JGRå®û¾ð€ÿ€H½w¿ žï|ªÐþÂÓ¿ïŸ^uÃ?@€œ$û1&¾¢W3a@ˤ0o¢,xe@Eg2g@¸$uضep1‘K€?KSÎô$ ×!c! 0eeYÄs°=ân£þ‘G}æ@b(ðÆ ]³PÙWvc°B@m;qû$Å0h4B°{¢b: pwôg`Z(q|‡8j]ˆ…€w…ñ‡jª¢&†{Çw –w£† P"ÁÀ4û  Dc@3Ñbö#5¢@ g1aXÚà€wQSÍÄ…Å Qfž`@þh@C4 D`]Á2ƒ¸P°]°ÍbhȧÔ‡!¿ÓT[N뢇„ ¤ Nf6ü‚¼3Cí6†€:°AB :Ài£¶†ðçw÷whxˆÇwêg†Fp~¢&qêWWx wq( þò`>E-x13%ä"Ó DÅ‚}²¾ä 2±(uevYCE¦S#1‡`…E‰Ù€®f@X;JÀ‚gts¶ð =òöÄu”}y €”PZoVPö±îd!ü vU€"É‹½mˆ~ô„§…é'x'jfÈŒ†È(x©“†·~GÇj !ƒÈàÁRhá #Ђ( `«Dø'%m”ÑYðhSѯ âpR˜%@F!@àq3€0Ê;y;]².6!à`£ uIhöqBLµ|vch@JXOÕeþhÆÅ=$©1’(`j¤†×’ñ×~„×’÷~êxñGqWè~„÷Œ÷gx=™‡j(à° ³0àS.N¤ eðyè(f}Â4º;P$tÒL–åkýá'À´”âè_×1´!À(À0ÙJ0ˆ-#d¦@¦;D5ÏðgËW!âÔ#é5ÇgD{ô`H(‚xYZnq°˜€UXxÌ(™'š-¹“~ÇŒíç’h†bq1ùpш…`qü— ywÐ{´ñÁA ” ]ðÒöIxî30a<Àð¨k2•Ž¡¸„€}þÒ@B@,@3@!p{Z *CSe`I”†Öv·˜u+Ô—‰€hZ…—À£dÕ%5q·D"—Ä;ŠŸ!€x‡†, ™ô÷w÷§™ˆ·†”Y“Èh“ùÙ~6i† G7@›ùi(Ð=ÕÂÉ¡µÔkerQ:“91¨ó€X 2gaÑ PÔdf'±Ãp·w‹0bA—Õ Þ¡†"ƒûÄ;¦o$„†‹@BDP#ߧUP H€< t°5>f W0PÀ{¢&j80†f ¦É¨…, qZ†îW¦Zxþ¨ÖŸ.éŒÔ¨]šqošj¨jÐ=®ArzÕ môtXªìØk¢,¤;ãK/€Z X%MZÖ¯xX'/çÆ4Vp,°!0 @ ` ÀG•µ´ÆŽqJÕ °Ur™u²;‘h©%ì¤"©:p){²®V ‹Üæ‹)»{Ùš¬€÷w ™@¦Ÿù¥ê™i™ÙŠŒ=y¦é‡jw†¬– £éiäYîŽ"£Z@. ‘­—™³LHª-h@Òu2ñ¦ãe3ñ›ÝâàQ°’ku€OG àˆTitɤ Æþn|¤Z¼$'ˆ»˜1ðžî¹i»W)Û‹›fxì'™Ëz~˜Y™ñx—{…{'š»~h(†Üº³÷ŸÏºj€j §fxq©¦•£3^I^­ ¢{«`©´¨âhYmt#àv¶š¥Sªh¡HÞEPÀ4•:G¶$k3v{ÚpüºmáéŠUS5f0<¦Å—‚)Èã|)ƪ €‰‹ €¸ZêžUpª–†[(š¤;ºšqÿIxÑêw9€1¦?™­px9‰xÿyjY˜œ&§6†q¥ù(T£5PT "ú숎'a@ÉÑ'Z€L2Á%¼· ¡Áýþ1°¨g:ðXŒÑF9zYBBð+ÕY'oò¨õ°MGú‘Qh¹ƒ1X(ÂÝR#(ûÄGͱÑIþ¾ýл·Ÿ=À»ìÑ`ŠÑŸÌ¨q!³=Ø? j, æ¤íÙ=ð².Æcÿ=ÿ­ÓÊŽþ3€"0æ5=(†³4ð @çkZ¶J¾É¢F;iÛLº`@dͧ"Ê•TY±³ÎœµçvóÔY‡ÀWÀ ³Ï• —ÅŽ¯#)æ [ƒÊõ6Ë‘©A¼XÅ!©²å=غw—ë¿NÞ¥‡­€Ç’,éW´'½†ÿi³—Íc4=æŸÝÙÇîbÿÍŸà>æN¬€,ŸÓ3P‘ð‡j_z:בS+Ê4G§3tIm:Ò µ$¡˜QµÖF–ÏÛº4à/0P'6zšqÄâ$;!Ï"¸QÄtu×°{‰«Æj @þ¿9)ÀOåô—ؽì¹' ì—…÷p \¦6»j.ÍÙ¤mæjŽìÿ-à3?Ú ýÙ>Ú N¬3Ðc>y ¶É®o‚`Sy›ÔÒ”¡¨ ¹Ä3—³ ¹P¼È›Ym±¯8š,Pw1”„PgT6‡yA„ÎW0>nêMŠÄ3X ÕÅ{P Åx¯¾1¶Ÿ^¸¬îǬ¼üñ;ë’-©ñš›åm¨À”Ûå!Ðù£}æÐÎcPà6]ùNÓôßþÀàÙù?A£z€Pf5vTÖAX…61Øv4F%5ÕEx5ص2VÙ±RÖ…6–¸1†"ô þ’BÂñ0T¶Ê˜˜(JAœBQàbÜB\@aœ"”â D¬%ÄüüœS¥^u€’ƒƒ±ž°Ža”óÑŽ!1_o_Ooä¾çåh'/Gˆ"L84Ñ /&øpØðáÃŒ;jä8Â<8á©!FƒÊ@)4fÄ”1ÊÀì0hP#Q—¢$*3ÂæÏž“´´ºDÉe—Ò„pà@W/ ¬`i4ÅR„Œ¢£ ì±mƲ ‰P Y#Àn1ÖV:XPp— ‚ë>¨CwpßwŒ¼ë—cß>„|ðñ‡“¢»‘ãÆ &þLÜÜQG¤Íî!z=R°e”Y»Ä|ý%(+z–Ñtäç˜ReŽLB£¥ÃThÊ”iµ)š.](„HBˆ¨!L=«d×Øh¬@¡ùÕ13[¶=k›"‚1'жTƒßn%(¼Y8  æ¤X?ðfXb8@:ñXöØ:=vA U&<ÔƒgÌ@Zˆ™f‰"š Š&¨Ö™W2Æ«´"Så±¢ÅÏÅÔˆ™ â’Q—tŶiÑEÔu¡".9×ÜLnEvÐ@÷HÂ3XLáÈ]DW 280…XláLYÛ˜IA5ÅþPÀŒ14X€gJ`¡:æ“ >‚ÏõÈsÈóÁ‡4Ѓ Ì°Ùh!šøÑC ‚Úш0 S8P‰Ô4…&>²‚Œ+L“Ï’Êl­ü*T8õÖÊ ç•²‰(¥@q,€,(Dh¼€…e°:Â&¤ ñÀ3[œ§m‘{Ì™)  Yì>ãÌÒ\p@Ð ‘Á¤ìÜS@õH†Îca@Ù¿¡ÓobþZfÙdL6C"x¦D‹H*FeÜ‘=hÒ^ÑE'”â@/hQ½©’B®Z¬°Â¡@aÛpDvà‹/þ8Ûä\"V4gl¬4iqA «ÌDA°€E,Ì°U¨¢dǘ©^šs ‘L2í9ÓÖo9#çº $á„\(L ˜£ Ö(A,ÐÁ ûÙÝÞiÄ‹Ô¨)~:"Æ¢–(ÂÅ ‰Á¦<…qc¢ô3YJäE)# ¢…P Á3Ï¥¬ÐAr¬ ¢’YE—™8v(`ñ* JPÀÊ&`IámêµÙÖWïÅÅ®Í8à ¼Æ¼ûB,nOb.ø¯ƒÙ=Ï` =œÐ¢åafÀhšnx¢>4D⨈côñã¢(Ð0†AŒÁ(8ÄJÇþŠUôÆ Y1]#˜”$)¥bgˆ`ÍV§ºàË<‡ˆ>‚)@áÈ °à¥ Y±É«Œ³ˆ´>é!؈‘<õ@ãÕˆ ⯄3êǃ !#êaz _øÒ 1Ì2’˜g*ª8ä"'*Q—Ñ„qbO‰U&”£`LaP` «¬ ¤.¤l Phëê(¬Rð ÄiN&zC³a5â:ÎÁ³hÂÞ)!8ÈyD)Ðð*÷L/.Ï`Fôè4±Pàl±Pïöñ)ê@ä_÷þ™ò•²oŠ ;(D¬C„ûˆ§r±Âml—*ÚHŠ7þȤr>™NWà#+Xa1Š@'(à —•!9PH‘ê4Ÿˆ"8‹è /†A:Ž³Qû2@I"„Ê\ø•ö¸GyÉ# ôÒà 4LCrá@ú–ˆ¾|¤²0FXP<ÀÜàa˜¡Lß,ó¨` è üø‡Ñô`£éhä>úQ$tTŒ]LœÆpy èhš¾ZÁÐ*qHP`(±IÍB1M%Õ ˆ8–K*a¬ô&WEÚÄ#0µ è€ØÓ„€×ŒnGà)"@p1ã"†×„`®´$ã†HKœ°ÐÐê`ðp‡eö!°u4Æ¡ @¤žÈ—ôþ=è …ˆg0%FŠ€£HˆP)IE p“’”^ÊQØh„T¤Ê¥8–2P¬ð Í´@‰KÔ&W`ª„oZ—$(œç<Îái‘Ù‰˜B9—ˆÀžÆ€`AàAF°‚`Ai†P".}~EGKXŠ½ipu]qj 80DF!H| ßÃðaJoÊL… 2U² ÁTäT ‚v°žéÏd—J»š7•øµ«9P Ézä–(RÁÿ¦0:)mbŠøÍ:1¦\if6)–°¢Ð¤óTâ9´½•‚£#ŸDb·Â¢ `6¬`ºR Ú¸þ6]e’O¡°µGm2 X@ àˆÚu¾wøƒRä£öœŃ)d$ÙÐ`+ª‚Šz¿Á^*§È0.·¿(¨¦z™KþM ApÚ:‰ÎÆ&;qÎ):<&`¸DF¦£#“h¶#i!œ]ˆ€Q±Ææ|zÁ8‡†l4£MéVaŒЫY=×rË¢ ~–Õœ SÌw ƒw´®‘:5ßúB™¼=Æ¡“2Ha‚Í@$ƒí–;ƒ˜wØPDÈ¿þE¡‡Š™" E'0%°àU®®hÓ…¬ðdÅ%%-'9—ø©M|„39ÎÖþ6œÃ0!àX¥×È©38K¤-O”‚`ÒZ ŸÕ´‡Ó›„®6øÝTJ”~ZLªf»Ù3êÔdÒ >¾]üÕáåÈ (˜õ—'äÐ$B1ÕÉþWZ#u)_VøÍ^ó¹šÏ6špæ43ç`P9•8϶;C3II %’ôíV¥ „Ð$€f•ßE JpÕ ¶2 Cÿâ¸W1õÀ ÇëzvìFdG9È ob‚·¹'Œ|t• r¨ˆ]Ñ¢å ËåV¢ ˜’"ˆCÇWìdƒ93—úØš›šjM%¹¢MÕJV‰Vè¤þÊyÒpVbÍбŽIE÷…rp63®œûÝh€V?`‹[p€w?ˆê«^Å$ÎqEy5Ì!2Ö8 aB`Á°Q}ЀÜcú˜Ðw1>D5È®/`FÿYýÉ ~¿ìÊ1Ó@$šòBwüþøó!ÄñɶkP…*èÀ(C5"€Ú#žÐ20#½!t’`·4ÀuaÈ )33Úä#FAg=ÑJ€u€X‚NJ°X@5¡ã# T|7OÓCs5ç 0q Ž"}m%7Ø—^Œ’(²>åcA6f  …~é3! r¹æœRÁÔR¤JþQ ÂÆWz¡1ðà€^ñTgÁb3%ÝÂo5…Ô‘ ¸­¥`.ÄÇz¡c¶q5CC€ € @!`V—™7àÔ#ð9]ð‡C#U)€ÇÐ/¨ZEÏbÿÀÒWnu åâÃ}3!îK)GW!PB8l©øpôÐJ¢àÐVµ"°PIˆrp^8u10rßð€UW`dÐð- ðe µõ•3M¶ §GD¬b¬â>RÍÁ3…p‰<7'¸à`¸‡0Q -²ÑS`3X¥þUÆ OЉb1  `˜A!5˜^Šò] C0ó§>±Ö7ú%)€W qP“V]f‹åå}-—R2›13 )’l”Aß@#g19“ÿÒ†D0W2!Nð*Z 20¢z¹2:¡zÓáL• †6A¬s‹€oC^@ÐT!0  æ²ª [\.j7Sî!3/ÉÐ'›8dùÀƒx‡0û²ƒ©’–þc`â> g>Ýs^BSD!÷•z`áÖ3;h!`“Rýq!Ð[ø HW°NÀ4 8¾þVÀ+\(¡GÄqmSG:² 0@IrmŠ`hYÑ2EÇ ¨Ð\@½w}8PC5\¨Ðá¤smRCòä\Ä @Æ(}Á"ß(k•}ñwôðÏ66¶V’ëéDq~±`8:€E*0Иð~„qß“çd ¢( U:ñA¹5°î4 8ÕR$3q›¡Ó 8ñ*ÏQ€Dµ 1ÕNòq¼1 à*á25H5çZ ŽðÍ@|?„UèâÏ@æ¥ÕGv(ßµdyéDüà?™Â)<Р—©„þO8ŽG¥\¶>îi‹©h Å™Eø›â’é¤ácå­Ôe9€b¦2<0Xb”e@5)` %S+Ý&%F¢ŽÉBp2d ›01Ö AçàÓñ‹°'” 0¬³ÓÅ#IÅð*Ò¹CÍWw§~QwÞ™Péà©67àÉw–9¨1Zz¦s÷VŒ)CDtµjwud %)¹0’^Àð…"e)ö•Jf™ñ!Õ‘Ѧ[) ˆ• •äLkt5ü8P6ã +1&5s 8S@Rap,ƒž 3‰J|†Öpþˆ_¡\ÄmUXE á¢A!ü(Ž"ÂV Ód÷'ìÇ)œâ‹_Öw#wiz_€Ã}Œ… ìã™’oú¦ñÕ8ƒ)µfÁä‹A7è0 ƒ_9ÓrXÀ±@ ±ASc0¡Ú Δ 8Ù˜)‘Ž‡¸ˆ¿…5— %øx[Pi—.*Z ÐYpä ®bû0Iòae²ç°wlj‚ÞyŠ">è•}7À¨!m·ºrÉö©©HÉú«‘ÃK:™re%ä¹)‘ó˜"K¸¦Ÿbfl}Q^âõ<6‘&³’(›/p@ÄLQþŠxm2qÈ¡´ÀðuLùn2’¯·òLQÀರ–¹é¡&–6[“c_A.h0aDMæƒÓ7á¶(qòÖ"+"5xó!À™OLP8RóÓ‰;­žQ„‘Ã)0¸* _™‚Z¦²ž‘]rÕ]ȶƒ+)p¯Aãñ‡›‡øº°ŠH2R´ŸÃ`‘0ÀÚâ±²Y¶áURZBJ ‚H’JhÐT[+ƒUÊ3 5ši4'óX0il|a à)Jt‘ ó“k‹7‚7!¹…f ˜âkAÜ!"% *¦)ÉåXþgöÃ…‰[X Ê$w ’rªpeD!ij~à (H3øx#úë‡ø¯³‘&ôr3QhÀ ¯Ñn5ÃÙöS[ J`*Ú«Í—­;ªghÊ¥Cr2'Ñ•‰! }³jÝy^IÆ°¨J—çƒ ²f"³¸3§ÑPÄÁ{Ÿï;1üSQã+RäËý]Wl~™xóË7®Ô/£˜€S m‰3Š‰¿GS³!G_›v(´A1ó9áê:í&‰H  FàœY Ê ‚†vm‹šm_›á’– PÐPŠŒñ°yÃVZ:A†^ÿþžíð¤z±Ж’¼Vvû“oÚóãk11Óê¥_ø6¯ŒÅ'‹P$ùÅe„¡¡Šåe‹2‹_pY<_×h,†Ø <΀OuG ™àL9S[iBvˆ­[JA°¦¾“€`¢ PG]Õ ià5™8dq#WLT(~bJ€á?^0’Ó«¥l)Þ[e q)¡l¾ÒZ¸­\X‘SÝÐZI«Ç0á eƒñ·ƒ0‹AѸL—†׊IpÆп>í _kÀÛðµ)íµ+€&׶ üøRG›QðVIÀš4‰Z 0g+þñC)ðò›t|íaã}~ç‹ò0ÒþsÄ_š’P(Å3€P–¢)›¡;÷G~‡¥•Š¥_veÜùeŠøì7¢juFp~Ž«³¨Jþò‘ñ]SZÜ‘2È\Àü(‰Z3ã‚U(ˆ'&Ÿ1sˆÖÔV`Z³a`ÂÚˆ_ˆTá€ûuk©\ì¢ij™.)W ò‰Æ)Œ!3W„3Êzq w8 ê+píe~›VTè‘û‰”KÊeòpàð¹X†òJ’½^×Ð×3EiÈÌUyÆ`°Ÿ:)cb¹‚&pAþ6³@uNqÓŒ PµHÿ:ñÁæ-ÔÄ /pp¡FIàP÷ =p…§à bkSd¦ˆRV!7Êä[QÐæ^Ì 5<ÉÅ}uÕž¬]àJ°YràTúpO}7|n°ÝE) q~ 'éí*ÿÚ[ð!ä*®2ST0.uºŒPÀì ãÔy7°£BÀ¦X Їͧ€ä&hü.Ôõû.çù ‡(xçÔŸØ/ÖÝà׶‘7 Á5k°=æô!u-·÷ì}}þ04À/b‰³P€·ªÍÛ70üZðè ™ÚKÓPþIÆà¹Tî*3´L•ä„ð²NL+!ZüþN 4À<Ðuƒ< ;'£¨ð¢>'‘šií'QÂ/bƒE¹¨FƒåÕnuƒã mÿœ*“ûÖ×É×¾/‰©ÝLÄPëC?€àrJ€_ð´ðd ³¼ u `š,<@±Ä]pí?Œ7÷…i‘Ò‘4NÀ3ÞØú*ñÑs‚ G;/ø›N&ˆ¸QU+#@‚õ>S"T†Á‹6 pM!;0r¥(¡ƒ"!® Š‰¾Vë@á?rŠ° Í­ò·Žk£(ŽG‘ó@0PG@§,hiþ¥j…A¥!p¬Æð*Xpᩈrt+1<€]GÐzÍÄSÓ‰ˆ`¬©&î„``ÍYq²ñAN%R±£4a»JÀí2ò*æah°ÁÏ , ¶–dà¦Ô(†KžŸ(tÕ©F×—­„Ðçyñïm †™×uåçƒAdð_ D€D` Bh7ã‚<)Qc]]Q3$„‚97( *<„‚‰[#SBS3WBcQS/GGS]hGhVQ)!!NQÒ,J¨G¸QPc+)) BB)þ-,‰B 9F9Fðóñ”ö‚ñ99 9Þùpïƒ<‚9L€0¡Á7nô#hÐ߇ôÀø. ;# J % À‚²Ã"Ë"ZX)@@JB0𒀂–Q´D)3F‹A¼„à@É Š 1¡‹t@ÃjįSV9 Àb‡³H±šR&•¸i±‚f BŽyQ‹ƒk¨m‰Ð¥Œ¯h¢t(…‚7!cI£P@–ŠùâÍÃÏŸÅJXiæ«h¤´À¾³˜“ÐÜ©öGòóçÿ2» 0 IРy€…š®0«þȳÁ¸ ̲b…´FZVe„êÅÞ˜@Þ CM i¸al”DSr½w¬Da‡iDÅÁˆÒ,bT¤°E<à4cEP€aE±BVøtLcŽ%B 9”‘ÂBòp¶Z<ðdÄ™;úˆTf4UÒ‰˜ýä€B?œiF ="ÒT;žYbb=À(ÑWБL¼E)QF]E@[ UF[QvË–ehÑH!l4ž&˜Àlj" Ì\QÀŽ±AL 34´æ `ŒuSÈÖPSÅÐÅJèàË+(á@hÜ2 þŒE°JB°J"ë¡ÄH9æhb>ïÀ£‘;¨QrŠT–èªl©¦Ö«¹jO?!=IQ(‚lT@,E,±Bd€‚Dë™M‰‘tSŒ±%Pbj·¥vŽh1 ²¢@^÷­™TÍàE*pHÁ”A ‚ ÌЀ¾Hx!¨"Qxå@lP 8ÖWp9ƤPMaa|iÓù@ 8HŽ}Lú$¢‹šÉãŠ!É6‰õ¼3RA´Q©òH¨Ívo©¥ÖTD"] È]QͲÑÒ(’@¼©&«AQ¯7±·]U˜¸ehnX0Ð[!HhrŸþ¼”oŸ*€ì }6ÐÿäÍà—Ã\åÌ—aÑ•LÁVH‘€(`1~%§—®ðÕu&ò±ƒLA8~tͦ±*tg ÍœQi®Žns?šíSÛê-:W’Î B)­„…p'ÃVc;$`OMTÓtƒtNtámŽ€Éµ¸ä.Ý“7ppÀ=ˆ@•Yçõ‹– ä™ ‚ 5A5q9`¡þÅ¥ÝpE€.¤\1 Ä'E5ÅàÙè.hD@Ž~«xÀ)8”‚J¡®D‘in…^ù $àÕµPŠ«øhs4ñ‡;œ6º@3B»F|$(«ð@:!þè€ZY ÕTU¥ðD"þ¸A”P€#|«@Q˜  …-áe’É“€„ Xï>ÓDš&Ð'3¤É*˜A¨˜„!ŽÃùVø–”!‰8°€€Q¦º7^p Ttá?ŽY€cÌA µàT8J ŠlºŒhÐ#¨iY±üA‰b„… p› @ Öªˆg¨†`áYJû À‚˜<-#Á– Cq•Ï`€!âÂ¥ tMˆcð–׺À‚ð@O„(¨¬'‚¨€]TäÄ0MÀ½…ô«¼ˆ¾¦°ˆ\P¨.Öü93? b høqŒnDþÃS¦™ä2¤!<s6’¯0à@ÒlfA¤>¦ô’ˆp"¹  8ÀÒ•¤u¾ÁJ ðOa )!ea‰ˆ”†f9±Öóœšd J~¢¥å)¯(]¸Ñˆf‘p ž zÀ)voO IAH„ñ+>t˜Ã>À‚ÊðÀ€ÀêK]Š\¡À ¬C'©:†då°œ7•À‘Wâ³$€M#}¨jG.KMŒU’¡}@b h <€ L%!@R%ÜîY` AA­ò,s>ᔨv‘BÌ [ai×sËÅ,O N€NE«=  þll¢ÞÙPLð`v’Æ5¨I#Ž@SHÄ ‡ H p… ÌàSQ%Å N‘r,C"‚9¸ÚAt&UïÀáEé骴N$˜±IbxHŽDWH¶Ì0ƒ$ ?ø N°(ˆAøÂ„à Ž.²¥7A"ÙúOFb$'A˜Àµ<Ênc\DáX#e%µ~@êBËChk–@š@1Ec¢`…þ ]x~ãMýL_"s2–1¼ AŒ)ÐQÔäbX!]«83Í èWúBV´¢×•#jý@¼p’q á øÂp°`44t ½þ,ÀÔÀ°_ÞÙnŒ€‘¶’°¾ùMRPD q²·e½–…§íN5e®( ˆ‰S¨I_˼Ҙbôçc‹~” GÇŒ¥ =ÝÂXÀ‚Ȩ‚N¥x@d¾!9s—dJHà"_é@å(D¾bU‰Öê2ßÝ Èéc•Ì á PÁ­¡,ÐÀʼNC{›˦üh6º2+°`uÃA´òG!@íŠÈ%9ÃysS,hДÞV4þ €ëFņp‚!BP…áÂü¥Q‰ò\¨ÇL?vBť㒅£¤ n†XÃç‚„G©ü*@Ê$d RgSþKÑ&™í™ 8h \ACQW€…{YWpÆEü+BcuDe'‡ÕM*ËgçÄ )¸“¶‡Â<ËZVˆ‹@¶Ž<4²'´€€ °EMh±Ž¹Ð‰© iƒÝ‚B…âi^`!ÇVßíVKÉ(PGR#¨«U>4·À@† !¸¨‘å¡V ôw©–Ý8 ‚²x€¥¼ „лӠ’1$ag8” -g„%+ˆgPL\ÊΖ 0yk›4б À <%ï«OhA °°EÄK< Ç øó‚#Ðe TPˆÓG§|…š‚‹*]@àjÈßäÐi¿¹ÀÎðj=óþ]«°wßĬ¥Ù¹MH‚]GNÍ‘:$ {¤„à éþ‚’CÌdòiÌg$kh¥XÁAlýÚp- ] ¶åožà‰"+õá/0{‚3ƒN0™° f~‘±qñ ú! ]uÁ â)ÿa S0ŸR'¦ !Ó!f +×+6³­"0N—¡A§ñþ´I†5lµIÅ ;4i\FÀWð,ðL±;ÐGxÀQBÌÀJW×5+ð@Fñ5wmÖ4°v ¡A`}7t"bÔ6×sÜ“ÓaAþM(Æ>s‘ Š€1"&©p =U"h^GN3&¢A»!°bàÿ k±”" F€ôó 7I)‘€Xà¤cV)³¬â3d#Ä FkæÆg[¢\ø…”wm7‡m˜dr£IþÀÖ#t —ÒSÆàO¦æ6¥GEb@tÂ>‡C(­u sýC*{”˜Æo«à.0#‰”q"oåM¤eÆO¸!±6,ƒ×RÅ1*ÐB°PJ–‘c§óJž¡ƒ1„WÁ 4AðP1GŽSÀ<fRþ©<6g·€.=Èy4#:@€(à¨Õaq ñA XÀ ñð–—ÂðG0!VÐ ž"bíÔ ÂN¨@÷B'[P=xµl+ p*POI13¿b‘¯ãP@‚5D£Pà‰a`*—€W±C5:¸²ÑƒÃ3Àã4ÈãCCá-ÕVhyØge@y DÀ8Y+ÀåWAÆ–_—6ñ$Y·þ1I B@!"óF ïQ”¥` tb)€ƒ uÄ $˜p ú!™9qQ&§°w#ƒ™,u7þÿEÛBš¨d0iËËáIP0§Ø,0X w À"ÜÅH‰'PJ +`<"¥%3·%Ôö‹‹‰`ðY`º(™ÄrP=â`ë=òn¸ÐS¾ cP>°)@Ey>a¡!ø– :Õ†þ9ZÇ1Šð ì“š‘a/J€WUWUè¡1ä!a-‘õIƒ•¢@"w&„:°`àJ ৡnùÀó„`6<¿1Ipú·‹Byyðùžiy"yK)PŸd;€"%¨U'“0zæs‰ö „b ¸@5™1Þ0ŽÆ1×X!"þc¤’5p4|„67ÎY#£q3rs 32¨x^{çkÃ#xXpŠU2 ÀU˜Y (ÀB €¥Ï™Aà¹$Kº…‹?Á DÁ5D&q–˜­Ú•õMáK?25›È€ 1÷€ù K' ý=ÅsuŒcL ?"Ã1î/š[ÝPuB2"J4@gUpüÒÛòl©ÓŠ•ÀOž.)1BÐ$t8Á°fÂP€Áy‚ i]éÿEkf`H–„€¢þ X1Ú®– ?@X^\5x•€_ ¯š„¯¬ ŒQªb‰‚ÅE îÔaŠiRÖVY¯Z àKeiŸBr-a›%x'­åö ®W þ/c° T¦à®7¬¹ f©s§PU{D‚©é¥@^þ"7?S%¯”-w#…´32-Ì0X¿$ÀB0@µI0P€,š8‘4sìDÌ“[Z¤3 $ÄËþ=As#¹¶Ùö¤òZ«J÷úH5aep Š ñ{2Ûa’½FoqŒãà c1Ñz [ !"V(¢SÂN« \ø³sƒPP–@#O%2Ðú͈·« M£ruŽö à°TN@Eõ;X…ŽQGò》'…¢-÷Ë5À¥ûUpÑ!Ô [  á!½Ä,Bða05•<€Ro&΋©…½»œí¤Ê³B&œ˜ @Å¡ø—KQ ØäH“ÀÒ[f3P0·àh6=DM·@  ¾)0¸Šo¨ð(þK9o͸ÓZ hÍ}×TDÑV“N@àÃÜ%ÌG;Ɖ~Ý’Š(ðR,ùig,:t{¼b[zˆÒk ¢)-’5—ý¤«Žéf[¨mô’¾N Ä&„I&šÇØ\ûH‚wX` Šðoá×à0Ò°²}ó «Ð!³ìÓ ß««|¸{#hˆ’‘¢57HPšKd¡}Â&fá€pèÊ:à ùë ‹—† Ê(ÐÈÈ&ð 9tàÇ] @X+å`I$ T`ßêù°Ì£…¼X¦ê˜3ט”åØD^CYd2þ<³jd†µÞ¡°3ÐÏÑð) ³Z o¶h @‰‹†HñQà@øb "¿¤0T N  ‘J0à¬P!«àÐ,Ù'+É|òéùë€BÇ'ta¡Èäñ=›“~a6•¸]òíQ¡ AaKªú-D$yâÌßËß‹`Sõ-4Ç%Wal ndíZ,á¾ ¡Ù%CÙa¶' @¹tÑ`È Ž3[šÚèŽÆuN\Åf \Ö« ‘¾Eù‹´5^`㤎ï Qnù‹ï³|µ¡e“hÕ!À¿¾ñEçÉf-íÌÿþ•¼.DÖàØVÕqKÕæõ'.bþC‰¹ë’ù<ŒÌØé ÉÓ{æó¥1r0Ãýq>#èƒ;î0tb/Z7¹“‘š` j1’Î'ÿ"êö¾àïü®¡NEKAêH0D>(À 3b³{ ’VÚ=9&Ôð,Cúˆ¶¤‹˜ìg>Yœ¥gnÇ+æý]s­ÛìG¹áæOr-ðíÃ:#Ы5hâË 3”ja ÆÐS1G'¢!>L Úo©ÉGë jDË *p 0»H â¦!¿ 30= êЬ¯­ÿ^pZg1 þö…Z‡NNð;0ç)³SÐKîŠ×Â2<(ª’׶»ªrÏB »ªgøWÜ/ÎÚ‚5¤Ð¾;†ÚÈe6é*ÐúÑÛ³-³ L]i06¿í6ˆöö½ž9•A¹ò{'(|€2B1332ƒÄ¡è5ÁaÈ1119áx8ÃÁóqÈÒ2¡3ApóqCs£4"´õ0Cðñ1‘¢UÆ2’‚…“óqŒ»ª’²R¦õ\V¶ÒÑA}=]]Ö±Í==Ým N­Õ…Þ¾’B üaKpS¿zû?\?Ñcy%ÅG(XÅ e¬Dye×”-(RHþqdKRPpáã‘)FŒp`1E |Tè`Šƒ–[P‘Á„I>Eª²iS†C*éÐ9… }š!€'U¸TݘA!k Us­`¡EK‚¢ŒQ‚l™*W¬ÐåµoÕ®Aéõl¶½Øìöš[æîºgÛži ¼ÄÊè%¦*O™*%¨¸$¤… 'BƼ¤å ƒ.ž-F‘‰rÄƬ Ovœ˜µâÇغ´‚Z` Q‚-’Ä ž–Š> :iÂR“M ÑEÑ3T¥ZöA‰G Bº^%ÛåëŠcœ<È`U­U„té"Ž\à°Zî.³ þš,ÐLç|ÓD€W6Òpc@[„ XïÀ`d RU*8À‚4PÉ ðPEÐCGÄdÅFPQÒ ±E0…@Yí2ƒÄ&ÄE¥PÀBY-$k¬ €Ä)=MÂA8"É&—M@&D%=uø KÚ³J—XÙˆ<ÎÐÅZü²Ý ØÂV=‰0Ãa¡ÃN6æ„5FX»¤ñŒP0Æ6ö…GÑØÅL±B°{AäÇB `À£BHá*^l1,@eY Ì€BL/DqÄ®Á…A)´ÂE±jôbHÛUêF.-ºZlYÁÑþEmQÀ(B]$D‚¤‘ìT ¤ 9)Qr u‡ PÏ1ü¼’ÕX¤b€VFD 4]¬y=¬p€ÅÜDÁM^}¶M»‘ƒ4$ÐoX‚…ƒE\܈j ÚAÑ+!€E¥B 2Â@f‘ `a€2u $’J€±á°AS<ÌiQPñQMY™Û®ø*£mÉãl(Ž0)PaQ'ªà!µNaKíµ0‡ $ÙBÐ#þLbË 9DJ,!Í€î Ô! (iÓ`Ñ…ï¡e¯$öE¡ µqÉÿ.²«-¤'Ÿð‡AìIˤ¸Ö&(aDè ÀþZö8›6¥\ÁÏ*^àÁ3¶~­ÀèЂÄ$ñ€!eˆKÀÞhnÐÇä†5ÒGACaY@5Ž˜4Ê›‚k"ø‚6’°XJ+{W›‡ä)&¼˜ÂŽ²1ŒX¥CBF`…¸fQ9Iж€+Š „%(qÀÆX…³âÅä#9wT •ãÉM$NS¤Ä“oA©Š¶X†~µÅUà«ù‹ÀÐQ·HBPÂìX¿ôk„éÅ5²οMÃpJÈ“¦1§t”!f@ÈhLâ’‚DiL»ˆ!§ð×’#CèøÙÆÐd fIAB"B,…D þÍc 0BR.\q'!á?=A—x$ù!HÓŒŠ›u¤Ë\‚¸T D /p ·hÅ2fƒJ`A]¢PG;Þñö“ uÜguù—827N~0pЋõGkÐŒå%R@þÁXÊà„9…$­‹Ð`• €#pæ:æÔbânãa±pV׊Q δ7Ïa ,Œæ’¤ ÔIÞƒŽ0‹&^f•#KõJ}üzH‘mgƒœÆ#W¨‚3Db£QÂÅ33ê+?WÓVÞîh/™ 9R¤=¶6Üa ¼°‰PX¯(Öjõ¼Ðc,æŠÊ¬Èììçg° è\—G ½‚ó €œhô8¡¸9®.‚uVñG[ƒÐ¬'Æ*0t“7+SPÈ/ÜÜîf5¨C¨Ð4$7Í’ÿCžYf„´¤X,hŠ Ú Â%ªéÍÐÆ¤Ï My¢I(þ“a#¦« UÏâ%¨€VâÀešÈËG`!®È >VäšÎBݦ!„ƒƒº] ÉŸ\± Laë ®F5%Ÿ:búŽ—Æc6Ó§oý•AÔe¢«Y¶ëÉÃá&El=õ£H’¬.EÐ M£vÜpbå—×þx„’ @i5h™Žæ"ÚÓ 7»ÙInž_×lR5ÉcyF³ò‚)gl ÊqfО=3ã³¢]†([áK}e@ƒØn ò¦óŒõ Æ~i8zš-nqRŸ/À…-`ìþn±ˆêµÈæ$]W$“M~G0+ÎÆ~²û4T€xEþ º,·x !Ñ@Çz·:’tl# ‰É¤6BÐ4!A»€V2aìCm mŒtA.7Kà-B °ýE3ab6óà=0gD(N°@@}ê€@á Xà&:`PçséÀoãpöaÝ`v+ QPVž&9ó<èoe¤o]JV(AOHG`;ígwÊ£]âUdY!ú‚OYˆ_±QU$ÀDZ9çþó EWµA¢Gsä!N³<@öù%x…EB‡t2Ñ1¡ œáx³ Ÿå6ÊÀ¸—³D ³“¨Ub‚/¡þ#bäPƒèTsDG½ƒñ¡ov÷1\€wåq¬âeÀ4T301%qw¶†4²â:ó è:`¡ ´:¤tÁr‹²ÛA_MFWu…¡bÎvJ¿BBÛød…VZø?v,ÀtX{Œà‚B­"Tˆ³/2ƒQ’Žy"@ùX‚Š×8qW †CâpŠ¨X04Hh;HÖ$c1f1á4yBB®òlœË£Iox3àJ  S4à!ªÄô3€UJ°€r"±(§‘†‹¤ ”Äæ† H ó™JІqtõŸÑ(XùdI&af¯!ATH_?ö«f;$AÄr.7ÀG œÀ‡?ó”Fgƒ*Ðð›s¢¢'j€dvØà|zº¢§è‡3[¤ñŸïBΆ‹]ÊO<d— õ¢þ´I¶cIk 1ù–¬1XÿäN¬aÓhH™)ñ†(„J&áI 5ýôpҰϘ†Ç„Kú?ÿÓF+ÙouoyÔThP„pFƒj‚þy´M€ Ui隢 p+Ê ð P0 dfq—({3Ú5AºH!RhPKª¯Ó ežd;¬ÒÈ:X†È/ U;?94ó "ÔJÅÒƒ qÔØ:Ζ"b…fáOZ`A ±šÎöp ±¦¥ö†Š·I£öp—´Î&…á DƒSµ³QÀÊn¡8N vôa”&ºŸŠqD¢,ð: À£v”ù¶“Hüb3/iqc·©ñ¸Nóí²²cÐ(Ä!+¬‡ Õp=A±:.ô‚H§.ôŠ\˜m¬Ây1›€²sžA­8g5(#þdþ"úzTàO¡òŠdJBèÉ—¦§¢X›“²hÞ„i£h'å°¢Z®;{bÓð]Ð[‘Wµ ñp/p—G,Ä¢eÀC›Ô6£>oèILÒ…<#Ð(eò4-€:à ,àyЕ±"_(ÇšJ#™ £‡ $>ÖQÑ5 WV€]í³]”IjG—´–¯ÛˆI¬êl3–dÄ’…J¿Á‰N+VV™sïpê“Ulb&¶T¾IGBåZ üba}ꘄ‰BÚª¥{§¯&‚Bèî(¡çëI$Ô«Ê*@<€2jI8úÂS…C‘†QHx7Ó«½þRdªùŠ\öe౧ñV¸'~;ô/P&Ó`4Æ—•šTÙd7‡ò›epFð³­E¿J;ßdGíö›lGƒŸ»@ üb'éqÇ*]z W;t3lxüÒƇ—}»3']q3, À3åÐ:¸ñVãÇÿW  âyQH¥ÈƒW‹u¬âŽ•È/šÔ†À‹…»¤mä?‡d‹f (¤I …_]PN»õT¶ŠçÐL‡NPp•Û•ºì®pé *;ûÅÌw —ÓO  á7²%Í*²ˆÀµ6W®JËuþ3c¨ö5Öh.˜^€¶`þ (TPc[€<€²P#%»¦¸aMƒI¯›"…t%=½ŠPçDÑƱv; goE¤r"0Mk›dnWUã¿&3[Éw¨,VÖ›·L„c¿ ö›ûM-h…/;¡2²H¦I1&³;cúÜB”©É3†Ò_ílŠä*ž„pBÍ€4`,°pªÑ> ef‚ø3q38×~ˆõ„Ÿ}ÁO]]J¼]Ù×e4Á>l¶—Äɇë‘ïá{Úõðô§P•GÚtv¤®ÙÖY%ùÀÀmiùȳÏ`‹78 ªÛ8ÇtÁoU¾Ð*~<¼À/x©/¤ÑÆû<þ]pÏ—J¤ïñ?¡0*¡À-t«ûB~ø‹}xlÊ8›Ä"¶ñl³ZdĪŸGB-ÄP7ZHÄrsewod…Buãl"]+âú‚Šù˜œó¡oçp1E¿ÊÍ[À]À“Ji%0óí#WE¢eP¨ž4²oEÆV7cÔé–D*]Ô€B½ÀþC¤IÖ>ÂJ!pJ ¨$ÉcµkC($zë\#aãBJ"¡¢¯ÃO§a‹Ãw¹¬±Æ*D¶s׸t’ï¸m dP³øcG„s¨Š”áxäƒo}â©»­¬ì½ù:Û´Ì8õ$Ä…êþ\µšÜyÙ*®‚qÓpMuÓF4¦³šÔ*þVXMAœsÇD*ʹS ²'€=Ól@ÍOQ_yµžþ÷êÑ4 ž¯½ŠIŒBc)ò ÑhEÆËûqaâÏGâÁ}&4°†Suv8+8¬\çñ¢C¢a¬vÜ›/KìšÌ4<·ê3f7yÜ™@Ýß©>#ìŽM¸IÏÐB<@ë–&:04:Ï#ëÌ U^®S,ƒ0eðÇ3,»®a6qèÛÆ/çÁºqžGxÑ~µÖ‘W­= 7X0ÐðÅÒŽ´eUVwbhZ‘ÀÈÝ[èZ} Mþ¨8 œýæGÐB3¦¯ØMÔ¬Iž¦7Ó{êãÃ×ЙyÑ«÷?àSQà'~Ö$ä•8Ø@5²ø:)r, *DB5‘PáÅŒUÞÔë[…Òu¶Kù%q¬ÓËõÉ !¡MFŽ0¢ÏéJ¿5X}xÝÐî–ë¨ù“?7ë ôj‹¨üp16c-´ã lm„ãÜ@kQÀ8ªŽ ¢lÊcf;°,K×^ Ui™ÜBꃗ‘PcõI(ñ™º™X½*TZV¦ïìc0c EÖѵP·*' èÕBfHp…_)@úBiß®?x­iƒÂ[9¸á–&ÆYoæwK5wK þ˜òcy×éú,ão…¯¼q;ÔDßhc¬¥ùîe[‰D XS0W€k÷L@AQ##GGˆˆT#VSSQŒGSQQVV˜ST)œ[]š]QSVšŒ¯+G‚‚)B¹NW* WWBNSZePeeÉ+PZZ+eÏÏÐÕÌ+ÎÉÌÈZÆÆÅÈÊÉãÊ+èÍÓäÜÝÈ[XS´¨GcªQ˜Ÿe«VœÇ‘]öuyQFU™cAI0a¦#eh9XÕaؘ(NB̈p±C”1 §ué‚æâˆI(Iáàƒ¨Ó!Wý$M\5qÊZœ^ñ4¥þè”>_Q ÀR/`tp¨‚â€V«pàp€GiëÎU[ÖÍ™ud•­ã¦˜±/ÇÉuç1”dQ(3“‚[4pÇ°ð08ÒÁ¾c’\¡ä˜QºqìÀÙÇÈ.fŽ™c™žEó*É@@Ɉ)]–]DWŒa™1[¦Ô¤°%ÑBˆºD àÉË¥š<Å¢„iÕ˜¢=÷ó-ÌU¬ZСI‰ëØ­[WP%ž4ru™#–ìlùoÛÒ3sæÍY¸rÝ”)÷,‚ ª—°@!5³gâ`¡Á>IöØhH&«ŒtÜ1]Œ¡ÅHGhZ1µR46 %qaÁþ ÀÂË°ÅAÝpÁI·-•"•LDA^'¥DÛDCE²ˆŸètÄ«hÒ‰+Sä2C: %X‡]”HT)¥u` a+Ž9fMÖyÕ°w‹Ïüà{sÉ'2,@`A–`”† Æ|3 1B¤PÛŠeh‚þÅ •1kª ø-(¸bIŠÖå x` WLÑB´t %Q ¡ÅcǹB“š¤ôSešÈ¦ÔKcùÊ ôSe´ÁTJI‚BÄR'e”È"Qç”Úaw@ Ęó¥GæM{XfAÑÅ:z²h€ÅÀŸ|ÊCÁ`ÌÀƒW8qþL8g}©®d’Z­]I uðÐ1•Ôª}äØx½Ð…¶e¤P†©aLdJ0@` 5òPÒ1m#0‚äÉšœÖˆµ¥|ä¸P*YAäÈÐYp€PJ)@²×)p]³XFÉÁÖå‡â­w–šc¥÷Œ™aÅ°9nÌ X ¬L<|ÄIjýpx¶! 1Ò¡h¸ÐŠ¡Ã NˆX2ø1¥¦A" ) StYƒ+F3*I¹’Ò+“×*I­6Z~šª'©T É‘Xñ*"V4²@MôéªÏ.^Ë Ót7iÆ^MWþSæ8bóß\o¢qÅ•„ { HŠ*ôr4hì40ÜóúÚâtk÷ UšZdñ]N`1š!pàDIõ” jkqZQVTF¹ä)]«+]Ø:Tpé_!RÖNøÉB P—º¡9°YvªR  „D‹Z±Y9¢¡žk5Nq <ÈX¢Ž¸ÐÅ„&üHˆ†,™Æ„‰B,øÔ`ê+:Å>ô¶zP œI\h4°T™Š{aHøp ,  ˆ•HÈ#VhjŽÐm ÂyÁ ‚z( Bƒª|¤ÐYá)D­ˆÄ›O¤ [þÈ€{†:ílÇvJ–Ð&ØŸ.±£,óIÏCÈ¢FŠ‡¾³]9`ØŒcha,(ÆÄt5sHCÎæÈD€ QpØŠ¬@)Ùã#‘xd€™Êh!À "@ ,+X°*DÂÍc!9‰&¨à‰BD` ®¸Mo,wˆÐ½9cˆDeNÒŸà4  b0¥¡ íJQ¤%¨ƒt¯.¸s‡ÕbBz^Kvˆ$ áã»yòÎKŠÖ"!D‹7ZÑdº€N$Üãb"…HŠ¬x”ó$ J¸@¼¶×Pë1$ÙÖcŽpF$f),þÄäê÷Šúé‹7ù˜Ho€„D0âÎH´¢AJ\V P4ñ]ê]n!7IÕ©ÆE<ÚV7;dˆ/ïá›fðŠ/QN¢òÀ*´YVÒBˆ‡ Ÿ €r˜Ó˜m£© †ŠÒK°Àb: €¢úfY&Ž´àÍ+¾(#D4ˆýÜ(X9Bt#øSZà€ UP uÁc¥3;È´ø6Uglëù$Ë»äÒ´7I#Õ?µz¼ÙŽ `JfÄJݸ­}»¡BQŽ[+O|$£ýËDú¡ Ýdqm=ÔGºÈ‰‚½ 8Ñ©ä‘ׄêKiŒþM"*¨*'ˆ(Êp% y,â¯p¯aPa‰)|3ÐÁu,€è€×Y–²‰Î:%@mòÈ&|µ´ŒGªåÇì¾CŽÕòViäÛÄ¢!ÐH©Ä 0‘ÝCù„Tˆ1'ŽƒšYŽ„‰Luï!UÄÍBžXÁ`†‘X¨Kœè+o‰¢›ˆNBÙädã QÂER…Rð¹@‚„X•Y0NrZGgNŠ9͉ýLÐœ“H¡„© G.RƒPÅp1¾…;tdõx_ò°Xú/ðÀÄ$ËË–¡BZð'¨É(Âuáq¨‰›véÑ¡. R™½ÈEþR@äÇʸ+UBˆÑ9IX’;Êä^ôJ*n™¥\­@7+|sŠ¦•“œ%Õ•s! BØvHUxA#ɬêU—©Ç<¸íí´¶&”(œ8ô ð‡œC #(Nñq}Ä­²õ¸-Ðñ‚lR • ‹hó:@¨ ‰K¬‹úæV|Âs‰,’&÷FS‚G—VDÿ.‡·È£J U¡Ø죪`¯F‹CxÎà<7ùÈ9ãYML³Û4œÚa–w ¾$Á‚ p ÜDЀp̽Å(¼@»§QG( º$8Öt…ävˆ|–¸c€ôœþÞM(Ï qè(ñR dW“à)qiAÔ$ÐÔî#.â˜Y¦’bp€*¬¹…oÃ|Ð! Â2,ʱªgc¢‘G1¶5ÕvLžÛÑ@ÇœÝ1E€ h‚ .px$CÄÑÉ®¦xú$Óõîl™ôƒ *Š¥à¸¢lŠ. ,¨LªqH‚=5<Ý„d¸›-x¹9šît¡Œ²Ì­„$(`­¨ÌŠÁU0HìTA&˜Á&À Ã?Ÿð¶ÕÊð\nþjݪs˜°Ÿ–»JÀ$pMÀ4P€.`>G‡¶y1»á ´þ&_Æt¸“Y‹²"Ü@•!QQþÀP&ÑA‚‘ và"‚$´ÀX“³ªB?¼!_?Ñ @òp¡ñ ““`:Ç„„ƒZ;óq%0ð0L‚33Ð.B@$±x´»1 2m×¢;ÐcÃ4ý÷cJ€L°s s4pJ'p¥§‡ÆSš°—6д‚©t T€)bV+ÏDñ‘Qc÷àHQÿ‘^¸ 5$“pJG >q·q»Æ3 €QÁq#˜À#àe4pwÌ’:Á†N õqUàwÑG‹~þSè&"XÈ ©–h0væH´;÷WB–†Xð? À¢zPI€ Há†h‰ÀX(WA‚g: ‹su1Ž!Ç€‚Ì>¦H2\ÆKGÁ 0á"”ø"“ð8““#6akK$4ÅeÁñL4ÁVN¤ÕW‚ 0´øq{çw:“µXà3à‹‰x-ØÀo)0&ÆAìUæÀA›̘JÀ5?@àXz ð5Às$B/:2·@2¹‰‘ÑÃEÁ‚p¥î¸DÑ€ ýòóM¼ô_Á Þd\»»qþ9*!ׄTp‡ˆ¶Д   ÆæGßgl 6%Ù~©БU YÓQ`ƒY`€13*°_A|˜¢Uð‹”'O÷¤r,I ×Âð2€ °:׆ Іð ;P®ù'>éç0}2â Ú“$°TýiA Æx‚Çà6ìÖȨ¼ˆ)ñÄ‘‰ü°­FÙ„$9R_ýsJàN)Sü3€`tNç”—¥uÐ= ~é—=à˜ZòqÕ‹G¨»¸˜S¨f} Ç!ã³%’B ðÏþè¤çžGMП¹И¡®)‡"•À@9/aW¾¢F72>¡\–ö8¯q*´P¡]“W*¢‚ yÁ ²ÁKeðL$“ „€bÄÑ ¬ð ¯Ö*„ài 'wi6TÄR¢Nêä¤é)"°ž=Ð&¥Zª ˜LXZR‘:V´¨~NA™LòqU€¦ÇwO‰7a qX?°H£Çz.ð™ ð;°=‰¡®‰89pÂeüÖ*– m„iñˆkIvc@WoÃI|3!¬@ŠÂµ‘.B C$á³\*f  ò p$_‰`×DG ‰NþÙ‘«çäG 0 P¥TŠ¥Yj&@¬Y*ÇÊž=Xp ÐB`Úq†‘µÐQ‹#倬ÑHø XpX`§@P€;‡§~Zzª¹ϸÚ®P 0é “À,á•P+,Õ0Z$+ptª ™F HåUXÙtøYÑDª*}÷(Q9cÜ3˜Ó ð/ ,£*j„¢Àn~¸ŠNy¾ú«Èz¬ZZ¬> ³ÈŠ¬€KP š‹¹HÐq·¸3°‹TqJÀ¾À¹Ð'º AðŒvÚ0zJІ:Çs5IþE@?@“D0®vJ¯›ùÚ0u¯R+õ·§±8B) ¡0‘ 1 F²”)Q úÚFNÙh”ˆoäSKJóã+l4, 9%奭È:Ç¢Àš¬*³3›¬ÇªÍiÍÀX W‹Ù5Ü1r}w`ƒ…?7ºëNN°I`ã£ç§$pšžçM@¶P¨Ïè“>Yàš€“!@X/âø 0A$‡@ÃåN£-Q»O±”£õp#ª_¤M¢s Žæ\ÞÉÈ¡°‡p‡° W–,µpT þÖGMªN‘ì)> º£;ÁTj8Ë;›º¦2—B b hð„ŸD´·x­E;˜À~S¨ p¯ù“'0z}:zMP?Lmx€¡;@¶®‰½E\0 RÀ©w#K±µÉýØW?…hø`å5-®J7ÍÅ74B7¨ø"¦P2@´õ§/ˆ?*_χ·Ð2ôfÆ@vlž ¬`Ú €Á5;³ÆjWz¥" X€º©KÂ)pŸR B°³’,ÉaðD€.Ê‚­lʦ…™JPX«Ã.À' š  sÊð,ð†ú“þ£œ¶®yšéã`xûšh#9x‚ðûMuÓ ™õ=y‘£¯Ñ €@‚fÜ ¤P"“MEº+Œð2øCq›•q€—æt,Yò¤v\~ ÅÇl¬L¥òLÈ ðˆŒÈàÂØ0É“œÈPð໨‘U¢ø9#W‹€[ñ†Ê°®)à=·¼4°š= 5`$€vêÑ2°¶¤:\¯Ç¯PÆ¡Gð—Y¤€*/bo^Õ=.’¶D¼$Ì.2i‰a ’¶ÒJÁ•M^æ|-à+²M’@w,nv— œ«Ô—}<³¢ þ³Ü†œÈi° `b@Pbið¼ôÏƺPP ðYÐ{´;cWq¿4:p“à“7. ¡XÛ @žÇšjÒ~š>ÀYþZküV£G‘ –€;ñ/K§°QKÄ ÅÈ pYG„àeõ‹8å ¢##±MÀ’t)3²û* 4PlùfÙQ~ët,!P׌ÁÉz³ ) ×$¼ °iý)-€hhÿœ ©»ðÇó¼~P8VB„µØw Ý$z´®£wš4ü hš¤Gªi§50zÇ›>ôR¢2Ó0A‚8° ™}_þB?+P].Ú%e0g}¸`D2Õ×JöJQµqƒ¾’t´1 â[4„ ÜÉ‚«{Y^³V*Ï‚L¥ëÇb­ºÙà PÝbÐŒÚr-Éi&™‚ÑÇò|ÁTê ॠHP‹ Å3·X`Äò=·®?¡êyë*Ä°¼¶L0‡dàs&“&·7­ :)ø9…2R2§°H M³tî'9ò¨¤íf£Èáá[6Ìå[ƒ5‘w$dÐq!çŠBؤxÜÇfP¥„,ÈL¥3P÷¼Ýl=8ÔmbŸBـ݌90ë9äª.éêÉžà …þ¶H„#G,ðK¤¡ó½¼¸šX¯>‰¶$p1*YRvŸ o‹°5Lb!&æ(°$0$±¾y"á)M’“kjT §{üˆÍ»á¸L‘ * »^ðÐ^ðK¿$<³w DzmÆ:àÕ£‹¥>ê–®„0Âð* pLB0¢ž À‘çî‘«>äÉÁìé—à…'­V``=—ÑP¡M ËvÊîê“¡'¡¤gù*3·A#˜X0NÑa`H°Š¨]+¢Zœ4nK’ÓO¬#( /e§>µÝå.00M?R?õp  þõVšWñqDˆÕÚa/«êZ Ö7›êYi æˆs` Ô£lÈ_€X0=)žâ¿žíYñ~‰1@9@´5Þ¯`À. `ò„ºò z¯0•t¸A<Ðì9 K)€ aÌ£ dôÄ¿â–°Š*”>ñ¸²áKN?ûT¿õZoõÉ[õYõpšdÀüdÀ xv™`³0;ñÏž<€Ýhà´»ü)À/„º÷Ü@Ü=§>/ÜêTê—7kþoþè?!°“ÐXÄ`wW1r:Ó$ø¯‘`Ò?¼s¸ž>€áþ±E±å@á0•B¡TRUe¤£Pq%ÔqÕ1†6&Q6AA!„h˜H12…šáðú庪2À›ÅÀË$!ñÃõËû+Ñ+‘$œ¥”5À<`BcaQ"òÝð-Òc"bR.Žþ=AQPÐ"Ô¢Ѳ’Æ"”¯•A$•f… Ð8™1€ƒ*z„W]t脳8 ˆD@l¸pâB“ $H’ a Ã6$ ,TÑ¡Eˆ 3/x QÒ…‹!f0T¢H1ªÄÐQ¢Ì+S:l)!‚•.SVX2%Ê!±¸¢rpË#D#ŽlŠÑ–Xn¸¸ -‹5þj<œd¹ŒA²½˜Q»–ÌK‚"¼¤“`Œ‡p&~‹h¦ºÉ& øh!Æ]¨›¡ü`……Y!,”tIŒ— eœxá0`Š‹«=ñ±¹p¹'pÀò£H”,ÁI‚I†×à!•E-°À³æšoC@ðJ…U®GzTE(DÑ…….hŽ8Ðb*Õ×±R Má@€ŒÂ-Q1Æ Ž€Å.€ñB‚0AAF×ð"Ì…Ë`¨Œ_öË/Ð8ßô@ND眘›94ÀÕ BüÔ¤± Dð+”F)dÀƒ30ðZLpþÑm¡8ÑŠç¨#NJ€° 5Ð@4±Á P üÏ Dt*Í°ÍK1e·]63pµÅ\q€æåRyBDðÞ}cD1ÆDpè+±ˆåž‡è‰-ŽàèDÀÂLó 0Xóaapa{i8@„n8m²ŽÓƒ"øà•æ¬8Cb´ÓB î,$ P Ff*ÁP@ñ3L0^\à…Ó¢hâ“,NiŠ‰0Ahb l·ÝI44¡Ñ?ìðƒšh–é›`H¢ƒœ(ȤC*ă 0]h .¡QLÁ ,˜.jZ±Œþ×N€›€È,Ç‚èx$/p]c¡4¨îBìÂ˨®,ª¬2sÍ’5v"®ßvû 5¨™*{Ì°ÀbÔ(&D”Ð3¬çE3a€0Ù¤‰é˜qÛd=Xy%X4Hûì’0ÒvlBÚ;Ôo¨½tôIœåEÒ'ÿúéÂ:XàŠžSL¡©(˜'ã­â^`a±HUfmñÖÍ0°2̼,Ó¿¸dAQ1 ¡$U `ø0@ÓÕd±˜dá’£B9>4 Â®,Š`@`ýt˜¤¡„fÂÎX@~AÄ 3ð@­ÖÓþN C´A©›9´æfÂ!¼ÁíUÐ0“LÙÉDÿÇFJ!d ÿ¹ €:0À¿p(0°€Á‡@pàD!º…ÍÕcP´³MË™Až•£ ÔLÃÊ…× NTÀ@ÈNŸDž™È1´áÈt&ð`©ù`D'X€¨J¦B›ýêìö÷Àô)¶ëSÀÚæ…¤- “#ØÂ3Ö1‹Q  šËS+.VB©b„…61Q»Ê˜"Áh Xig· ÀÄ4ÐA6Ú°¼ 1C  Ó†Y§&ð1Sß QHö¤ áFA*6@Žíþ„¨k5)øu†˜„"r–cÖ¹¹ˆC Pƒ4‡8BèÀ ÐÏ.ŒN(×àü@%¬ Jêr\êÛ  †M2`†zÌRA„N13 h`1„¦RpÑ‹¨•ªÆhp€\Ú6)%‚·¡”lÀaÚ@°œ`ã ù p‚¶ÈδT¨pǪ¼Ý€sßN ˆ±€` ?*vîs§. ^s–.Ä‹àtx,BŠ¬T,4P£·P€7ÂÄv-©B®!`-˜˜<@ u°£€d 5ø¸.@ƒ+¤à þ&”¥‚Šþ°d„ åXŽ1‹9À:€­ŒãÎj=Ã$ï­€å+°ƒç|< ùÇ;Ïù”Óàoy Þ$\æHÞòÄÙ"3`aE(‚º£@F2úHé±ÜÏ ædðZ˜¹u›ÛLI°¼slªPE*Œ:¸ R„ªÜu»` D”À‚\au†‰BЧVÁ©; ÊOà…È æ ¼IC€P„_QÄ¡¾ ’R €/¶@q"ÛÁ;Ìayò²gÕ–rÍ×|ÃAuíâ$`znCåãÉsç3VâBLà\`6àXÀ{ÆæTA‡,ðsÀþ×À†Á!@^båÞÒ^@à7xd0FÁjÛ¤^ð:ÒQl° 1qÐ&¤à0¡gŒgxd~}bwƒfð ]¦ T!nøçY`1I†J„w3 WNÀnú­3Ü17dRgÅ^ÀA&ð—7WM°.M ˆë‚`:A"K7LR„>47^`\À‰dOæ‚Aׂi@lh€^!Ö@!" ðD;x"m¤ˆ“‘ Ö‡,‹„AâWH° ZÃp,*P¦F1Dò“8°Dy±!q3à—¡ÕA&Äh"þ‹p12Bp ± z“/ ÀÝ /~8/? †í×^÷qÃÁy‡x%ÑíÈ.Mð%$aS1sPr>ÕF.€‚J`0PIà¢ø‚édê˜ 4P1£;%Ò"8¥>Õ¦ð70®€(rT,@YW2äu÷µ+H° XDXÖ‘&Àq& Xà41I£A˜ 2c€ #`…0BAñ®à”£;_b çpBhy˜VÏÑ^hpVuWwíÈ‘¨]IH9Åz>GáSÐP0Ð<\àÓ¥{¡¨{hþÐ ¾ó!;Á;ÉlÄt»B%ïïDW·+°ONà’v°OJp( ´¨ôcj;a0Ð'!pXp7X‚gRwh dxÀ)@O9Q¡A‹Â9ãbQÿ1ý¨.Ãá|bè‡Ïa›5Ð^XwÓ '°ŽL°#Q`Ù–°"1pT^ÃN*p”ïT6À›X,h˜0HFI3«.@À;¼°ä@sâ•kBH&Дe ½HÑgH3pY)ÐY—D’›Ù“5±8(°×á1ÀD÷r7ÚVÏ‘rehTø·(§°)‹¢(þ˜¢x°pY‰P[ /£ì‚m·éÏáÛƒ8ˆ@wgöqoÉpó•×%19E=¥z‰â¥ó0` Y\ =0øs¹‡#ˆqàŸŒéŸ,Ó+ÝB^"@6TDw[ReЄ©`“|„¡Uxµ P° ð¶~ýØ'kµ…=9w;Ù&/gB&ÌÁy£÷?\„ö`DV 9¤'–Ò ¦QXð2! !ÑÖ¤e¤íu7×ÙÌ!†ÃQ[Ú_ùq–×y0zp¤<>P^W³t)E3pý€ P AÀEðû0¦öés  L . þ;pªÿ ‚âß0ï7à÷G$ ,É ¥óWÀ 0BP¯: „J0PBX0Zb&fB‘Ú~ö¸ÝÁ – ´À W1Œ°”§`9R™œ)`ª@4€ p›7B*”Ù¹«–Whö£‡¸&̱L0P’=mm¤tR4WÀ̱ ÏÊÄB­@$XÀ!ÉÀ‘Új*HðzP¤^ifÇ|t'+Ð ZÀ,Iyj3ð®'ÿÊ¥f0kf``€&ô#êБ/ÇqX'€¶µGP1úÆAŽS•þ“3Á±È²ž!rXÍQg©–¶Ú^eBB¹öøàŠæ+¹0ÀL"àèã=*€0ð³IPaPDÐs@·{ņª‚ ¨B6³ ®¢;®ÈzS²{³V×Ñ›©vËëÀ†CJ  ] }DjE‰ÛÑ/¥Ö ¶y/Ïá!ð¤ø°.$AÖ¢ï9Y±‹P¯ ( ´ Æ.ðÜ‘NJzKz›mùè ˆˆdR–¶j«ˆ8¤w)k¤‚iÓB30^!X0¯0 `\ \ð©{Qƒz!/„*þ£w ¿)\Ã$Š¡jE1w¯uTïDßÇ(epšk{@è7`Œè@*( P°?P”ê{Èñ81ëò?c€)p(]•š•2ªEd:_Iz8Qz]+ËÀÛ¦–˲@Úy ‰çãzåOdð^0/"6UEÖ—AÀÏZR„)¦¹÷'ó!ûû!°‚tÀ›8¥MÓÁVà cÀh<¬ E±s!s: pÄ.(3¡Hµy7¶zOÊÉoQ¿LÌ@¨ó0MÙ S@G€AG (& U##þ3#$á«Èë( ¤5 Ûæ|¬Z¹¶Ê«˜m6•±kÂE@Ìä0¤ÁIRð¥ï0]ÓŠh Ë ´@0ÚJ* ý 6¬µ6+3`fP§+pÊËKÊvJ3`r‡v ý¢<€$±V 85[h.okfò¤8±4ð²¿L#礊8„pN 1Šb° “%ô!ð:Ç.à4¡Ø†²Ö)†åÌ€AÚ€íuf“û£ §y°Å€’\¥?‰øXõ–¥&Ds?‰À£0w™ˆSxíÊzª˜”ürzB‹“FBþÄ”1ÀĬqáç+Ü #HA\ÀWŒ‹ ®Ð"ÀH!BÀaÜ& ,@àZ[Ààµró44é7 øè x€Àxh`ÁTU2N˜P°°`…*”% P N-@ b°‘‹ü bhª@KÛ5FÇaHë0¦^´„" G(§„'Þ•ç'Ý,JQ +@ R <€«í*‰´sãW¡üÐ@÷‰°}h@ƒ dÀB¦•~uÜÌ ˜›G[€%!·DBÚ 5-ð%µX€`䆿þs]²{ëä&³Ð@ð $5‡}XÀ@à-–‡Í”8aŽR…0T„à_=ŸS§ì€$ØM fG¾i ":gñn(:–æˆÜR[0O£‚'”8Å(—*ŠZ/%„#8€ø€ôÖÒŸÅ’êdÜÙWjõ×Ï}Î^Ô¤Á&^rL˜Á  dA¼°%Ä%Øà´A^†VE8Õ- z.Ýbns+BIÀ ohÒ Á "0ÓÎðF^˜fpǶ†–UP‚"W†Ô:a:¨‚Cºâ4A94À^ 0Š‚*¬ð#¡^ˆþ8Â*aõI¨* P` >Q¬Po¢,¯7‘ÏPp@HQcDÀ —tÊ4ø€e6¡¥©e„À¸º;ÁË ¡¸Æå@!Ñðwî$ p˜¡°Àm,P2”„‰Ö\~¡Ñ¡±£køÜA2GWðÌ5Èä€+ÁYì«5»Qʠ™Q€¨Â>@ˆû't¥3<Ï¡€"ŒÐÄ4ÍxFÈ "³ ˆ ^’ÀάÁ˜ÂŽGžGõ;jE|v2”º†{I04X±Õ . €½Ú>¢]1âšl¬òXû¨o_À2€$# ¨þ¢5…dy &EXø±DpîØ1*·p‹F4îcˆø¤ŸÛHA«± ‚"=3¸‚T`úTˆùBèÉ>›Ú`a»ŸlÎÞ€šÐYQÑÖ‘fmæ1ö•˜“(ç!ƒ—˜—’o#À‘wW†övkÁC¼ô¡€2= Â^Ø„YÆ4$`øaœ€ ñÀSÁâp5ð0>ð +ÂX! @€ZEð+@ ¢#4F@$ð $‹pÜÌ&NlB@LRa(ǧ‰(7‘#¥Ca›ÀÁvvñKbá9e„FãÓj1*ÒS+Þui6*AUã;¬Á`H;…A@` °jJÀ,' , !ekR° ´µ×à AàFVS¢„P„ €á2™ þ`Hºcj´34€À5PgYÄám'0 GD ‘Ð0T…1gÑ–?^$13=ñ)0“2ãa9ao,‚<—r`NPÒ£+T!‰§h‚@4KãÜA`“†º‚h^˜O…µ4xÀ’dqÑH¦ òàIúS*Ð*F^°@Ê&,€D€P´€7€q .… ß:#P lFv@F8INJÐ| À„`& ñâ³ ž°]QFF1ÐTÁV+€ °‚žü*#±$AR‰gÕ+ Spó5¿ƒ3ƒ‡=œþ B Aih’øh_1‹ÆCà1Mžg‘+¡0j´ch/©Ä,nzïÐ$J$r*%¡šY 0  à’?ª.’Ùc~“JÀD/È—<0vÊ IøH€isiOHáÀ§â“Å4pC+Øå¢PñWž`íÅ~ 7EŠò(qv)ÞtN#ÐM¿ƒŽç)@Rš:Möm§*•@â Ùnp¤qDÚ3hà³L‚ïYù©duG^ð š®ê2±ˆ =Æ\`¾F®Øà }£ ”€·`H I„(‡|©þ0š¢H qáJȤFõÚ†a/ÝG’˜25@4aÁ¹=—'4Íá1y—¤ZPüµ41pãaŽñxûe))yJ°= q ³2@^!<û4=I€>n§W¤b =»4$Ð|S¢ ÉšÈ|Æ®Ú ÅQ¾V®ƒ?Â@ à<ÚPP`k)À`š É¢A`K3P7uŸ«ÑEf³bm· È‰i£7p;Z…aê“ ~My¡ 5d7 ãè_{÷•9ñÆãM]©_˜²èhj÷Ñ“‚`x eôˆþ7‹¢'R£‚jqˆ8¶÷ùt«$‚úÂ>¶û|áJ¡œô´Vë@BA}—‹40É°r^ ™àsd» ¢ÀÊ·¯uz€ÀCÙ1 çs:@é–h+F2h£à]ì5¦Q+c Næa:!Õ)g(x)7)Š‚‡# ¬ª2øñŸR^.PO-ªX¥ Š7¦æ¹LsUpŸÅu»I›­ú2%Êk›äs{ãsC2’@'¡€+l‹d`ƒ%²ö­!ëS»Hhw„„›FP–šJðK@(€z+ !pXp10aFTþË:? àÙcºW^ŸMÀD>‘¤Áã_¾£ÍY· æTU”(öˆQ„Å0žæ9†™0‘€ˆ¤>¥’fâZu%ŒCG˜—ðÒ@Ú ¡®•ùsxŠÈ@÷Yà‰ jWÈä–h É=0[PpáJ ÊÊ¡nIvãæ½ÚA “F†¹Vƒ1£’¸Ç±=aAÊcýÅA±osµw=Aé$E™+'À…œ’ äÛTO1=„Û¬$xc + ­“DÖ'=%u¤ûb\Î,àêkAò ¼D(’ð(\˧µ6å?6È€þQv’j5<ÕÏ< ¬!Hè|>…š'Êapéå¦O€ ¦dFTñe8*⶷ÔÌ¿x¸óåûµ_ûVÌUN>1ðuŽšB Ú³æé¾OñF¨ÂX¹²Xj‘f .zÐà ¹>©‚ WÐ*ÀH˜3ž®;8¡x ®” .à<Øp.ÈË4¢ê›ÖÉ„ÜÆYá<XªáóKU`ežð)óy‚R°jÅ —D˜À{(Lš&Müµù›óÕ] E¸*Eå å@([º“›`!Ç á6=¢>†VÙ=$+”l[‘3=\ŸàÌ— ,°þPRSBgÚÈà*ÂÚ¡P=¤ €HE`J§Œ(GGI[Ô«Ô6»p‹Ô’j›áÊ5æ7 W¼ibÓñ„~,2A~¶_hP~¶«#@„w)†MØ¿ƒ9 ´âE‰F>‡…ö ÈÍž€´„Õ Ïû¦uÄÁ*ÊÜÚJFˆœ¡ˆìk!Ü œ®ðx0`J<0ÓÐ$šùa;PºÍ>Èïe"  -y •ÄÎNcè"7æ-Eð3U„ØwÎ@¥´"È—^èlÊaýÌ÷½3€ÖÐ?³M+©ˆg芴ñezÍü…‡Á1LÒæA<&-B ¶EFË誦°Up³OÙë´(A Oám€”_¡ipÁ‹“´ YÄEGüªlÚÚ`QYdI·Vcyƒç0ÃDè<`$O¢Jþ„,Ö½íç4%Ü[À[1Å `!cœlö1Ø´K(0ÄLØZ¯V+tgë±Ò‰<ýeNv<ç±Ä` ‰*ÈŠÀ$ÐpÐj þHh{ëç—nShj”Dœ ¹-Ö«Ö#š’j®²èRÜp7·vR¶675_IÀ$HxtÆ6Zp‚ ÐêÔ¿î¦Þ>ÐÁ€ÐÓ0b@¢’RQSS!ƒÕøRóSCY³P°ÑtÑÄ@2r52uôrt4å0rŠv46beEAáà06…ëpº+4ââÂD¢|P‘´Ñ|AâÁÄ ½ÍɸyYÁX³áá‘Qàqþ±¾2Ó`""¢"¯Ò#ßs/ÒcŸ?!2hÐŒ Y  Á`À…™Á…‹”"m¹ñ¢ˆ¹p˜0c†—hÌP¡Bî™xï?|ûøÅñ_¾=&@#h¤? 5ÚI‘E€á!¨&¡˜0¸0æÈ StE™2¦VW­S†™reeE”µSÀZ‰ÐÖ…!˜œðà‚ß*œ`R\Þ8mÓÖÈ›SŸšÐpÌ Ô( ôÈ)oŸ<žúìÕäɹ„^ (º’â&güHÂ¥HG´5ƦÈÅ" !gp¸à…†2¤d1C^N&ì½þt'N*â„‚F† I.(q b‡¸¢”œZ¤Ž2eP.„SÌÊmçw±%W[+rSÁM5.cDpKW< Ä4(‘Ä „S^''ÜÕ‰6álò '•hèÉ:WIFY'41  ’™t›å“@-¢xOp D ЂPð@B DñlᶑEEX´Ñ AüÄCwÐA& ÁN 褊› ²Ó@!Ðp‚BU &–4¢!›„r !4aeµä‡ŠtQàºì.ðGÅhY1…0¯D‘)ЕÁ6á8"©6 va†ÐˆsÉ8£þ¸ðɆ4‘—v4QÅ–1š Oô̤*˜,W´¨B°€F 0€iì–Ñ‘EÆ–Û±?°À Ì \<ëÄW`ÁÁ‰ð̃ٶ™A—™ WîAddBT¶áœnØ)MFU3Wp„Ð÷Ö³€Á\q…(1ÄtÁçT¼ÕU.l‘‚{énPI›0b±Å—>2hLž»Œ²Î qz@‚L(C9è gøT—"‹+òD³@ #ŽbŒà Ð @!…B"[,GRlDQÑI3°Äa N&Às“fÀOÌû|-# þìL›é¦ ¯Sp{SÔ:L´Ø”QÌòQ_ͧ§ß‚ë W,¯¤0Bì»ï. †ÐQ“¦MW ç5ÈàH5z}b  ˆNØ!\†sM¬¦¨™f6oÒbL HÐH@CP@ñÀdÀ²C>E0À`C „À^ŒI3L€âטÝf«îõ‘…° xÑ Íš¬ÙšlÂVIv 0Bÿˆ–Å8 LOú_*¨0ŸÄÁ§ "†£p íTÀ›SÌÆ.Ž ¤ƒÄØ›"§Q˜ŒžQ9.0×Åîk°‹N‹2þš Ð@ÕóÑò»¤ ;”Bž'›‹t$7 ¸ *@†ÜAUË@CªFƒœè%` _ø¼tØ"2:ðŽúTg€KlépŠy± 6‚b5J¶` UXa è_ þ4(X " ry-Ú2….(rr!ƒÞ.†ÈJY*ƒ‰¬ÔÈB'd`èbd ?@ k)Ê Ø:ÙIAÄ C ðƒ",à É‚¾†XÆ , C‡$Äåq! C² < p€.D“"L¼.}°ŠÖa¡ŒØ±ì/ Ó뜨jð‰§ Q–ÀQBG_ÊPÂp@ŽÐŸþ¶ (®xAßxþP@+½Ð…. ЄCŸ"‡ÃQKiÐB†YœÖA•˜ì E9N0AlK™VD&L {\ *‰¥$à;k–;¤e )HćB|R›”ÆÆ—w³ÞH¸gEÌÐDK]cQ†Ég`¯ ò€ò²ÐKí ›“A†Aœ,m‰‚žºÀ ~ ÌÅ|¾2Ïÿíb¬¼ Àε©ÃÔb†á‹ç6E1&HÆ{цéh0hÐ@ìÂõI||&ÛšT°…2Är6 B x(Ë’² )ÈDrµ ‹"´9ÁóÈÀ€ þp'4{Iu^èµ›L€§«Ôñ3µç tmBbؤ¡Í5"ŸoôÛWöHsR€ …’ ÌÉGlAæ¼…£èè€LŽÕT«@1D± eÌB›ÊÔ' A2¢Ìt¢hÂ@Ûs¢Ø‘”Ê9&273´`‡i`%hÀ‚á¡á‘Þ°°€”†ay(}iònƒ›Šä† 0(“¼€„œµ÷uíI2tР¬ îi-{ЈÛi£<îñÀ"€âSØB>÷¡ãä2‚À‘>° FYvAãaŒµÀijA¾T®Be#¥ØTFú5Â' a Ü:ÐTÁf-|Î>ªsLzèþD x˜„ßa¡ P@ÃœËD@ iè@4Š€ÒËÊF¥'¨Hƒ³SŒ`Á!ƒl¢"Vµˆ ˜T.À ÷ì›8ki˜«œà °Sy$ay"y(ù¼Çh”çã?Ò‡ª¦HÜcÂ|ƒ»ˆé„/•©qà¶0h¢TçÒ!*CH‘'˜!™2S•ÎÀÀ„ôx@~Uð°\ìP³4s‚pËØ@á":œel9`r'ïHEhðÆkBZQÎèþ×Ð e Ð 9E3Š¤3ò&Âû®ö § øªËB…¼€o1ü9oQ°¤ r|Ç1Ô’8 $}²ÖX:!׃®Ccí\7þdñ ë0 æR)´-¦…]Â%1òy ‘d–(Vèà';‚luh 4/ DqFYHs<²`´±`a'€"[²%ûà¢'i`±&Í@‡v#I¡ b÷uI`ptD\¯/°®F„ ähQG»@q_Ñ\kq „Û7PF!/lG2y1PÝpAµ¶kß@F lGЄÞs7Ñ%ƒþ"œdhà,@mBÐ+Ð-p6² °4KH³,?PYÁ[@RPY€<·QE‚\ 3ÈI¢qPŽ QArB2?˜i ?$Õ0i˜PMTQà RGXåU¾ mO4Ö {G@Vuôû‚UTàîq‡HÔÔ`!nåT‰±d4)ñ# °-ã ñ.ÒV&h¯¢3 Qs*045RipOTRˆX P³×_0€a€*Å3Y%ePg3…,´Q$00>¢ánÙ  Q!:,£ A=8x1 þMàE  p•ÆŒ‰Œˆó V .O(O„³»à\ÄÀzY ê·L´n•«( qâe”1Ò …¡[¸¦IÌW²-[‚‡*$Äs5Ðl-B  Šx XP@beÀ%KP°ïóa‘UR?ÄYp<Š´Q&‘E7Q5Ö`Fía:  'P”Ð*GE2úÖ õÃ|° 'ZÁ8­VxYå7z4T°U­ÀGoÁV…(\1í@*-³&s˜¦3 ˜“)³ ŒÑsHz¥ ŸiqB&éãW (>ÍÑI3£µ"°=B@þŽ3_@7¢P° #DÀ@R%…4X @_oùY—J@¼Š f0¢îÖC 2!ÛÑ °4  "Ÿat ?à6³½°¨0¦ 'Á˜U¬WZA8ºˆ(×/ËØåD B4à ˜d”Ô ¶æ }Pˆ‹W!:$0yWz$ Òá:ñWòXðĶ%°_– b J #dfm_f—'èoIžÝÙCö{Ff"ZùðZˆQ Qõ 5rrF[$ŸŸžÓ3pe` @û‚(Zà\c±c­þVUe@XE o)À¦’(/À’Ž¢>˜d°ŠÕ`:2¢iEPû'ó¢ «øj.?H•a#íµS<@'1¬"#ÿht€ÑI°,(pbóYe+0Kj«vI_Q÷ =QCÏ–H€4 ŒÀ á'€£kM€ÂP 5 * Ò¦°e±/¨ÐßZGÇõ76ÆU±@ kÑÚz¡æ”(ö䬹Í@!–Bk7”‡Évh:°8"u2 š.;5à"pF7H0+0PP@×JÐe ððO°ˆÂ3K7r#þ#¥ãé¤"ë¤ €ž{ÉY{©÷‡!Mb˜îF¦ÐÚa!U?O‘ÄG‰"  x¾ð[…¢~ÁÀ8ç´Ð¾ '\ üÑR1'ÕÀ åÅÂvLæ˜Õx:²À¤Â£ˆZõàL3·3€9"Z€ ÐP º€pT’_У°g²ôðe7¢¤;‰$Û_Ýu;„\€žÐãKJEá7°}Øt°y_{A¦  › p!qX ò!j/à… ÃG¿ 0vN'Hp! ô0¦yb· BàhËÀv­ Wár¡Kþ:°÷×AÃÆ ›ë¡AÒ€2‘§¢•‘v1Â% ¡@GWÀªh Kj¶/B€  Q§sÈA_‰XÖÖ, ²”w;² ‰«N:“’>šãÃs•”Á …hWA…PaP˜à6Jà‘±c~ƒ/6¶ žVU7Ypÿ!@à #ðâ´ŒûRe±pêÇFu>ø˜Ae:.}™9Ü°1Òd7¡PBl§¯;HUàWÙ[6³3òs¿€‹ AÀi@¾Þ Æþƒ ;R-Ð[` ]Ìãɤ"{Ò±”.AptåüìøvÒW5 Ià&A¡ÓeØ ¾u oqº§Êh /ðÍ®(‰\\ˆò‰ÜZ¨4«˜ÔX ú ­$w)ŽPyåÃ>ØÌúÃ’! d ½>«<¸t”A %Æý«¤­‡Ð(`‰–b#Z€ [€¿Œ[Ò`œ«"“é«À¿VÏ{2Ç l|Æ ˆ2+€Ú"@‚ L;;æ ZÚ)гq¨ðñ æ*X  £Ã|sµÏ[=†’b™'"D€#Òþ‘)J¦ Iã¢e:s2"Ï XàÀ³~²ŠÀ×,pJ}›dÆi82Ò;b3p¸zÒ)-Æ´d¼”A”Ò$@!g¬ ³ZÚ1 ƒFEr¦ Hª´—YrAG}g0m8¬ð ¸°ð¡²:(g(Qš®-î* BÒv°x)wP‚QdÚTôú”±éš­e/z³U£„Å%¢Dcã`¥‘ã0ÝUÓX^ 8ÅPÐ@bˆ­gYÒƬÞL ÔÀx:`!ŒÐÀZ.@¬EP:ËZ5½Mðéª ûñgÞ;Ö?r!H¸þЭ§@¡ã …R  ®ÛTµeÍ|º1AÈ9¿¶1@ßñ$£A롨û**°(eÜÓ"*tÐrÏû;úù; •J°,æ¹;Ï<à<²CBÀf]\R 0í²ëÑ Š¹¨kGûÃF…Ðë@z±}ã 0=)Ó!Aầ` šOË8…üa |Ç7sª0mÑD›\õG§poˆvÉŠÄ9#¾9ÿ´ë.°Pàeo€WÔ >@ÃÁÐÊ&Q3’<€,ð_¶ €Hw·H—¾ dP&@7,­Ž:M¸w½ä,€>ÐUãã×£þU£È >·µ”äÀñ†ÖMÐÙ¶ð™ô”8/IÎÃ0uôGÁà­ý#]«ÚÂðì‡ e50'¤° ‹ü—¦—"b„NÃȵFÖz!oäÀ‡ ã\ƒ Á Ñ€ÔÕ¿hp IÅkpkV, 'mЩX;ű4ˆÄ<žì6ta³n£ÃdC á;ÜÞô&  µ5ße N¸à8Å•UøâÁ²Rí†R d!]WÈpÁ€™òwyN¦“ :@åpA¢1 {ŲLF’“Á¡#:è÷5&„„­¹”1eYD>:ºÊ'bI Ý¿`þ'ø#µC?Ð6¦ñðˆ‘%¿-5YlÏðK>vºëàÀ2$1åA4ÕˆÁMt)bº¡ËUòw¨@®+¬×¯Ý8§¦G‡O 3¶çÇ8†bO“¡V .ˆŠŒ‰‹5Š'L MŠ‹‡5‹$ Ž‡.$M  & "=®= ± `-B[Q++PBPiÄihXÂÄPËiRP,B,P-B`PÒBXXÊäiÃÅ 4!4^ !J! 4!!:!!*p! €‡¥˜¸@‚ ‰¢D™BñÅ.¬HþtÐåH+S8ˆà ä#¨8 ’òÉ)P IA—ƒ-5s.˜ñï߇KZ„¨è¡2U¨dC£‹F2È`ƒ#ƒˆ<p´Fˆ ±L°êÑCE+Y=&¸V€Âˆ¶kþ*†æ±"|ù’F‰ ”pKÓ¢E™XØ~’ Ê—ŠIE Ü»@ ¿Í  èW埡58uÐäÄ¥M ˆ2b‹¼°XòÈ)#LFñ"J—áºSt¢&Ê’À› ™"—v!ø#@ÃjÀ¡B+œµh œB]•(S!LêA̺2{þ–Vµ#@AÁBàâÀZký¢W_†  5MP7ÓüàË7`\¡B‚ ÈØ7+DP@çЂ^„0ƒ'zÑH0ÀXCv1øc@QB-´ã&’`±8uÜ Ã0ÆS|DQG<'c”dÅnUI‘HMqDL1EAA0„ úŒBàyPƒã1rB!C¢ÉR“ÜYxIxpI‰RYm‚$°,­ˆÐŸ£3´B¨0Á×üEA.”~#.]¼Õ‚Wä•‹^t Å.ˆqM+l † RÀÂçäÊÂhpàO¡Ïfð þTƒ!\°”$5l “ÔK ‘˜SÐ…LÆ`MÁÒLbbé%E8‘ë[H"…—t19@Oÿë Ž$1‰&C¹F‰uB{¨‰BÂD)BC)$@y“Äcþ&B…[¡ÞAr¥Rˆ@KÆ&Ì2ÁéÐaª{\€”™# ë6“¼–×ÌTÆ0¬‡xE>|ÃMÊÏ”3 ¥ÁÌàg÷|Fµ±:P}Ù¡:Àiè=uÈLÐ0Fpi´eUZ!Jmw+¶•ÁtR”ä†tDpoƒ¹)T!xÓ™¹L³8¨Ì‰c|(÷®°G£ ¿Ès‚C *8Ø EÑ‚,­è& 1¨@9[˘FPŒ\Á+ Ý2"  mÁ@ªš¨ QÐÒ€,¼c^0@Ò4“™Ј41¨BõF“ôþÀ+üâDj¶x Œ!] ˆÀ˜%0GL%q‹)2˜P‰Q¢þæ15çÌaA,05à¤a

•N×<Äbi‘šÜËÔp ^¸ÀOúaP /KímVÓ>(%7ÙŠáÖ¸æ9‚#a ësÎ: ÖtKãÁ D2Çì’ %y›Âf²‹°C€LûL¼€¢LáK$a2(ÓŒÂ)‘‹JñQA„À!‚°l«P%¸i N·"¿Ò茹¢38 ˆ ÐB3àÀ6rEŽ/pÀ?‹X2à‹¹B*à-2æŸ~Lo2:Ú>î!M- (.ÕôAAøYþ­˜’(µ±&_ ßœ€uoX¢ILÚÅ‘’l!]7¡€° µ*”€øx‡ ©«)ú=…Í/AJ=€q4ùxc†ÑH  HàÑÃ)BÊÇþrÄÂ":p\ŸPœð\ 0a$îØ]Îá#8‚J'^ä2lˆè'!IÈbƒšAHÓ|j™"Ñãz¥k i_=ˆ(qÂ]a~§È©M:V‘ž“(t¦äa’ù:'•q’1= bèx4I:û'†¯€q'5aÀ1#UK3n!ðã2VV7!ü4GôH^³Ç•hc›YÉ03‰LC(ÐuÜ‘4^ ”^€4Ld0#ÿ`„:øQŽƒH -Cƒ@ø¨Ÿ”IDQžÃ“¤I…rþɈb ~R1D“©…G™’9†’©É™gH €1‡,7"”òpTZ§‰0Âù€rüðW‚ÆY’ès÷ãFb•Fs´tαŽÊæ"ñïV¸)º¦œ™á[Ÿ‘"Jà–ö …ÃfÂ(g­Øða£€hŠ4I‚†ŠMÀ&i·Q虞.p  '`ׂvh ÇŒf¨™W“d¸¥[z™9iR´€%°,ÅGz3 MGÅ;æœH#õ |péØé8ˆ²9e@.`‚›%aenUˆ»VØ- !‚dFm) Gn™#Ì'#äkáÆTýÃkQS þ(:`ØóƒŠ0 {æWdwz'˜‹PA; (P°hàQ錳‘„ gö6a\Š™5¹ŸÍØxÍH†š‰ji¡,H,ÌD4÷L)"#ÉcA°"GF …_Y „P/ëuÈ–!(tÈ–l9^(ñ6"qZ@ƒê ©½õ+2¢A ­÷H.05ÿ€k€d9§ÇäšÀŸ41\u ˆ›E±9†à'™Pì@€2ÖZóMVq UFJ•™¥¾z™ba.ÙŒþ ”—žù™Åå€UðI”"H³r­Ö|I`Ð,úQY ²¹´%Ü•þ…˜T`a6‚ÁÑ¡]ÚT¹7ÿÀ|¾%”ïÀœ¾²4›±fS*Ÿi&Ѓ“ôF‘ s’†f˜C`ˆ š IGøÆž8' °¡žñCapTj1“'™ùé>@™0Ù«b™'eŸÐ?%€¤šã–4H£‰4¨yуµGæ€$RIú„”” AfÔ¡"AGVu`²N¸É­a4GV€o,pv"šç+™øœ™8© ŽË‚1÷™DSsÝÇ/‰0Ÿ$ L£AÑïa-EQ…À V£Šƒ‚ ³( Öv¦àÛI· »IZÑ+ó 7¸c¨þ{Ÿû÷ 9 í %P‰+ËÒddhj5)â†Ñã" È'À;‚=MXN~ƒ‚íB°tTð­Ì1Vô¨$¸t$qÝž!³KÌ©D€µMC»£ç?1`¥Qsï1b»Â ‘Š`ª4AÝYZ“©‘ Ö*gMீs CzËô 諾3‰Ÿ‡ëŸbQ²’yR²à¸¦ŠkE¥"RÌHóœÏ(B»Ê7À4@ ³nRqz!àòÈV"ú­1Á(‘•`æhä•“y5{D¾ò„À£15O%dÕ#dú°E±°›±˜“@HKªÿ:þŠ@wÑ+h4 EŽPªPI QQ“S@â«É×ê»I\™©l%ëxþ™¸=P9Ò¸ s*ò íð+gÊgz/(BÒ”œï‘¤© å„O×EXé×5>@'‚ëceÁQºŒ‚ðUÛ|óª‰÷käÖ44`uCFΣau1§4PEÑ{¼†° E‰ŒÙÉ Fh.°QC‰²éÁ#vJ•èá Щ6 yank () )); bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> kill () )); mainLoop () ;; labltk-8.06.15/examples_camltk/socketinput.ml0000644000175000017500000000422514745615735020273 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 _ = let top_w = opentk () in let text0_w = Text.create top_w [] in let entry0_w = Entry.create top_w [] in let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] in let buffer = String.create 256 in let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); Unix.listen master_socket 3; print_string "Please connect to port 6789..."; print_newline(); let (sock, _) = Unix.accept master_socket in Fileevent.add_fileinput sock (fun _ -> let n = Unix.recv sock buffer 0 (String.length buffer) [] in let txt = String.sub buffer 0 n in Text.insert text0_w (TextIndex (End, [])) txt []); let send _ = let txt = Entry.get entry0_w ^ "\n" in Entry.delete_range entry0_w (At 0) End ; Unix.send sock txt 0 (String.length txt) []; () in bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; mainLoop () labltk-8.06.15/examples_camltk/taddition.ml0000644000175000017500000000442314745615735017702 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.15/examples_camltk/text.ml0000644000175000017500000000364514745615735016714 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.15/examples_camltk/winskel.ml0000644000175000017500000000607714745615735017406 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.15/examples_labltk/0002755000175000017500000000000014745615735015366 5ustar stephstephlabltk-8.06.15/examples_labltk/.gitignore0000644000175000017500000000005614745615735017355 0ustar stephstephcalc clock demo eyes hello tetris lang taquin labltk-8.06.15/examples_labltk/Lambda2.back.gif0000644000175000017500000015030214745615735020215 0ustar stephstephGIF87ao@öïïÿßïÿßßïïïïïÿÿÿÿïºÏßÏßϪªÏšºššªºŠšºªººÃÃòÃߊš¶ŠªšuššušŠ¢¢¢ÏºÏuŠšeušeŠšq‚’’‚’ŠššuªŠŠŠªªºšuŠŠšªšUuŠeŠŠeuŠšššºÏºªªš¾¾¾ïïϺšßïºßŠšŠ}}}UeŠŠªŠUešEUuEeuEEŠUeu<<}0QaUuu0EeEUeÏߪÛÛÛ<}}÷ß²ººšªÏšeŠu‚‚‚‚}}euuuuuušuEeešªŠUueºÏšuŠuUeeªºŠ]]]ϺªÏÏŠªŠš¾¾}ßïšIAIºªuŠuuEUEE0EuªešºeeUUÓ¶ŽššeŠªEªºEºßeªÏußßuŠŠUuuEšŠuešEUu00E 0 ÿßïUUUïÿªuee 0,o@þ€‚…ƒ‡†‰ƒ„„‹ŒŽ“’“–—˜™˜•Ž‡“”Šˆ‰¦¦Ÿª’Š®¯…¬°³´†Š¹¹·»¼¿ÀÁÁµµ¤³²²†ÄÌͯ˱§ÏŒž«™œšÚÛ–œ‚ž‘•¢ÆÊá¨ÔßÖßÕÎ¥Ðíν¶º¼‚Â÷øòð±ì°ÈïÑö ¨Œ`%Dبq#µT·ƒ­©£¥*™Á‹´ÌÊDZ£Çaº|Ù“§Ïž4Œ(Sª<—ª_ËuéƤT ]Å‚åøYD©q%Æ^ |zÏä.‘G}*%X¯äRŠéÎÍìîR6t£>¤Zê©×x…ˆŠûËV"§_Ó¢­—VjVVþ[­*LH“f6~×*&Øö)Û°MÉ Û÷+I¶Ã ïãk-Õ:s]A‹ÔO±eZ@“Ž*t°g¤FÚ-줯²¨5_†*ù¥CiäPT¸º6¬ÌúÄvö,´jÕhýâvdÓ߶ý¹kYù™lØ£¶cœÉá¼³ã;+ZiðçÑ ²úÊeÔ³;i^8wÀ§µËÏwvj¹ÑƒVø‘×ÙGœWnY ¤jvŠè~#a9fœòñ(æ}ŠjŸY^Vé&¦—š™ê}“>çé­úmê&pzŽÚ+©ÚŸdH™¸ †¦–y%Lú*'®ÐZVd|1kmo‹úZ'¨œŠ—,›ÇqI_´ä¶•_‰¯~ûk>4z-¸±â²E†W_ª‡Áªê«Ï²¥Ì@ÊT¹Q¸ê»;Ú¬©K˜Œ]á°Wþl$›ª&¬ñg óÙð|ÿzwg·sÚ9ä™Wüž¥ñnìòÆÇiÛ‰˜Õ ¦o%«òjøŽ³—ºõø2Ìûy(~‚eäŠ;‡ºRÓÔ {,©íòâîÐ-;Ô·?F+L3ò7Ï…ëöæ´NC*a±œNír»>V-7Ö„%è0oi¸¶x-ŽJ6ÍN3mï¶9“Ü,}e(ÔÕ¹,Þ8ÜŒÓ-9Yyÿ·7Ù¡Âû÷ŽhoŽÝªó®Üg⌹ã¦C>ùêٱڹɎf]˜Â+k›fxÙ¦z[¥íÎÎWõ=ª£nzê¬'wí¬0Ô£éy7ÈÿÚ,ÛY‹ù±Æ.ùÜþÇ{¿ÜÊ—¸ìOì!§<)ƒ|V+'ðŠÞ¬}öuËŸ¥øV[Ýøª{œ»"g¾¢•,G5›Fåìôi NlmCR¯~3µúT+RSÐô‚ ïõ/€äk\0ÈÁѯ€<’hrv²Y Ë‚I ûÒ–¯’n0LãäV¼òðxüHÀÛ¡rý œ°~çåi-¹éŽ„ÂÓ3Iylr9¤ÛéB(Âáù¯‡Ããaȱ&ŽM…Lœ­XÅ4Ù1¨N¡»à%—E¬mÑ‹á‹›AÈ?2þHj¯»Ó‰¤D}ès)¼áü|æÇŠxáâ#ƒˆÇF–JQÆú]þ)½Sí*,Ü (-¹±þ¯{`¼šÉÆÔ­ò‡¿øŸ#II"Þý…[@ßÃ(Õ-%¦}´,`+»×ÁzQDx c+ƒ9"ì5˜Çyã³|ƶHÝ̆|3#QÒø7*rRyc,&òNéCÇí‘•ß;e+‰ÂpÖr›ÝÌÓG˜ešê -žÌÌ2M¹N ¦“•“ôß»Ü9u \¢ÔTS£KhvÍžïê±& ¼:擈Bb])P¡u>œe,9ªQäé.^ fÛêI¿ÃÍq›EÓæö%Ï‹~äŸËìbMÊ™ ¼2 @Í£,cYćÊÔ¢[£g¦Š’¥:ŽR‡ìŒ¤‘9þÒÇñ4¨ÝhTƒbÒñÕªbÔé8¿èÊŒrT–pC£¦\U8Ýe®–üº½nY7˜Öy®riMS:´­–ΘÂS§ñHÚǹ™£á£¤¶0¸,e­4s»”!æÚºûQšSú¦eÆE¯Â©’õiV‘éYq¦óƒV-«*J¶bLTJuV²ÞjÄ"¬K±-0õG5ÀFu§éh¯Ú¿!†ÓƒD5,r«Zã§à#]< ´Pñv‚6Å[dzÃs>•þ,#ÙÓ‘0µÅ3îøþ)Tè.—kû:œ^Ku]je·ŒcAjUÅëÝŸös¨ÿ£;ãVÖ¯عë=­øÜkRþÖÆîl\»¬…töÖl^ëgKl«mM˜0ÀÜ=n¨zSr&§uo» ™¤ØáŽY\*ªô¥_k¥ëcö½/gvHRñ ×´ûU¯gÑš`è6—ÁVôݽrL[hj6V+¬1dTCrÅ­ª:SûÅþ28­»3X\¥L9n¢P·øµ²G×IÀcò4½¦$'@ÉšâçÙÈ‹ä°ŽÔÌgÖ öÊ9 o ­ÓWòÏ*N4tw„F¼®4wúo##Œ¿`õY‹]-gaï¬è=2ºµ'V¢ÜÖ°Þ‘9¢ï$ue/Ý×L+sÓN´éT˜A–å—Õ¸ö3oB+N6/˜Ó Žµ‘·zÀ˜þUd•îó±Ûùg@“6Ë»öpG,ìj+úKö€¼Nk`Iô¾åŒ6°Ž™Jö¾ú´À–d.´m×n»[K~ír)IŽWÐ$ô±yÃ:Na7WµéfÙ9:·'+…ÛVÞà²_fbW£V°ìí·ŠÁºÓ‚ºZÎÖ¾6˜º :!üÝD£_‡1þëû³Ú7p¯O.ët“üŸ8ô¬mØñ6}ä ‹q_I~`²¾|âWyŽî–+:æšž¹dyÕLœ;ý£ˆ-r°3®îfûU•éXÛå pæ,Œ¢ôt^Ó§Ó·‘Ä rŠÏúSªÚ*-:ƒXàbÚ¹ß_ïÌ(ñiö¾¯þü£>ò¿•{íÁg´Ùü¥;ºLm¶÷ׯDýNyò²™]y—yãÏ[÷¿ë†Ä\߯9 OXÔ)oåm|Ä!'>é]®WãÕ¯s÷ߥ·=µ¿œÎÓR~ª_=©nŽåGòö`}3ÝùÛ]™ºwùã å,߷·¸öôê’º¹êý,ôŸó­is&^üæF/Š§ŽbÀÉÕÉŠÃjöI¹Åâ–îêÍ2¯ñO¼a’ÛÐxmöRñg|g5ÙU~ÉgÄ¥QœçyÐZôÖ}nWm¸µa?’Lû‡€Ì´ç·~¹w€'k‹ÓdO¦èLËÅe\•LjþÇ\ ø€òVgv&l§j˜çÃÄ ‡vÂc`<–ozuvqÒ×i;˜‚ü7b]„×'9,¸rfwúv„jgnr¶„…wTugp^G”CJ…$8! p † à†PãpHă*Xb“”vkç€CåüÅ?»ç…»—hMÆt w]¿ÄT4·.ª±€ ðœxð‰0ð€  pàXàb=8gµJ%å}³çfòFu89®ãqAÈ:SXj0††À‰P”hpð Ò °‰þ`ðÞøŒ lXiÃ؃CRWÖ+r×k¼×i¥ç^ÝÄ/-ˆlº ßø‰0רŸ¨šèßxšš š0ß(Ž¥Ø ¢à p‘ `àl8‘|oä¥Gá…ÉGD™çeÈ‹esX÷ u؆ 𠚸`¤þŠ Û(YùPš¨#0 `‘ €Éù %PÀÀ‰'P‡“s\÷gäçk+Y0‰Cæx p™•!pty•XÙ0`”W¹‰@”ÒX‰ÉPþ‰ÛxÏøŽ¢8ЋiÀsxŽççŽåv€…8w—whiimk¹]¤&ð–q©sY— ùYÙ˜{y”J‰Œ€)˜ßXŠ†I—‰ ŽŒ™—9‘9™•9PFèešix/˜’D÷™¦—.–™k8 ‹©;Ù“ÎÈ—WéÕX‰p‰#" U¹“DÉšÓ˜•ÒHŠY”JÍØŒÀ0ŒÍh”0 Ðs( #) ‘é°‡çxÃöCVr{ÊkÁšKuÀ"à HŠ™¡:˜0ß™X¹ž«™•*É¡J©U‰ŸïùþÀŒï™‰¥È‰œ¸‘€Ç8Ž©ÁÙ[FZì× ‡Ø~½(¤ל‹h64© P(ºšXùI‰Ú¥v‰›Yy¢ŸøŸø@”C©Õh”ï£ gz•ÐH£œÈŠx4ªÐj¤9ØU†ˆ§(w Сzö¥é ŠÒ8ŽŠ{¹—í ãIžy7Y›*Z•ð¤x¢>iŸ÷y `¦ÙŒtYŠMI£~ÉŠ±y‘$`wR§œîès{ʧLHzhi¬Ö†¢pŒþH—Øx©Î˜‰žà”áùp¨!P•&  !{Y—0­þ¥šŒèy—£zâÉ,p­1ÊŒz­‡Ùž›H£0Cš–³J«iÙ„/¹j—¦«À«y¿Ú¢ÂJ¬ÆŠ¬" ¬Ìꬥ­ÒJ­êª‰×ššM©­‡š¢Ýú­áڬ͸˜×ù抮 yÀ®஺7}Ÿ9¯ôª–Þ¨AûŸÖ¸žùX)|¹˜!@”}©”Ué×j”&ê¡ , ) 0­F©´í©+¦‡éž ª¦™x¦jš¨ Àê‰ù¦›Z À P§—²f{¶ßó~“v¨‘ `Oz¡ˆ9¢ÒžšøšJ9¥“êžâɨ+Ðþ¡ßžI‹¦È:±‰‰ªà²YŠ‰Ú¸ÀŒ‘Y¹F©±Îx¸ï™•šÈ‰ÀÏ(ŠÉQ¤h›º Š‚2£l€£Œ€©Ïˆ›»8ŽY›8 ŽDk”កÃË ,ð/ªE+µ<Û¢¡¸¥uK¹ï)žÌ˜¦T{¦y ª¤ú¹ÒèJ¹¢x3©ºêk¤²EQº=Úu[vˆŠéù“ ±ú¢ÍZ°)ª¿ ¢8 ­0­Ã*;¬DË2@¬À¼I10Àâ ›àšš÷¹¬¬I£N9” £à[¹ÍH´.@Ái.þ¹˜*\ª”º˜ð‰ À®0‘ë{ÃT'CvÅWË“j9·¯¢¸œÈ›¨¢¬ÉŠ»ëé¢FÛž×êàŠiÊÂDûE¤¸¼3À¼1@ 1Àc ‘ÉIªÍ¨JÙ¥èE{¦•›¦©Â€Æjú±þš·Š-*Žsª€Ã† Í„¤0SÀ‰ÚiFÛ¹íy´áÈŠêŠz´ëG‹¸šØ¸Ü«‹“0]ü0ÁÜ‹Æ1мàÚ¼Îèɪšyù¢ Û“í™Â‹˜J®U©ž ‘\¹0\•Þ(³)ê•jhÇÜÌêvvùÊÈŽìþl¦G¹áYÉ—œ¨J¬ÓÊÉ„ûÀÝȽ~ëžÓJʦ̼© « ­œÀ°\²\°´<¶¼¸¬‰ºÜÂ}éË9³ú8Ì‘‰Ç±Éì†ÌìÌÍ̺Þ6.ŒQ)8Z®y<¼H;ÂiZ¹Yi¦lÑÃü‹•Í:#ýÊX¬Çˆk6p¦|Ê,P5À¼ ®7‰›fº”ßH3륟˜¡‹Ù÷ɽG ÊR«¦ÎhÆ‘9¬U{› ©È‰4Œº M¯,[¥¹‰Z° \°c¼˜>ëŒÊ ®‡ÚÕ iÓ‹¨ÓÙžH 8 ªáIÆîŒÊ0°À–¸Çë·&ý6 þÇ4-6;—Å«“ ˜e=Ô.±ýꞟ,ž¼Â:ùÉžë—µ¡hŠ!Ë®mHÕU «W- €­°É8­.ð­ˆË¿m}®€ ì·;­÷™¨4í·#ÝĬÇ" ýZ¨ú¨»p!À0ðbŒÅcÍÉ¿Žˆ¹ÇMÙ”wYȨšÇ¾uyžÛ±ø ÃJ9Š4ªŸ pãñÙ´zÕ· Õt©““Á{,à°!ªŒôÍÛû•Ë¼È´\°PýJ×X p'@ÕY…º¯ÜÊ+Vº·Û­Ü«®3z‰ûX”´ë°¤ª”™xïiÇ÷þ9˜íÔ•;£p¼‰PÙê¥Þا^ÿ¨êÍËê]°ë{³žæà)·¹n´ŸLÅ ¿Î±Ê¨Ô]ìÊxìÛ˜ìw¹ì…ÜuÎkØu™v«Ìd‡¢Û¿Üìà”š¦â™š;I;éþ‹˜e:­쯡hê$ Šð€8 år;å nD+Æc\´ù¢©š;›³ÍÈŠÓÉŠÚ]—yì½ÞhÌÄ.Ƶñ)»°±ɉñ9àü)–QWñ׌G>/bè.#3‰b›Œü«‰6óÝ·þ´ß¦\Às©¢ÁM¬°5±;‰“Ÿh³<ðÀŸ=pŽ®ø 8ø >Ö¨\çNi¥ ¬Ñè©­ ºoj—¢ßج™Î³}[ìK—G©´ÝØÄñ½QÊùI¾Ÿ;Žû"|`a×¾}n`¨Áà @ŠØáD !F`F ø"xêWÒcÄ]3!*„hf"V»F¸ÀâÅ \Ä ja«QJmhB(XP5mEéB¥ .šVJõÀ‰Ñ”™=‹–¸lÏ€uÛV .3¹ÕÚ®õ€š€F‘{'"jÕIò]pá¢Æ©vï6X@÷®‹“™~ZÈ„¿æ þ”rd.*É|>ìzØ!A GzˆÜ׸áBsjúbåå™\NeŸº>,š@HŸÔ¨‘ ^øC(» 1걈ÎÓOG’=¸ ªË_G¨T¯‡¥“îb`à@Úùô­µ&®Û·úõ7Óv^zñUÊ è¸$*…E‚˜b0ÆÙcJF™:–a–Òf}Æ™rµEPÚi¤¶Z­½vg²EE›m¸éf¡:¾5Ü#Äi`Ü"ɉ6È>À=GtšTWvÚ}Ö!à¥2R,9‚ ê±7H{ïÅW_–YÈe—^~‰èâ :¥Ô¶“”XR Ýóèþ<(H+PZÇ‚ "€` ÏÅàfŠnpÑH$E%Tº¬6„ª?‰~ÄÝu3¤”*Úiâ‰X²‹»ìÒ^{HA~÷wd:£HhAd B=Î-Ñ _eA%­H2K{ˆLÀ@þ βB/Ó%´Ü--5yM€8â8°â›‹mƈý´SÁ +°c & Î;Ý:˜Ôƒ 0ÔsvæŒByæö£ ¾#R }`Bm"¹Ò5öh†ðhà¼`ƒP/À:!0.&,ì‰ *»TEÓ( rñ¼Ä?¥ìƒŸX—,U!ÆÂ&Öu›1-õÀ> 3Ý‚È$ 4 ?=´–à t˜¿4Ž€á4Ý´ 8àÀ¨›í3Á!\wròÖ-Vr‚"ñyïtÉxr¶âï‚ÆP¢“NBÒ¡ÙŠðI¼ÖAþ=¸&hý&…ô !é“Afê1þƒ×­BM[Äi…-ŒDd'—)ÈcD7®NT‚uZé„œ(aKøˆ)Ob ì ¡ñÜä&‡8Π॥x4\ËÒ¸Á<æ9 '2›“…áàh!ðŒA †'U¬  í¹‡vç(N@‡=¨FwÔæLçsT‹˜/ƒ%ê5`pà7ˆ$8¤Z‡‡>%(žhÙ $#+* Ø…ß¾ÕªQ؃)ÚâШ‚UFV•ÊûИr ¡O0¥)V©H±¡ç?2dV ?É%qŒã…TÄ… ‡ì+cÙÚLÂÇì¨C”ÀDëx „ÆkE øA¨þéñ£} )Õh©‘lfŒØÁ ’Ôæ!°Ê*µ’¯üG,3AËËtê–¹Ü%S¼öKЄFÃŒ_èŽY‘dnD iæ3£9ÍÑ4çšÙ´SC¸éMp¦gœ“kÙäÎ Éœb~kg*JO“ͳ õ$?OÖ—ŸŠl36ÓJË,¬TU(CªˆªµÍ 9¾âŽ¤&uM¯tĤ° xþ¼›òä‡Ä˜:Žºãˆèð„vZ2¯mS £Š6³Gx!E Z¶§thBŽºz¤A¸ ô¬ÂNu’PS.Ç9 @”gíäñÖJÃæ9 z`8.àC49GŽâµ´€$­zo  l²í4SPš_y×Q¦Ñ ‚@f5Ç p€Åè×L '¨i/H :æˆDoÊGL­Æ¾ðð)r¬èf=Ná ×&¥39Î!4çΟþ|Œã.sžþ4QW0±Ç¦ sMæ¯.ˆUž)@€!Z¯‹<¦åeÉJfò “å1/)`À°€JÔ‘£H ‰ÓØxrªâU`NÈÓ*“EÌÞ\Æ\tKU¼fÜ>«ˆP(ÚæOÇX›D} #¯Ál¾ ²YC0$ è§èŠø!.qõP_Qµ†^gsªÉ.F`=Hl¥Ÿ ‚ÀRâÎ쬈aîÀ€Y±Þ¸"^±œI±Bïð †ÉR3žeì~C” X@•PQT…HLž@ïCp±°„¯ŽƒŒ&äuÊWz¢Í+8Õ¼üQ>ñ@b|ùé<2)LµþOdwLòLyj Ðüé.€BwFxÉèÈg0΄Æ#™Á óœ‘fú¯ïœ$ò‘㔀¶Ógt¼Í*’Bâ™CÕ#÷9Â})ùs!ÆT‚f†x@ªR x†‘ÑÒ `‡×í¹7œõk4à»ë!s=l¹'»Þ8¸ïE;$БV¡›êÀeAÂ's€ 5pzL>ø× d`Ró˜]ØmS‚‘ìÐj>VzŽñ7_Œ¾ v@tä‰CÐò ðå”yý?Dðvub“;•0°Š: ‚b~lê!ŠU¥m„Fð²j¥ã?Ey\[þú(A ¡(¦ŒºÌW£LÌDðn 8ͧxRç_â½ Ç1 `¥'ÖÅ.”Ô¯ סŠ­h€ÑÀDê@ÑŠºÞxëÇ”˜œ¶L–ÌÉ[µ¹H³®nloŒj€_ã+;¯yç $´Mò^÷ó'ª¥ððèFÏ]) °8™!G«€ ›à ›° Áq+˜ƒ11ƒ`A,&:†t`cüðŠÒ‰â’p ~t ­pN˜‰ t†`b`-Þe 0dÏãÀt¾×%88lÀ'ÂG| `|›À.ËW#à|Š É¥ Ôg}“}56Ýçpþàâ‡5ïP~$¡Áêw;®mîçð‡òG–bø·w ±•rþwk˜-x6)Q€"…€¢p| X9SF¦ÒHr[%:x ¸$„á½ô ¥‚Y”ãÂ9(H *XY°ç‚ Å6ƒÐcƒÒÀ<Ë“d¤l9”d£¨dnµ4Ìó]4á9 °8BaXÖ6 ^ªå .©Åcäî>á’ônx>ïˆð,ó=¢em ²‘ˆ`aò!oh)Uƒ= o¡ñJ—hpŒ– ^¡ñEOÁ ¤GèùN/@4p6³3 ‘3þ1.VTQDÙ£p ¡ ß±q}Å·Ffæao.ö0€“àaõ 0 „€‚°À‚ºp÷‚z¬‚e+tP`VlÕs7ÔŠ¿vŠàbs"PÛáebÀqcè%(cd ç@gv•usóE¤ þ·*3"©Áo_3) ¡"Žr¢La03–Ñwˆ7€Q‹[æ2ud1„°*?F¶ 9Á™ÍOSÅQ’$*ƒ5+¨`T°ƒy„ €y› XaPÅ —WY(y•UŠO¦ŠÈ³d2›¨˜CÀglƒ¥KÄDIñCíÆW–¹=Õy }"'uTGC y™@>SgKþÕy‹js1õ!“uJ?ä}ضR¯ö6¡×fy((à>4¶ 2"zG}µáËÄd‡o7–¯±…Ï‘8Ò!2z_ÿ°#€r2¡ €13Ñ:§3‘Ž³}!3‘Z:•(Ρz’á ëQG¢’i™yõE2U2IJ#ƒ‚ƒáÞ6Šd¨l­ˆŠã@s>3t×òH1ÁåxÄá{·S»ÀWå„'ËVGîPNʬ`|Àj™!y&„”–yv¡”Q©6U4/ù L,Bc¡WSùs?‚r»`húwùÐW1$–vŠa›ñ£4%ULhJþvœñôÀ‰“‘Ó2 Ðm‰T?îP*ŽòGóä2› ¤ O>q€:Ž0ˆ1ŽÚx5ã5ÙR*¹PH£ùŠ–*ˆÐ¢àªÉãª0:›7:s¾ã3€«ºú«¹5”ñ¬Â ¤…eTÖ¬Ûö Ëšà¬ÐØ1­·Ô”üi¯èæ ÚŠ¦Zøl®"®í™–æèÊcT0íï¯o´¯SÙ„¯éª~Яõ°4 °ÙQ°¡‡°aC K9 U ·†y_›ñœ“TV¥Û-+*´v9†÷\Ør²ßQ,H¶<-i£6ð< €Ÿ þð•;Y&¡ð>ýðÚ™mS×25`Xy¢.·dT2‚¡"€P‘ªjò dB!Ч,»à÷7QQ§ìh\‰=~æ¶ò#g„æ÷5}µ–5ÒË$o —áFd ßªX³V?´¨>/ '¸+I„Ç*ë`˜÷²*¦á¶à ’!K¤à¤ÀA(U12u2:h'!Þ+b79”RšÉaPZE)÷²„öÍ“{5:£¦h£Ð å³+Y^Â9N™Ð å„ Ïimy¢ é»e¶4“Ã.ó¬Û”êÀWû5rržóù0L仢„®Uc`ëeYE¼X*5Lþ¥×#þm÷q?ëØ~·FŽupçFŸ^RÁ7 8U÷ì@5ñˆô[^Q5st³ržøe¿É˜G2‘ça ;*¥0xçá@„;l2Æ&È‚Šv-à]c!ÁÍsu À3}ÜXÑ‹EI ¢•Ð.K·¼—œÃ;uF Â-s+€t´Û.$ÕZ¾ø'•’$1¥àÄð &æáŒÑ €QEƒ×lÚ8pãÊp—(q ³qÁ¦&/"¡{†‹…=怮:5Æä6ý(A0¤§³=ÕD¡¢ # íÔ9F¡¢3¬Ê ÙIüÀ"·bIÒU!=’àþ9Så¥rÐYw/  Ðc¨õƒ=d–žâu*’¬…í¤"€AIRج5 …‰Z}Št>K¼Šá…Ê!<*ãׇVØ5J—É;/g“¯a9P¶ûÊ­hוàÁg\èQÅŒa‹Ö*PÄTÌOwªÒ‹ÅgÛÛw·A$ªv=ZÁ&‹›iºà¦f‚ šó$#»¢]­¦Ú‚NúðÕ£€z‚ ´h3} ;SšxŒ’„û*P¢u±Ë«Ô§¤*dÆu$L»ÚÖ-e’pá²Ê7¾ª jž 7à Ö\N‰×“>  -\!ü׋±¤cOþZFçyÌ8 ܪŸ,R?i93¾d·¼%!X»@l'žŒf–’ào±KVó?cLŽéê? `’Ã'ÁjË(† §T µ@I;na "u€WñQ‘ÊQfÚ²ÔÙA¸ž žùS_a¢'˜;§Ófa–Ç×47ÓøE‘(? F m”@뺸”÷ ‹ØôaâÃ2B¼QZuËš'@`|z".+à“©À.ªÒGç«É*G\wÎãÒ2ÐnžfÞJÚyU"‘ó7hz Q²Î8/¤UÚ3v­Ýè ¬¯–in´À¶f)ˆÚ1êu¹ £ÝQ–ý¾ {%,cûþÖ-Õü&2¢—"*M WŤÛI…5fý IÁP,7ÁR|ÁÞÏfË<ßæÂô½5õÀWÏ©Ûà ËÖßÒÞ”Þ2$Î2> N ÐàÖy®ÙÝ2á× –¾á‰z5…Åáç` ZØw#ℶ*zyaâÆ­+Nã€F/ãl*AãK¸|ÄQìŠã ^<Þã ð㎳lÕ)Õ•àQM¤“¸€äsB+ÀäÍáähÇQ.'S¾V3e|ßQɉäå*æ›Qžg\W£â Á´âõÑ |Á]TÄûD·”šð|Q2Aé8Ç'Z£àøþm+€MC nŽ­'híدä³C>IuEàš5Ïv‰”Ì°n`¯Î7‚˜œžé”g+öª7"ñ($m‰ y™˜:é°\xߘ—sç(õp5€v±Œx}ªß¯@³e‚LÇcH–íq+5LJt:!ƒ;„DŽn ›ðâM榪ý Gö€ ÒYDCi.p[bé@¼âØRJè…•œ‘Ñ*1 ±">ÀuSÊPTÓç@.é¢ê.y!ëˆÜQu¢VìF¨×8¢¤føàŠÐÎÕûµ "(ÔÈ"^è$Õ¡¢Œµà[©°AŽñ\€n¸žŠ0Ñ£G…嚸QO€•Žo|b~‰¨F æ8ðnt³Å &$®5(B;üÀ$E¹I¬@ø›’™ e€ƒë(VV$À;BlKK¿{ D"Ž‚þ¢XJÙ ìB°|B|­Îr¡¥¶Ä°cäÐJ°ÃB¨ 5§l@Pð#4h†|”†’B8´\ä±Á np `gg0Ê3zÆŒºç(þaIFaà4œM*±@„ $€X+*Ü™‰/SŠP”ŠbE8þ÷¿u="Š1IªBJ—´+¯‘ :æ!ÎñÂZXJE ùPèGK2Š—œœR“ 9é©òŸ4Q'§Â€Qz¬`?u`²“1k“ˆ—‘´²©0ð3y”F¸'d, :IŠ ð–±möÕ ÛE<èR†pG*#’3yA!l1žÜG?*ydº•5rU°$-äü¶ã ˆå„± ßbõK×é­Sj&Á§$•(T` ¡+yª"b U®n'’Ø!‡o’1•}Åä­GÊk"zR™F.RÁShU0n]hÁ„XÅœe$1+Èé5C6½ØCGE1cò“¼AkYÌ aS¶H±d`Q¢bÉ ip ³L›v£:಄ÄU|ª2Šr“`È«²]D Æ2 ñ]¿“”9¶²•V!ülýlȉ´.x)®@ºž#¦;w›ªÀXÜ-ÊÕÔB†¶´=ÐR}äæ Í`-ÉS ,a.6aQg¤X•ðVYrM¼¡{ß5MDk ‹:š”Bß“ Úà $QyŸP*Ðÿ¢ ²EG!Uq.ëð½4N½T+P2òÂ@ÛbX]CVŠ`815¡ ôânPe¦Ð€0²F=Wáq9Áj‚ @L1àw•]†ÑJéq$Å|„ *ÐN£¾ðAȳR8Ñ4Ò ÁtÝáþFæcc1D a”+l@1<.2°’†sgPs&tX!}HI  Çàw À@PC÷)/ðGÀöTí%>K¡Á>žr+u ‚AŠc0ßÀW¯à{¤'%Ð 4`—U+E2$0T2E@<` ˆðá±€ñ 2¡‰Á]°R†… ¦7€T$!ez¡g„xüå°ä>ñm÷nEÀ §­²8³”-R¶fæ uäPL§†2)ÏåPØçP/ðHZátáÒ!‘4÷± è15™·/ð‰Èðsá€rÜþ1G**ðL7)rÖ +äV$w®‘ÅdpáÃ,iFxIp€>PÿtPbGF7U>°FV³¢ƒ§ÅP7ª7¡™Ø• à3‚ThäGIÐ<ðù‘%P–™Hy… (+Åòm?Bñ+ #(a+A/D¢X‡å!žòpTB1 K±ZŽP1¤-W£Q0J/0&÷òƒP:©O‹°1™½ö!Àtyv!•l‘d d5š)U–yF—4ù=5P'” mT_"äž·M“7ûñPþÀ3‘4qCc”Åtë§ s yÔ“R"-0…F]IC€‚òu$@T1ëy-é°UdI„EÓ!Ð!à_!`ßã=ËЛ?;‰]¤w Ð!hùŽæ‚¡¨‚ÄAZ¡âÅ'r×b~1¸$Ý‘Et±-+u/+•nã€0@]œDZVä>,ÕŠâdÆh-¢  /915­YÙx#âáŸÉ”Ùù*‰¤=ƒW˜~2)õXø¥ < Iep‡§Š¹¥4©”‹Ü`R…jˆP²Õw$’yGáBšTE@¾8Q":ÇþtÊðH\¥ÖÇt_ŠjD“žPÙrJûÆ52x86E†þ#Atg†!P›\õ̓} Záœ*¹|­eŠ óð)¾bÔ#rÇò<—rxˆ0p¥ªE1z!O" ?=Ðkh©«Ò±Lûe ¶ðÀU ÐE~¢´£=Z¬[Œ ¤>pEŠ}K–¤kåÕ¤ŒÒ5FFlSŠUj„Í€¥‹ ¥¯â˜.¤BYt…@¦7`¦“ÉlŠ ¦À¦n*tdrŠ”u:,§ §¤Â§RÕ!ŠŽ‚z„šzxq¨é¨÷I]ŒêçáÊ’ê)”j©"þ€©¤©©Þ.žº  zUzÑŠA¦Z,é ªÊªÏ’×Ю5 «WS«#p«¹* ùÁVŽ¥(¿Âê ^á)4 [ÅðTÉ _ÀRAàˆ¤ku@9˜•F8m…ôŸ…}‚t Á¸W›U mˆÈ!ùu)’žÞ…°5 ”†&QŒ†ÂP“‚>Е‘é¡£‘äÏúGù¥?"€–`«Q…=5€Dh„N‘€W¢ë3iR,’À9©_ú… EœaéÛWy3AEp­_¬ÒzÖr[ÜñTW’Jöpw ¡h”²*$suu¡%´ø ~¡þ …?° ²SŠ@£wÔk¨Ð ιzêŸOEzŸåQ!¥§Ëp*•‘/ ‹p k—Ù…Z:ç= H”´F¥ 4å7÷¯ã2E…Äž"ª4-ЙHZnfw÷1.+åp`’"w\Ww x¨>‘vA k9*­EµIågŽRUX•–X±Ç ªðf,åñ¶QkVhÉDQyåÃиV[ öG÷ðº`f§‘<"Ñ<aÄ}zôñ^á /J œÜ¡’Ð剈 úïõ{@†dHè½è‹u5åO?G"1<2`þ²RW#ŸèQ&AH”d-XB»kõ¥›_Æ )ëñ}…ÃãN!Nö–vëq 1ü´\hÇ·70 ‘ÐÔð¶x¤@° 'ˆá’* (q…HÐ!WÃ]ìÅ9Ò‘-:8¸¶.éõK5´õŸq”‘~ÇQtœ[D¬) ác¡·ßÑñ ûßã)¹¢²*1GÄ’<Ê¿P ¥2ȉðc‰ŸrPºG]·@rdxÊÁ°¸¿É…Ð ÿ”š)ò\xäà³oaJRTÁYD0Ðpô¦m´i tiG>?w´ÆKy+!¶À&þ– xI¹·”703Pò³ZÞÜáp-pˆhéôƎšU.ß|U¿$Ë«pMÝqÊ$Ä7R† ›”a>a,±‡I ®Gc<Ö2^‡á¡}ÿ5`†Š…& fªÖë ¢±›†ŸñP€7;æPHhÅ´‰èlÒ ÜQt«ˆƒ!_@ 3С¤çû+úP9‡ N—ÏøN‘ûGtKØry|L‡‹€}Éó4@;#5Ûef´¢q^ÑëZ‘èQ(¡s¿¶Z˜r@ ÑŸÒ È9TyO1)äõ#wuÔ!-å6¤YƒfÚÂ(Z¤×Œã¥þ;%è|ûÆ׈|ËE$BçÉ´PÆÓ4°Õ¥±îñ*2øØ Ú9òÌ#ñ™€>18m 5)øU yŸ0µ*%*+!ÝÝPtý´Ïà*©´I-ò´·•_̶Â@ØÕ>ðò½OuøH*xˆ€º¢4Zü>ù/#€‹†ÜQoðØÉééòåP-òšzq Ž­7ä@?ð“DFg·™K'[¾avÀBS»´äÙ2BÞ¼Z •Àæ[M†±3kWþ @P6p#³°‘âͱÄ*âí"!27™mÒä¶f¡_©DßÖ¢¤]9wTèZQŠ ÀæFS¼ô¤¡†â‘à!õP ž"~PJ1áþšþ¤Y’Âá(qJ}*Óö@â `â†}*Κ¢B§/I2^ëlã*€ã:¾›üÊ?¾‰øélQ^4F~SINáMþä åàR*TÎVykc!´å¹ ×óå^æ21æe¾=;ÇdLªlîæp~N2çY/ñ)xzÎ|>w~Þ¶’a'Aè$³V‡.Š®kÒèÜé÷(Ù rßY™©)ŒþF*ÝÀlð÷QDgfV]ž©ÔPÓâ_6¡ÙÃH”†¸&¬ï„›Gö|* ù¬ Á7àäÍ€>Ù<ЕÙ»\Ïç<µ £t!NAS›7 <‰_0$²À¶ ”‚s7$Ö`î!ìÂ<ࢠN¦(ŸæMéüÂËp€ÖÒŸ8tC×å¡ ©"Ù4Î2Àæö Põô¥2wòs%tšú‘Þô,2Y.Òx¬7·Z¾@/u(>åfWdQÊò‘Á-Ÿ‘›!Õ_V:°…v¤«†Rk´4‰Ý_ ?XA§Ü‚ZTa—âQF|<;YP,0’ó푵÷iwþÉò‘ª»‰>Ù!%+ +É›d}Ï÷¡ÔÒ>Û†¸1ð†ðô04A,_Ø,šËe›™E2‡ ÌÜàÂ×~ømŽQl 6Þ—µñÝ™¬˜‘”}-:HëàÓ ¬¯E€"Ø!!!!h(ÑIXØ’á"RcX(âØò¡Yób*#£ÊRQ©¢¡bè!ˆXùA[S£Áâ+è"B*LŠé(Á’úÂò "(âã“)r*S£"«áQMëè#ááÑú1+¡¢¢®R¤!‚úrCäÓ/¢a"@øp§AÂGý|ü¨á!Þ„%2n¨ÚþtéP¸ ¸ÔZ/Ä8êJ–Ô€Yˆ AÔiÁ²‚„,X®!U´ÉÀ‰²Rwb Œp¡ÂQg ¢KC9ZŠ$ÛdˆÅÓ  E`ÕÈÃ…½(ªU$¹ Ô6@xj¨]‡¥„0Õxz™Ks‘I"Ø"‚.K*u€0÷)*o"Tù5ÎC… Ž‰˜¥¡Â4œ<`MwïT ¨Té0„ÓPˆcæ0½ AÄ_¾@€ÖB]Mc[;¥óÀ"\An©RÂE5x˜Ad¢Bƒ§"„‡~-ÝR$üÒ8E€¥q Q\æ3ºbÚ¦%a*Óäáþß]sNQËQ~Ù¦Ž >à´'0Á(a²<H²QêÉp@FIÀ 1Fl#5ØÖˆ‚"óÂE"- -·¥ÆÜ_o f AÔÃ!EP·” Ò‚s!ÀC2MXAi…ÀÊ0ÈÏ#iå22¤‡R,‚±'’ ƒ)w‚Õ5ªè#\{A¼F 5d³_†·aÄ#% ’mF¨BƒÖ#õÁ$òÖœ5*Q!Š„ž,¥²Š7/È ‹½˜K,ÓœåJoI ÓS‹|Ù˜˜æ”éÙû„(Áš4´ù¦0‚ÈéË!uj·jy‚°§ }’è ‹`hDˆ*êì¶O…ðh¤“fW饙B²i‰qyŠq3ȤL›Y§Fè骭ª&Žv±ÎZë­¹îÚ«5À–)ð" )²Ê2 N8GëÁ´ÄX‹­UÚrëå·W:".¹æ¢«.qíªð.9ò&GïˆÜ›þﾂ­æË¿\ðÁªÀ0n) »âðSC0qeÓ*jÖˆ`ƒ /ŒìtN2Ø0Û~Ìb˜Ì‰JÊÍYÅzs—/i6 žäÜæ «É¯¾È+8BPµ× #Ð@Ci2)$tµÔÃzWl'eãˆ75,& *þÃ:¬³6Ç5¨ÁsóBë«MÌ*_í$H1[&e°J_‡GIГ%Œ€(*i×´ü´*%ÈO1ÒLÐ3›!e,Ί‚tžìBHÚù€L¢R-‹MèpS ‘›¢]+‚Ü÷úµÂHÈ×4v²ˆTä„= !ˆæÙþaÂiT‰ìáÞíGoÈ•EPF¨Nëª`:Ô§ý\ä}Oz‚˜‰9q"?ˆ ц" Æ#’ "p¸*­K’ 4§ÏülÆf… ÀF5ÿ±'²; Z}W 6|ÕŒGF€[Üä6·Эî#!¢Ý´y·:â=o"Ô»DÀ·¾ùmãñc)OxW ~Cæ| OùúðÀ€«(² ¸Z­rñÉPFãñH„¨ròFˆü)Ç€ŸWþ 4¨fñ€!áþ >Ê$=À—ài6!¡À6ÆC±Y*ѧµ åKè5, e<ùð&`SU @èt´SW40"³ò ’t‡Œ1R‰ˆÚñïíápQ” ãr s%34b%fVVâ Ã35ÁqB=2—eâ&)ô -YròóUÊÄPôPÅR!ëP!z¦A”û þ8x ¢º7}r&InÒSÀq&ñ+&±BlG „6ÖàN1Kž@b¥ƒá¸«±<ŸP.Nò2X¯Ô‚0k\ÇA=a•@„nÑŽ€L¯$Pñál¦äuB&äD³‚+ýxYT53p2¯Q ìÇ /E+ I°ð­õb‚0eׇ€³Kˆ ,3%Ä3Gå ãò.ÇQs­åàaQÐÒĸB<#ôàŸ¦ f¶Î%nâÖ#@s*@†q—ªaRa· Ð Z«‘Õy›pr5Ù€ ’„Œ €ÜRV%¡ÛpdM¸U¥6ñþC0af|ÃDsø=ÃS ¾”eHf†©Àhxñ)ÉQärŸH‘°_‘`‰%€—ÓG @kFi–S’GBÑ=ðJ¡I S,¡†ëã FÐ?´³E€ƒ30‘†Òé†áñ€¨R~W! Ö‘Ñ%<öI¨€‘N¢{©¥{¡Í(?evx I2g†ª Q qÌ>aC =œÆ2=ë á¦UÙqM€²>õe3Ùà—´Q D€F¡° ¿(«2!N)$Q1±â€òA€gÍø~ðJ¡= 7¸"=‘M2È|3aW5БFSb/®þe¡΢C±Ž*)À@‹ºA ˆÝQ£ä7)‡T%EñL‘èI›£Iësc…G+È°Kp 3,p‡­%R,1OV[ŽÀBPgC;bÃ8å‰ éÐøO;ášð𠟈Ö€ñÀP… Á%3HyBä h0(Q,4@#pÒr *° ²È²‹¤\>€!åÐZø1ê°>’\Á DâDjr&( ‡1C!Ôpý(=µ£DÖ ¸À6Au"¾ P©VŸ“+Î…!0`h((° Ø4§Å|‰`t z—þ“x¹ «ü€fl àcÓ ÓŠi&«ùÐ:lj«)‚«úpc™Õ«¿z"›§ËåžÇšnÊšZ+4H¥1 ÷ƒFÓ 8Öz%’s±… 5çšßšáš ãªåº,P‚®‚‚ 뺷íú®&¯KQ¯÷ºL±¯GЯÒ°Ë"°$¢bú0_•°5°°а<ð°wkÛ?T±ôËX4×±ð±#²•Á8ˆ7')»²WOLBP¨X3ûJ5˘PFa§µ»š/´q9´D§´¹p騴ÔÃDMë “E±Ñ:6pFP³b‚!³¡E>q ZÁ:­ãþ†2€ %Eð–)F H°Ywe{¹&^ö&#qÎÕú +Àf‹` ,¡¼"•š¯µ*]›G»g“"b2ÃyD€”H–-p¬’áQÃTwºáL )¾0´h3Ãp ¡E,ñ&›ÐF’aorŠ[vŠâVš<#’fÖV¡ ÂˆXW±?TPôa Zªý@ pÃÙE¸*ŸÐiiÈá<š ‘§•PÅ ÆÐZ‰ÿÀC‹Dp3œûU#EQU ø×»­:–W÷ ´±,, )V„¤0’ éÃfAS|@#¢I¿†þ„ Çácö:D°_„v‡(+4A˜1+ò-¥ «âH )¨ACPÊóБг b`œ<ÆË©¨>‹â›R‰l,J05½sÇÂ^Á¡?­À#A¥,%0\á±#³% ’Ñ<.!…J „àÈ¥¢‡üHPCø'aI0]Žhç(q^¤ÖºáW¾ µpQàèà&aüJÇ)ð ÉÑT2¡úü_UR˜Ýq á =ð–`òõÅÐÄΦ)Pè éä»gÁydƒü¦Ð´ÿq4©Œ@Uvd)²Y¨oA<³ŒCðþˆ‚g-x¬ðˆ"¹ H\S”¡ŸÀ È`ÀÐqp!I0“"ÄáPuÅ>„²#±ÈȉÍ ³)™@ÕR-% Td½²À#ÎØ|Š"Ø` „&Ê td0AI0lfU1cè$°±‡`©U‰V\ @ƒ«Ò\ :À!Ý3ò fY)Eð»¨âþ Ø,EÎAÜÆ ×°gEsƲ¨ËàU“,×Òµ3IÙ%3|ÑXŠŠpÍMÀc}ŠMÀ5§Cà'„20Ë›¤Q< ÎsÑ,UhXœáAéÈ Dp¡ÈTaº«á á ÆóÛ‚ðR9BKvìœp·„ Ö{ Y-‚å„h!wnADiåUTš)¿–µÖ2C=¸iLl7æE§“\sñÞpX7@0±½òë×@L¦gêÐ{¤* žÝ\Š4fYŽFµ­g•ÀPEñ%$`ŠA ÌP ªG€%ð>·#ãþ–nk†G¾Û$/¢ôCÁoÂ+ò.‹$ ‹¡.‹L@ê÷ƒ1še¬›Çd2ÓÆŧ”ŽΩ†PË°d”î‰R‰RÁ º› 3I}©AjöP‚tBÞ<]ˆ‚~œô("x…±*Æ°± Ãä*´*)³´RþT^*VŽåz¡åxe?ô¡³æÒ áÁ2G±å†àCÛ1)œV¼òZNl ¤Bç*`çî=X¼çLíç”èÇYV…±˜è‹Þáá~N ta|,›–®LÁp k½é³¹#§øé¢ꤞà¶W¨Ô-¬ÎAüà³±8þ³ŽC”–f5£9å!Éë˜Ù¿^ ™,cö7Æ`쀖 É~Ëîz$AòŒÑ.¯Dí±RØnt‰#¼:ˆ¶iœ¥ôðø@cѱBï$º$ٶר@+qÆ"¥-1ºÌ@Ø ¿>Z "›¯š‰¶¯•Q‡¯{fK ösÅy™G€àG@¤^‰Ž{Š±è¸'˜"PV­™;¹ÑßÀb ³ïr^Ç<þ ‘ÈÞ<àùÚíXšß„ê"^¨ŒŒª¶¿glûFR<sa}£7sëS-Xa½ïÝAU}d1-<#…Wï‹áþ†=`tß2³œ…È/ñ0HüÄyÔHª äç jŒIÆê€Ýa‚ƒ>-…--**„‡5/I2DII>!>AA2¡>¤5>-A00D7F*>CCŽE5C¨Ÿ¾¨·“*’>¤>·"5š³ -Eäzé`«2H5*ÒAI$>¢¸ƒÒÉ@âF y@¢DI·ÕÆ©hAðV"BH(R+AA,Xp"ÔhC xÐðaþD! D á!Bˆ 4Èð• ¢p& "U/<ÊQƒiY™\9 ÊêH¨x"dDˆP#‘Ì ÆJñ±¬E‹©è °„ ©îMjt´PZ¦É¸JfúHá1ùD5ÒBI‡Ê?>Ù+äAÆ*>>X ÕáD-ª¢¤Ö¨ð‡ÃÆ­P1D¨d½Ë]ˆf‘4;Yn‘G†?B·¦ðƒ'Ye>‚––.¦7ú:ƒ0®Ü`nV´ø1ž %Eª-?1ÜüˆE<¼xA¤ÅmÆŠTÕYA U5 „=\–@T1!DF2IAUUE•ÁPDÝ"“0A þ¤<èá-2$ ” Š€èŒT0¼@,¬$)\ipW AˆXÐS†Ì5HGdÕS"ˆ7D|¾ðTH7•àQИ¶ =¦ÜB)AÜ ¦ Ñô|í Á)‚uJ5±¹h¡¹ÁK$]5²R5Ö,6‚p$S qÉN/ñ%ÐâpD;%xvà¨P„y4•àA-ÖÁR£kü„*YüÀÊ2E ôÙ[>|ê›ÞâÈ)ÉNM8ç\ Q½åA ÍTX !Ôc!¼!ÁXAtrÏ”6½¥¬ "(+ÈB(+‚1^UàÁ¸£SÕŽåƒ bʨ¤L€YþÁX €°_YJƤBp5‹$`Ì€AŽ’mSsi§\¥“Õ²<+Aa*t‹,|*a"+AÀ©2 Qº7¬£ÌŽMz fO¦JÓ`ã+Ao*|@ÐT!ç k×Ö6S‡´€ )ÐÄ'œ¼±6 Cè›ÑƒWX--"¢|4äTútD öùGOd+„üÆR?a4=AÿúWªðäÈx„vê9 t 6"x„ V Ô °8(ò%mÝ#˃ÖǦp…-dÈ Í$ÃqÐäUªÊ ¾r˜‹ð;?DÇBDƒ1>Š„À+×ÄÌŠRì\¯¨é‹^”QÇHuž1klã mGXÎud‘P¤¦ÇBŽ\ŒP#ìÔèFرƠ|3 >…nf†„ŒðF´€’|zD¬s4DZŠ&È™þN|ŠãüÀ=æhFI“>m5ˆý6€Š"  >{Ò8æ³ÛDª—4QB YlXÄ6žù©ÖF6uŒ…c1Å=fXˆ‰¤>@9eCБ,¬Œ`z·ç°„ylAÔåC6ÕH¬DèË›±zÀ€¤¦Iezx.²XH°h  áD@ `ØGJá¼ 1 ˜Š ˆAx¬q""N’q8Ço©+‚Ø&öÓ|„Wsj&w:EL`ˆ˜4A„Âq¯I™²NÁšMøRU𑦟ñ”,‚€„Kø€&‹(z#:YN†¸G‚Ë,`ÊElQ„5i–€ë¶h N˜Â È‡[æ`I(±” %#¡T0SÓšß „P22í)§ …‚ @¢å Šjº±‚pb³ðÇ©þر,´m1Ÿ”r¾[!ƒˆäÓËz0ÐH¨MÀÁ PÏ$DKùXÇ-jp=Å4VL/Ç>Æ´‚ Õ ¶SKÜ„ÊÌ Ø…qÂBšL¢F…Ù lScĤ¼- A ™Ó&(°Ü9Jå&AÂÆ»×j>!¼n°@L®¨…ÞR×mÍQ^éfÀ~Ö­!b¢Ç¾Dj¡cµC”À8˜Ðe?2* ]!V¶¹F5К“Ê)…Ñ ŒPÚÀÔÀ!2Â:ôÚ$‘FkŒ &lqï¨Ïþ@FGi%R< Á FLia6°eÇ™ìÄþ (D¾Œi¶“A^…«å0PH»¥:°‚hâ6ˆ{Ü@Ù$1u20‚ÊLEªãx £H-‚‚Ç’„•X•DHHV°‚Þx¦×‡RÎÃu0„äŒrĘÃTÝ_ÝÌfùÆ\ü󌳖7$•À:Vr <Ê&Ÿe>–j8ǪÑT’ ”ò”£á"Gö3Ä8="+Ä¡ çÆ¡»v@ÄcÑ€êÜ=ˆ €›uÌQOFÉ4‹ˆ!©³Š~ bðE@”Rš $I :ÜuÞ W¨¼Ò6ÚIg²^ñ¦'¤%2ä'M†g¾p7{[Q`oÓGÐ2ð‘B¸þRAªbAP#!U+0é9Ç`(%°E®Vx!ó"#<‘5 +¡ïá¶R` âµ*V¥¼S5±gf„QÕ,ÐE`EÀ2ÝpMÎA%&•Y0P#"Æ ÈP!PIè ˜—k‹RˆÀ|@Q3 s(%"´s0`cq# B Ð8Ð7'¡B¡  -÷.,ÁFL:ãLqL2WRó'ƒ#÷  ‚È,PÄñÝSDð:PÂÿG#A1ZQ wr— Dð+ °†…ŒÑSá› ò$¡H_u†ÇñR2YÐ 2ò+4Uðþb’x%1 Ñ y„ƒ¸T"ÆÆUg U[ Ü +XKSSÛ! æÓàH°%Ê2P ±'ã°Â…,ÒQ\n—?ðRakgÁE:èVmB0„pM¹ÒpL 8ØF“²nG°Jж6sK1ñ+²R1#TK…Ë0“%? ó}! OREƒÁi Á%ð8 !@ˆ…˜ˆH’pƈŽq<‰’Ø”8 –8!¬‘‰é°‰œhžŠA Šèu¥(4-€Š“°ŠEЊ(G43‘²\´X¶¸’ÐÑ‹$Q76ä±{¡÷FÊqŒÅåÊøþ!ØdÏRÙRÕHv•#Á,ˆßXMâÈvåØ•\·%ê¨ íY2 ó(D7`Ë‚?“ ΑBþ8™BGi+Ü@×°ûãL!!}DA‰,"2¢ YLy3+ð‘!I[df‚ d C0CÐ}arQ¡Xpá ÈP®† #¡'Ò0;ù:À‚ §òˆýP¸i·UÀ@H7+AÃ1B„# Ð=LGË1A³)Îâ "pýPËñ?6?Á©U À]tV§ññx$àªâ‡’îp –r5À‚or¹%òEþàí–·8Æ.îPî¹Jü@éP+Ð $l…ó,t3Ù°5Z˜çÖ"Ž -ˆô„ð×edd¢ÇT#·0C<ð+$Cò ¸i} q †’Á2GaVŒw`…VʬáatùAõwÇ8& •°YÐàšbw¢wIP {²r°á5·Q¨³#é°8ôtƒKä0¼p-Š bóA*wõ* iE Px_ÞQ2Ç%} 磠µ¢c'y¸b1Žšvu€oaI¡®íx`æӪѤ2¸% *º'?þÏ*+¹‘Gï¿DkŸrW”‚WR//b!  `CÀnsSÓ¤!!û; 20øØ|ÀÂñA Ô‰#gJR“F*öÐ, pu†^á“+>_äÊoU¶.ÁÍpÁ&¾1?RI0aE*1"wpG¥U `>…r 0&!€qšàCÂsdš-¶C-7¨0.™Ó¦~Æ!«š¨›•,›E–%ëêÅ’|ò+©yGðTô—FHÈòïâW#öBd7A“A…e¥àÂBX¢ðq÷?+!µ0.×7 [XG Ô #°vÐ#0høþ g&’ÇÇ|%ó"€RäÜãKfZ¼E4 ¬Xdq:‡Ù8Wú“Hñ…똱 a‹K9üª,èµG‚cD;å§ -i4Ð É)°® D&CBñƒ o¢=GÁO¢WñµÀ1àg¢+6­Å7bAÁ—†‚¨qµ»'b:I‰[•wdQu ²O‚&—ò ”,„±áÍx UrD?K ! ave‡Mª‚2Xƒ©RaÇc!³ † Ý#·u#2ã@ …]±SŠP0c ˆ×`%¶)¹Á/@/`’þÁ="å‡Hè2sŒËÁ[2üQl ÃoÈ@œÍð¢34Ýi}2FÛÔ$Æ°G„ ¼ ˆÛ Á²^+w¢e‚æUIŠ&ƒ2{‚P&ì²²uÉÖ ‡ÐS €½´c‚à d ³¦ª~(¤•Q ”¯{åvLv±ûS(þ`–ò_÷ /Ã7°\ã(´ƒª? –ò‹¡Çæ“HKP9FƒÐ,ûq*PV¶“\!€É#ÐÂS‹=5!•uü¥P-¬á}÷â \aA(‘éàEBwE|Ñr•Ã±ÁŒXÜü+@œB R© mG\Jl`ïñ*> Å!Åž@–U\gWœY4üó]],˜`,ƒbl dlÆp!B¡Æ*ÀÆnLU6ô sL;`\¸Ð%¡Ç|ÜE 3Ï7È·Pȇ¼žŠ,ŒüŽl,ÉâÔS—|3š§ œVAõÉ’¡™ `tqpõpœˆÒhS2Å]Ýa¥&¯iáf("·Ð^s1-—΄$W•!»“ª67¦gõ]„.TÚE<¹>¼^ŽP²¬A4ѵG4áÊñňþßYWA@à±ÚŽ Ê€ ÔÒ‹¤°¥¸Ð&^(3¤°x7¢2>¡«Šq„Yå•%¶) 1FP7•òY"sB×Ð0ã‚8@ð£8Äöm,’‘M`~È0îô9ç‘ ·áYNK1ð‹XBGœsH0‡" §äO±±€ •Z'mD2@tK¦›å} á!ã ‘‘/1ý€Læa( u.!ˈ³J&† $ô­{µ“åí}>q•Qh¥: ¼„”Â?c Åò:d²ˆúÝe“BîàØ!XDmJƒ+aT+wÞôPÄa²4Ñxõð±‘ޜЂµìS,p -0çÄÉÛn6Ôµïªo¤{Í ,ûþðÌ$õ¶7GRfõ»±ÍO U…]#“pÞ@TËmRM @)ŒGly#bGt¦"Fd/Ô*K/‚v „pñˆ°óˆ…f4Pî•@tq/ Šë\Ïí£N¾J±ÀÁÉ?ˆîW7r¦kQÄÀT?ùÒ*0üÓ‹ü32°¹ŒFý¹™±çÞt$ÆÝŠC²¿½Ôe…iË!‘ß0näö2ê@_òK1j”¬FyÖE@j)à á3Ñ™­nÑq}-Àz§2œð^Uã˜3ŒBGü'Íg@-˜f(p.¼X27W¿ 1W€PT¤þ!¡â"!á±!â#ÑÒq±!éÓÒqTÔQR¢¢ñ£R!"â!âãºÂBSSórã*òòò©Ø±8ä##ssƒ(Q´8irc“,]M]SããC$Säë1®¢‚Ô´­®î‘Tƒä±Ù.ƒ¸Ù” 3î³é‰ ã<øÐ`Ѓ#…JáAÈ\‹ &É5dˆ»4tèðaÁF+þ…hTqž¡$&C|hQN‰’#>*¢„ MH™Y"HEz”𨆑m*x8UÂc„cH“ÈÔ”ÇÌ'Ox”X5óŽ±Gœa1¤…Œm!¾ù Y3Á‡þ®BQêÁ„ Ž&*åk‘ >*Ž”ë€øƒŠ ÖþðÁ©9pk‹Àì[Èï¶rqvbˆ3‚5I$ jÔ¨"…Diº°ƒ$)'C ¬c0bEH@Ì2eA˜9kÍZµiײmëö-\‚åÎ¥[‡”ô·xóBÔ»çZ?Ž4ˆà†FœøÙ"F58z9oÛH %ó9ÂJ-½ÓL5Ý”ÓN=ýtDPCuTRKä”VQMµ–mW‘ÕV]}¥BXcáPg¥µÖ?nÁõ\t‰`W xéÅ—_'&X"„¦b5-ÖX(rEÆÃdTYVÎ"˜Âþ™gÎ@"Ú"¤™†ZªÀšk°É¶‰µÝ¦Bn†x)Co ü&%#Â%$žÉð‚ ÌÉyƒUÞcL-5ÀÖ–6® ±Â ÚÂ,'M—Q;Ñâ ˆdW>'!B©F—©`L䨠©AE|pHAHÝàhqCˆ°„~îÑèZ›@òª#—HREå”C‰˜Žr„XMtÀC¯VâÔB¯½’ ¥AQ³%tPMT(„ AôtS)N‘DV†u½®pƒÝy§Í–%€Ð"—áXÔMˆ eHw¯Aɧ‹ü@%C&ÐìP‚©¼%Œ#Z4Aâf§m%=|þk%$À«õ2O0´ðAM Ò].Ÿ€Á@³ ãCF2q<¹HÉ"ˆ@„6>ì¹"7ÀÐ IÔìh/¯¬UУôtÌ+êxeœypkÕK,Á~Jæ[P!-`­B}UÍ*Ù>·†LOÞ!„+nµæ´$®¬ÕW|dÓm 7©ÐCÓ"f´!V°p…-‡f«æÕJý b%bNa壯y¹"ªƒ¬ã¨• ¨`*NO”€D¥·ª`#ÀÚ`·"I @Àá“*­W%T²U?ïùª"0çÎ;IP±(u‰+\*ÂBq…²§l¹€°–þ$3%cç‰?I‡Ý13ˆ—7”Fi8µxIo>»•*©0®Ã*º}ãiÿ¡ËžÜwrä§'Û#Û!8å25•-I0]¾ìAê¨ÀKô Ê¿Ê! h!Éײ3ºb•År<˜^z2“&«,?Â)J Vhx*TUðfZ-PbäE?ð€ZðÎlâCøc°â·›Tˆ‚XA`B9Å™¦3JrÄ&Rä7Tª%Aœò˜lC|«Ú?``›MT”’D¡‘€%22=˜€—(R‰ï# M-XÀÄ"QÉÊaŸ„ ÿ(šþ~<“ ·|ŽTß°M2J¹«¨Œn¥ÚÓ=âÖ!ÂA‰Aã†Í.©‚f¡‚rÜC(w:ŒFè8 Ö A)#P%Šà+tô Êñ*Žp9B^~5 Å­K uF#Œ]LÚP.)âTm° ¹p”gÌ:TØ ´ðŽyç–G•Á«H)å'ti]cä2€ÝÈôÌDÀ%Œ(DABç¨ÂD4iå/ –þI„ÌÂ\Å«SŠP³¼Ex‰ ‹,;sñ)<ö0ëóƒmàD>,쮉1wa­. i¥Â„”Œ„r8ÄdOÖaŠˆ?”0e¶m žÓ;¯%µÈ ˆˆ03wârrê%>r Ô,XøQ Ô6zðeaö«Fh¹€Ÿ¢èxð´äE,A !$,ð™ì–‹»Ùù.gÂëƒñZÕf¥äïP×Û^pØL"ˆ/{ç›”úÆï$†Èo8øëßøeþ…)N ~6dðàžJ¸Ò(A†Uô3‰ S“iÆTkâƒS&>qŠ}°þâ—ãU*ˆñ$f¼…h3Lf§˜Ùh6VÖÜfo¼YqžóEëì\<#AÏ:ÁAŸýh)ÕF³,ïyáôVÝlÛÑÁÍ^­ W× Ù8ækÕ§£§ìe/™NÂTªÏ, BÈò'WÞ£u HnB·½Cb+#  @À_jdC¦¶ð1–¡Ÿ… ½D‰e c£=Ö22‘ áN36]Šà’’ ɘ=³Á»ÈˆßÈ•£+u‚¥†$_×Ni±…ƒÀtZSÊþ=†ý2Ø°¸ lò©“qÓ&(æ<6F^uoÌKŽ`ØŒ… MøAcÈñãˆì‘›,ñXc!Á^õˆED! =;6ˆ ÷Õà"ÇxÑø&ÿ®C+š7|Qòžá:KvA‹4êfÆj¢£S&WQÊKfMFÜÜÒP^:#LuzÒ>¨A„tCN6iÄø3R!PÃslÝ\]àí"k-¢é 02°?à> GPÞa5' 6°ÐÒSºR ±zÍB «DÁÓBÀÒ+òoŸ”jÌ!\£;é€ ¿0?Íö7«pCÐ99[“À!þ!D‚0F´ÒÒO…Ñ+cÑ% 836ºE[EÀ1íaR‰Q,8LHH Ç“ë ¯ÑS¡d4GJoâ¿!¯±åE êgßE±'Ô_±+Ð(7ðTÑ]ÞWÜÃ^7{¸ ÖKãGIò4@É°^>ð ÿs=*éU¯ð‡‚|Ú3f3 ƒ×8¥`b®!©"¿ ~wÒ["WJEGB /0bGÂ)2Q%3a!pNçºC‚P®@¢Ñ ›00çJò?6u&¹QYƒU*-r/Θ~S!ˆÓ+‚Ó+=Â$f½#ðþ,ƒ„$SQ£Õ~£ ’LàN°+4Ñ+sØ5@oS?­ä'>°t>e'F0“'Û`0§¤?ãjfE4wÒQñ7?aƒICðd'£r=$^*CAC7,0~BPvãð ¯#ìgPŸÀHp „ G“uò }ø 'q7 …Â]!ôê€lGðÒQÓÀ… àdÃ;ã“ÀÚ® r0]çÊ%/%¢w”… ™SÌ ; 6à#B®B“P L¹L0@t¬"=~[/Öb†±ä”5X ±ceÑŽKDÙøBȈ׬þ0¸°±ºJ@P ™P°9% ¢S5à&×G¹P3„å“éUHÇ_»÷¢Iê×S,I@“!°sˆ x Åà“ÿ¡’OW5ã°'K1KAð‘ä9ÀI*`8^…U‰îRȈá’ìÇ…è}GÖr4d"ID—jÿÐ 2Õ }b É0!1` 1© Ô`BS^ËBfÐ_óP @6ÓâM`ø=àWM`oÐxP1# ‹”W‚µ -p: ý"„/iF€$à †¨ ÇP?0^B=0$$3 ™IÐ~æÓýÓRX+@þ[W 4YMpg¤€„+0—N1êpã4= ™›Ã@ (%3à›Y*♥”GÛ š¤é ,á>© ª¹š5КU ›F ›C³¡‘~Ĺé(»éS7ŽœWEœp2‡Çi.Éy ËÍéÏi’A ¬Ræpù’î3v ê*ß9 ´p3ÃQžCpžéé}ìéž&§EòùD`ŸÖ•ŸŸђZÚ,Ú#š ± .ã jÌÂ:eš¡Õ@ú¡!:¢%ƒyÛp¢)j>,ê6/£äD£1t£‚:Š <ê£å¤BJ™wV¤GšjJê>õ¨þ5u<rŒåÂhÝõ¤çõ ,'S6£~̇>Æ S›Q(ˆO€W‰&”"]’6ÁÐ?:•Â'óó"+)Œâ÷¹=» 'ÜA r§QEò³d@ƒ‚ô‚C‡7Д¹ ¡:Jðo¥^r,@¯¸XNÑ Pij!J7d•‚ÐÐZ¹WEÐ? Á;»³—Ç=&³Y–„QC„3£¸¨^$'=R%bÛC2d @ RÆ&E”/…#¯¥8eq•@I˜Â㌠\£ª8N¸:*@’Ø{î#4Ë”nÄt†RgSÌþ×{— Â÷šå%|ûµ°,ÁKd“¸ñó@6Š ®0^JÕ¦“p(B *ºÁ­`0ýCˆVE‚…°R»QàdZ½ç/Yuø‘qaé°%—aIÉÐS1dó抔*iàñ3’ YFÔ“ê@MØ 5¡²Èvy414À~"v³ ðO³0ÜdD7qž¼"8p·R,‚3@*iQ,“,ˆ\$X'¦w—7g<ð½E²¶sé§%;Bø„z1ˆ!8³™

w2‚,§2èM|²A³jÇÁJÕ<Æ´¢–¦À_ÅQO×þ}˜$@ÐÇ 4V`Úù4’?4ç†0K„±0À¥Q’#'!XźóªM†3qx³é¥_ÇP !zŸh[·‹{dy>Â1[¹˜ÓРq‰Aû#Ž2Ò ‚5'l† îÈ+4q1}Ü"]6o·Â[&,ƒ³-ýÖDx:%ÒBwñe$2"á‚$@ž•¦,ȸÝEqï "›à=Ê·ÃÝeäô»g´²–Ã=Ñ¡Áùò½Pq*x@q#?D>î³àP3·›P&zecq‡À¤R‰˜äVÔȶ[BdŸ˜Ô¡ŽÏ*l4°Ì·7ˆl /þR7ðY‚pPD‰03]¸”"Ô &ELjApÐÓ ?ZOr–ÓÚPT =ð0#ß$˜ !2J0‹ [ = j¦ð-»ˆN8ÊyQ¤ì•'6Y£/±]2‚ƒP°L`?SråÂË䪷Ý'kH>ÛUS÷csXJ {683g8daÛ(G3XtaÔvû°qU±r3³¨3Ó&Ηž ~l2¤rα“ð¨’qÓSr Uƒ„ ëvßóó&1šñ w-Ž'¨Fó}~bW†q ›GZe]ñƒÇ“m0E‹|6°ç2E þ°Cð€¤;-pÄ$sZ·± O7Û½€Ü”0Ü”$ï7´ÅV˜'óŠÜ„gò?xg m,:Q2ÿ£$ôƒÅÊÉËõq†)âÜOÝobwÔm5@sÝ·±Û½rÞÍÖ†°…ã ”aÞ­£ÁÛj'Ýž^ÂLÚßdKôM3ߊß'§ßü}Z¹‘4[ ÃYR‚ÊÐ « > p3L5lU³pá>¥~Ž˜rõ_>Ù"Nlà;UŠ€¼(Žµ-.äãiaZ DGÛ°8ÎY&f<îã}äÌ äq 6a9†ÕlJÎL¾ÚÄë\@ÙRÎþ•Æ‚Ê©|4×­kx^ð0?+gqž’_ høÁã =·?D q3Gó U‰Ó1ä¥,H±ØäI»p|‡Á¿ éŠ0\Â!ÌaWFà‚mB¡Ó#ð¡!ó™ lõ(YC*=+ô²]§U7>”ñSð„­! ± @ó 60ets ˜ò“ zD Ò?:5!z-@4¶î²1À>¦]µ§àW¥Ðn‚ðìG–1B‹À|Û2XñO¦yW"vÆ™hô1A¢c‘ T./L@™ÒEïäº'>µ‘ä=Jßå|ö³_?sØï ¤vu:Úþi4—û jÏOW4Ê ~ KöYV3æÇX¸ä…újÎ1…'þtÌ2ÀY°ð 'røÇؘ+Çã ¤¢ ½€ ó:]‘PËé~ñSži×”}²ÞÓa4\ ñ ®@'ÓÐó~óÑ…¾“ó-°dk412@ˆê )®ª(@ôÝŽ‡àâWF{FÓáðzn»â8TýP‘õßT|ÜÚØB ´ÓcgÂKç«9i÷ J«ùS\(i 227I5>>A5A25"*’"AAH++5H">’‚7–A£ž£>!5‚I«D!² ˆHþH5"/Š‰¬D¼¬I¬2A>‚‚¿!"Å—E+A?**?B*#HÓÈ"6D—Ó»‹ *,ƒ*“Ý0200†¯!>"Cóó“Hƒ7þ‹C†tèðAÄFŒêMzA„‘ˆ‡õ|°hdÃÆC’6@h¡d`‘Žð(RäÈ$óÕaE#JÐàïÆ-Ùù ÄŸK*Š´àØaÈŠ}9$áÃICÖ !ÙAÈK–`R‚ª’#?„lR„Lj>$¨háôC<â1ÂÏ2" küªÁ01#‚à5d‰˜¡cXÝXZX’$yÝ‚˜¬AáH•XÆ¡Ä5þ–ùHl$#—±ú|èb#{¾˜J”Q‘†g Í~Pò!m$ Óž²RqhÅ "•H9Xc’Œ7 ÖüŨÆw€£Ž:프š7^Ê:pDu/ü©ZÅê°gª% Ñ <#´¨¤¿’ z%Â+¯á&I`±ÅEö 2Þ >¬5Í:ÜôCeE8õMRxýRD”o;} Bý!xD&uÐÑNL˜T‚>AÌS $”Ð K2`ÈÀ`Éh2ütd#¥±_uD|&u«„xØg†ÈFT6Ow‰ rHÓ0sYh{V‰v˜"£½æ Xæþ•s5b$^0À'Á.5¨ÀŒ /Ì•\WE”@œiµ°Â‰–|°Hb‚Î@Ä EŽbÇú QŠÐœ-ˆâ!ITWC@dòô£r‹&•adD'"$‘Ä"—Êbšiv ÒjH`u¤Á†Qú£ƒ2„PÖÊ8)‡]ER ñÃP…ôA ˜$A¸G—”z/Á<#c<׊,šôUMàÀDuT<4Q‚%¨ÒKo‰tdª5À“DCkgÚ;0¨F̘ŠÌåsȼ&Ë õcI<…!‹‘ð`‹âHi‚ ’Ð*sš6& „¤ù&+vÁÐÉ1ôþÑvo²òƒDŽ*Ì#‚-Œ7ÄH|PB\VICŒD F:$B Edð‚ 3Ì`›Ëˆ@Ä /€ _€ãÉ%AÄ@ †ÂÂn)Ñ FZhÌsƒÉˆcÈ7˶äÏP¤JÈ_$²Á°àO#áÈp7ðeÈv„xàTMá?C|%#·= d?Áà $™EÕºìò Ã4úñ7P+Q‚%òüí“ÒYJð?Ä5BL ©1 ; qšªp]±¨#’±]§"ä²!‡œ8ÉŠœ\Êv+w¾>žËÍ{†ÎÓNœ’ôŽŸ5«6ÚþŠ&ƒ£©EiLsÔ¤F5«Y"kEØÚ;&õ°‰lf»Ú^Å6·­¢PŒÅÑì†7—éo*ð›æ7¸eëp!Sœ=lÐ8ëÜr-œ‹(g9ÌiŽ9û‰D÷Ò™NR©[Ý Zw„×µ ±#íl‡»gín]qù ‚ç¢áïxAH혧çzÒ£žõ°§=K Â7ˆÂ‚0…—Ý;Œ Bvó °Àl ŸüCh¬C‡‘ÀC|Pˆ¡ j1rc„tЦ´£e,Ø zÚ#ˆÒ¦'=ù…>šcÇfÕà\2X`Sºã™¡ç#âÖH…ËÄ… ÝhÅS2þád€þ¨ÎúÑ)ÀÃ0mZ `ð2 $ÉÂ(Â#,!‚ÊÃ3A`Fb~&·ØÔ l6@fZ˜–ËläŠÈP,LU¤"jT „ð»nù“»bì²È;Ћ øŠg†>2’þÌ«ãÁH€Ð³Èh(‚!Áv„'øˆ?¿ìL"ƒþ¸ˆ¢øbH€ƒØq0·0M!’ðLëÜÊ%»Ž D„ø”I–XÊh–ˆÍ%ƒ™¢ È<ªs$Dê!¯M?†ä2Áè 6lÅ®²Y‚èj)8«‰4k âœ@BGL*–vÂS(`+BŽ†€­apgÙ¸NËŽ´þ9õ­i=§q^Lf?gàÁÑábd’‡ ®,1Š]8óÕ€0§´ ¤KÀ-R……r2 Uʨ„ÜÅ 8ÀÂdÔŸxA_‰W¼<Ï0A%­HxЭß‹XLn17â‘™%ÂÆJÔæñø1M©Ú• Í,- Œ–ZA{‘án ærŒRê)I¨ 3‚… “µ"4ˆ¬E)´Ôˆz¨…F‚;;$`( èŠ"Ü• L¹ ÉA·Ô¦‘äxIˆŸf" úTîg‡Í€ºTRx¢²a`²EYþR!c¬LnXÐ3’‚ÿ–ĸJ ˆkI`d¢¤a³ų9Ï&`B1œ¢àŃèå6`ðš]˜ðO%¨@EþlÑ”ÀZ¶M‘#EÑN°ˆ ¸øEˆoI°F´ ¯I@y{¡ìÔ÷aQ²£!tõš$)b¼ÈÐ]p¡—KឥaSbò24½¨‚|œ“›ùLƒS„Ä©3rJi®™¡…À(.Ág’%€ÄŸŠ‚î?ãr;OLè„>p 6E¡4g9ô<`x""o+§z| b‰rëd†?hС;ž,‘Þ‹ižé™Z¬§HÈfœÙ§þ´®CÑ%<’%ä’$Ô‚~¾å"°\+ƒ(AŠˆ§„”â ·&YWDs{„~¥ˆ8Xr<=’dè³yF2HT]Å‚ßžõ@ªT Ÿ‚J²#·N} ±^¦z“„VD{,±¥E”bÔ!´$â$NQ1z€a4¨T•RøØ»ÚÉkLF "¸bC[S‚9Å–R‹X^;§LÜÛX‡€è£ºnF;-¾iÁ€&’‹ÃÈ­† ÎÐ$À]™L"„ žšŒ-3¨lÏjD1±_ä}œ ÊG¦±@]%á³kÁ¸♉Úuø€€SFÔa‘”1ž &GŒ×[áþk¤ðzB—•[É®Š7iP<Í'€*ã’Àþ*‡Ð’jèÚ%0)á+Ϩá]ÓOóD0‚æ2»y€Š‘˜;Â!5øù|³_àû´Å=Ò£ú3€ß霉º,¦¾]^]—Ýép×3:ÿ¯‹Cì&;%|'µHBítçn÷l£‘OsWw»²byG |—þðw¤p8‚w]’ ¹0 Žx$qe[ãxa”Cy+`yN‘y›—xàyý’x.e £'pÑczM€z< zýÑz¢e2ƒþ²ƒµ÷-¸—º7 ÆðYÿ|$ŽWs’cIW'«!|òq%£þvéÆ>Ðd>ò$R5_›ãG# `2•1tëñ ‡aJ§¤6ØÔ f%/v ¾‚vQ÷¢% l‰‡pR&ª2h>°ž i×%îq+ë1 ŒÈb 0`Hp~,pO Í‚àCÀ ¤°€f§Ii’ ;±—²B±otueqÕ #Mf" y’rfP(F`KM=peÑ0¦÷\]F_ñK_!/Úó C€T1;f-¥Wñ&ø 0€o `¾p Qƒ8Œv v'H2·>ž‘+%ã|ƒ_c¢%h¥j ’,€%‡P8ˆfSóhÏ÷S‹þÐX1)a !Mš5 ~ƒ‹#*LÃ4q¨ÃP!WÆvËÆm" „V ŒpÈfUð0pª0#Ö L# 7GO!ƒ):E‚Wè]zu ÏvæÐ,A´*QD’¤‘B ÃpEÕ-Ã¥—£Ý20#ð(ðÒuo-0Æ“!0\¿•PLã"ø²zÐêBfJpa¶µ$‘9>F ¯–š—yVFZþ€{D„¡hš1)É9!p4ˆóh>¥8þX.v{á6Ù…)ÙTj§a>˜*ÁÂ6ŒöMmw%ÚUë¡Ì€œõ@P¢p9O^ìþº…ŸôlîÁ>Cuf'µB€’”ÒÓPTQ8Q+Q€RÇ}Äó@L¢! ¿p(’• ’)I¢D³GÅÆl±–S¹‡ßÂÓÐÄ£q15õÒÄÃ4WÔ"µå/N)p/·Çk<Ða< oWƺbŽ+. uÀ6â†iWx…á2z%Í`3&5'˜ˆ'ÆÀ 8d™U Qb~ò – » 1ÚÆ}-Ç6Ká à0 3 ЉÌá’îødró0*‚R`á¡åD>B— ~Á hã‘ô±ˆˆÀZè os›ó@A"®„ÿþ+Ú þc>?¡4ádn‡4!v„5-P–À4‚¢+E@qÕ „žCWî$5s–$±sMŠ-ð$§üR-B= )²–NYÂOiª¸Ã§"ña¡V`q ¦`‡¡•"•'ñ`8•‹•$­ôÂBsDÀ*G²W…q -³+Yõð6¡á?•s—à÷‘8Ì×±„‡–ÀrSr -Z0W_Íé3ˆ@*A¤8ôÄ º ‹°N]"à£AS i?¡Y~ayҬщq4å3–!.Ù’°‘=• ±¬(d7þšngêÜpE×âU§3Ùô§'˜QùÀ×ø% Hq*`k¢\ñ(Ó Š„rÅ-ñ.ý†PèI³Ó\´l¬%#22Xu¹Ÿ™*g•*Ì`Æj BBÅ »2€é7Îç&Íø—ëá‰F Ò*tNÇ  Ð©Æ°SMdŽ‡ƒ AB;+J’Žå3.{r=¥i„PV„Y’„@ !pZWR+à+ž¬tâšÐ&&Q15 ëD3?3”À·Ð kA ÝäXôü€žl«:ÏNÆ·*œ¸;6‘'”W4ICHèé<Ÿ²CÁY.È~#*rF°þÑG;0Xѱ‚-˜xAÁ#bÑ"!±k$ÐN?ˆ¢²ÇÁ²ƒà²‡³BIöZ³7+: }’é³H´'*‰£hZÒ}GÛJJ±´ºpZò´@²òJµ…á|W›µá°µÐµQñµ|¶ôD¶®f g{)ÙiªÐ¶ññ¶Z3s[·‹Ã·{!Ø€k2‚+M4®'ƒ¸ó™ :Cà¸ð¹ñ–4“+•›—›¹ð†¹±Ó¹M“¯º50º¿Zºð„ºªËºjÊ ‹»í-´K,²ƒ»Í%/¼ë»$QŒÐ¢¿9Ž‚& ’…`ƒÐ1Ÿ ›‚ Ç`þ¨ètõh„ &‚dJÇ€‹`ÙgiÄ0¢ôZ8œ Sƒ@(÷T—-Ó õ4kl‚ð3PzäÅ3 ‰¯* œs¿;q 2t7öÀ¶c27-Ö c|Ìà316 ?£`†+QAvzQV`¢’Å€ˆae¸ñA€Ló% @þ6BiI,ThZ¹¬.Lù-Ø Q.YÄkeQ DKSº• IÐ=§ÓâO™”XD<¿E![åò£Ù°<ò‡6PI­¦+UÉ Y7°K $Å ‘[ÜݼŽš—Æ`þ3A »þbK +¨R½È_N/`Gÿ#¸a·rèåC—"7sqð®‘8æxÏÖMMú6²úø€Ç†Ð‰äˆà4Ç\÷ ÷‘6„,ù ú°š¢ð^· 0)r¿ùâÑ%i(«t¹Sƒ6ls$Ó`ÐæÅ4h-ûZö0ç`0IW”-™<â/P ñ–ŒM ;¾ä[€î6<&ÂÅ# Lð¹D,Ø Nq)Fàx¶%7>9‡rN‡ÓXÐO7KpéŒTŒG!7èÅ %²P6°Gx) ¿àû¼%`˜&Ýiþï»BˆÑnç'9’t _µÔ %Ù±bÂ5L¢'ÌÁÁ'xìæ–têCtR¥ª0$DÕ,Ÿ† wÊz23¦wKAÖ¨O«É9òâŒ5-¶Îà™×l¡Pl±qNÙ$„ܹfÜ’Qr5 ñ5É؃Šâ”_ýÈ´Py&qË4iC*= ¶–L0! éæb"#†ü 3ÌAsïH}±Bàtÿ@`’°vWK Y+÷â(­·· ášz¬0Å*V|ÿ0bò&Ï7¿¨«…À m·äÊÏÔM‡`¢Œ¸~IþÏøõR.3±:4Ì ;'lB›Yü)ˆð3bhv?s‘47ô± ÓÙ%Š àÝë—yð"»€*T콂AÁªó;²Ø0.àòYWÓ($¡mÚ]‘- —2":¨®ì¿Mà^7°P&!ß’/í¢¶ØZEèé;Ü­><•8ˆrC ­”*€×͆žY¯.¶Á(0žÅªÊm”I$$î…}™åð€í³&ý7«§Ò½àpìN¤,~ñ6§&1û“’I¾ k3ÖÑ ±Êæ`v¼`0•u‘”°´õˆ¬ùkc{'0=•@Î:…í›üDþg OX„ÖqqåÑùÀ‡`#s‘-cO†þ"EqñÄèŒî"àb-`v¾rEòí/ký4Osúéx` I°ósáóuôA0ô  ~’ô |Î?ÇáôPß2R^‹Põö„õ¨ÂMYÂõ9î_ïa/ÅyR ~3sª‚öðP$ñÀ&›áö¨ʯ1÷uïåxŸ€PãSCXèRrx(¡"BôrCITs#”(#S"¢X£yä¤Øâ!äÓIDôÚy㪨rt’!A)cããÑÒ2Â)ûzêññQ$ÜÝCBÒÑRT”P}íá!1-ÞòáãstTbdþäQÄüÝQ¤¤T¢ÔqÔ14TÄsîßAI‚#d´õ(D‹Íö©ðÐãG§ ™’L$"ã)ŠK4Qüu#‰È$AX$Q„ B(Ñ$D†$ê2ùÒQÓ #$=R ™ä¦Åž“(Y씤F§¥5Ddòˆ$HO˜Œ ÝäsPÒO ˆô¬´õÆ+*ù!hÒ›å< ‚„¡C„•“ —”Ð$0`$$¢¢D©fª@"H`N”nhq‘ˆÀ‹¸yò"c\n•ÊxAħ%$8Fä;2°¢ q˜àâNƒ[œC7°Å´- ”ð­Ãa-ôAƒÖBŪîþcø¡×zÜëw\É=GH0)¢"¼,|LF;ïáI@QÑɵÒR"35v,#Iã$K’”(¡Øw(¨4D &1&$‰´S)ÜHE‰Z2QEŽQ¤&7döQ&KyâÉMêPTƒOqƒ GÕ•TX…!FìdÈ&ƒhr IHØ` –l,IЊxy@ ! Ì%H²WždVŽ"6Ò¢B¡å™‰±P¢XbŠ™§!/¤bâUiŠ'Í— 4‘#pS;ð0„\;ÝäJ !T‚Q&! ”@ Á…Ä‘Aè^×ÜÓd> 12´Ó‚<ÐþLÄ0ûð œ5„猇W48PÓC XÀ‰"D¦RC8›âA,Dì„É1—À苯Ð@ƒ/A4Ð@PC4Cà°‚90Û E}aUV…&RZAÄ"BXõÙR~áYF ND‘HtÚ¯êT9RRNŠåÕ+yÈ.!šÈ`Ĕ⠔žlå”L-B ë5J /FÊiA¦HdP’"ßþŠ‘,Üø ›¡LöHºFøtC²°è‰S0dâ"Hôp­2*Š0„GÉÜK ú)oH&ÓC>\Ï©¹1‚‘×<÷N'ÌhRDwðì£xaogþШ wL!C7ÿ•ðƒ&ƒYÃ<"•CDZºDc¢@D°€.%°À4ƒèGеÁ•?ÀÄÓV°‚N‡× Î5VP%eHà*àÁÒ't8ð)Zt¹ äV*µ¥ ÊÈaˆ€qŽB^ò×À݇]ý¹Á¤b•ŒÃ÷ñ Šv‚„ÊiïK %¹”×y¶­’õÁ9e@¸H 2š`°"°>aþÄÃ"xHŸ’Éáª%·S®§ÑêuˆœmdÊ‚ÇDÌã”ü-"x.l«-<#Úâ–•Ž)Gf¼„Px–¬c 4Ò£#oˆXE¼A2“ ðÅ<ªÁP©äCØÔÎ=ÎÞM$&zS¾Á¥6° PUÖíAÙšB†ÁAN ØQ!ŒêÜPÛ~€'Ú’d2Ô&¦¡}@àôX„ÒÔY¸¨Bú%6@@0TI sÓðaTÃiE aóаVLèvÐð£¥D¤§¢ÿQLp…à9ÈB4ÕsFc,Co”0$`ƒ6˜ÀP ŠvQCó·=ö A0[a!9fV(ÜÓ.ÅÕhFÐ[ad9ö"b!˜ná0eÁPn§UÕ32 S”!êp<¼…€LG¾C H *æ4 ®þÖ*ÑPAOQ=,Ð]·#C@ ÆbhH0,FøBrRT¿²8‰vuWAp'>r 8 3’"=`æg5_qt* K? kô hJP6Ìp*ËT’6*ŒÚ”(=0KAHбH‚¨m§ãÔO¦–Ced®KPc-À&À pƒßhƒ9€`E6re!è²{E”HûaH±X ã=q:áÃ(Q¤"ê@4”ЗðBxZsÖD¦Æ%2!†› wÊðFF I™ ªh,Ówgu” "&sÝs€á @“¡ Ôñ¨þÖdh„0@JÀLD¥@2÷ D@M“!1Qä$Ô¡  rhÑD«D>r%WÆt¬@UÀåh,Ö¥50GÔEáph  —H!0<0IvEÁ"× †FhŒñPV%0% Á˜*!v×ÐvÐhŠH—`}“ÛØàøâ¸ähŽ)ÒV`´ŽFÑŽ§!ECöè$ø˜úhmýH4‹!2!?v)CgY"š#?ÜÒŠ‘> ‘ÛÒt¤épŠ™- ù #)%Y'™’+Ù’f“Ç0“"P“èr“E“;ùþ=!âtdA)”À`hèb”€”J¹cÈÔNù P)•@,Ðu•Y¹•ïÑ•8ð•ay0¼X–,p–Á¨–lé–p)—tM%¸Q^•m{“Ž1[„Üh ‚yƒ)`hçhbt”ð‚G„"±¡ìˆn±;''QÑIØi#±]vd¨Š63 â £E}L”?¥ÀæÑ‘á>þ²\2Ú hqHðNr†—FW}Ò{  ‡q“ó2Àx¢27h¡p¿ò7½Ù'o2‘<'”¯0Èé}7àICà} ñ0R‡u2„£#1/Ð(´U"¯þÙ ûPÖ070òð±†`$¶ ×`Lç@‚@ *PNàmÙG€‰Ç%ÐG0N^Ö¦s,>²û‘ÊŠƒ³¥"`”"'Vñc± %ìFªØ J€&…X¾²ý¶‚RŸ£"}äDF¡õä;3w/§P]¥pœ³+‡@GÌS`R.Ó“‡YÑ ”t< ]pkI}ù'Yð×BPæ ´Ppž˜å…X0€3i±€»‡_0‰Q”&oE?ÐÿGG‹G’å ¾J4ÙwÆé~JòðB ’js]56EàVY>þ ’R7æSaN’’r$°M×p 1Q$™ß²\¥jª¨Z)€`ÜR†.Jao‚˜¡Sm– Š—‰@( ³7A?Ûh^…b!I±úƒ$;aô´Ær†sáw[©`lÑ1s–"s[Ù2¶Á€\óâ ¦Mp]ðOà$O °Æw{·×°LYò*1Kvåâ ±€JòŠ.VÁw– Ðh˜€"š $ÊEH@¹qXyzh>" Ý g‚]Þi(ñG4Á€ Ùà`B°?D)Üñ?yd6À‰¨àmð ŠbA«2s#÷ÐLo§È€þ=ÿÂ#$¿"¡a³Šª:»QQ/ãw±[S„9ëX"£ ÆòJ0 ¢‰ˆ©n( ê Ê00Ú×1œÈÐt—Ù-s4"æqG!YNÛG¥F ‚!ÈB€ÅY‚J þ<À±r•Y‚ZÕz0^»hñ9#s y½UoL"03 ÿQ7iø2Ï[eÆ$KW ©ÿÑU< QAA0iRWó¼\€Ô\ÐüÌ©|w Rb aÐPð`0c°WÀ[ Šd„åp_ž EÑ“FÈ#e úE_ÍPÜ` ØÔNâqJ!°LfwUc=£*ÕD9Hlx"   GˆA¶ÞÀ·ÁÊ0*D롱öpEPe\rÐC"‰pÂÐ ½ÐY¡9e´µ&_”mÑ®ô½Ñ]i r€"%„AÒJ¢pl„JÁ°þÚbÛÒƒýÒ„Ótó·nl"s/â˜eièriÁ&ʽ?°d{x RáˆE0à5¥Ò‡‘½C–‚–"@(WsÂ\¿à]¨9IÐ –<Æ#² U‡±„Ú„ÁðØXD˜ý‘qÄD¡ÒÈP}€¡PÅ…G®@*Ž³ W68)À,ÁËhù5“ëT6 :fó`(ØÝROTm9:2 ž@$’HgH"†”.èé`O²þÂ.È’^hÉ$hÝVì5(h ±^ZÓ,[ Tàæc°ælÕdÿ欬æT`ñþJa0çn~Ôw»D†»Ýc]§—f^—²UþiÀ¹/dj×ðÈ$ ‚fy ¦ž=XJð˜aŠŽÜðAG]rZæ1àNȼ@ ÑÍ ?ºÆ %Qõ/ñ@„ÉÑ@pů Qùp Á 4ÉŽÚ¨ “Ž¸2_§öÖO•0Vq/J‘^ù Ññ€ÅSbo D²my Ña  ´ÍM -pOO]Õaf€çÿÕ°¯æç\ÐþçÀOÕkÞç[ð( 5‰¦šVø«°UìÀØE9«8 ëåíôPSÆVA `ŠªBõ€ÅBɾ-Í…NITij9³dŒÀiÐ0|T… ×`S'171eÇQ)Æ]«A‚‚>5>>A5!2ˆ‚F$ ‘‘”••“9 &&#+¤AK7>** #?E$<%EJJ-?*KCC*A*76Ä7A>!‚B7ÃÄ6Ì6 ,,7D/Œ‚/Õ0FFØ>HH2D5"ƒ¾"*H-EEòçÒ6-ï*µðEBI2*í<á‘¡H E2ŽÙRÂd‹˜-ð¨H$#%L˜-[–pþÙB†L™0T¶xñ" *`0^Ie̘(dÆl¹rL‘&Z¨Í Îl¼xñì íT@h‘რ7’ùpȃ’© y¨¤ÆSE‚¹÷aD°GŽ)ñ¢0ÈÕ`fdƒC‡Ýâ ŒƒxCHI… "$´€ ašžåj„õ°Bˆ ´(3C¢S‚„(Q¢BÈÀLÆ7f€Ÿ2zº$$I*¥H¦Ò™L)TüøáÄC@FŒ8` ª$x‚„ #´"¤È%H†J­ô#>d$I"ˆXg=mÐ bD„ "DòÞ AÌH#A¼É aþ‰ˆCâ¨ðÎ!l à=T^ °Âð¨‚Ä >4„:2¬ð †ð0„KZ Áe” ©Š0‘!Ä+>!cUTÁ,&QF…Gd€!%xàÁ=Ü@zBuÄ eC¸£B1µÀ  0 ÷ÎXÀÜ`ÄPñ‘ÆÌ=ZvO HœâŒ5•Žg5À22h3#!ø% ÇHB,¶žI€L-´ÃÔZGÈ3‚NA„À * @Ph¢™iT7¤öTx2´öZ$±Q2[m”ÜÖ€ªºñæpÂgr[-×ÜsÑ­CuØiwÃxžxþäazͨǞ{w"3_}÷å÷ þˆ„€Eh š ²çƒBxÖ:Zˆ¡†2p胇 ŠH¢‰¥¸…E,vôbŒ3Öxã9îØã Y‘F"©dPà õ ”SRi%–"h™—^ÂC©˜dú`æ h& æZm6 §œC$&Aw.¢§?Èø¹ >J¨¡ˆz¶h£îTB¤L Œ¥ÌŒ«ixPŒ7—DX Un„$’T"€HÈÆ°îæ„ ¿…2Ø 1lÚ ñÃ; °É×_óЄ òÌÅ!f ¾A„35ÞCTÄTqÞ3úáz—ú0Cþ‡ âç*ü2Õ!÷,ÅàD‘„V¬^|‚ü¢Ä_g VbC-H„ER„F(rÅ2†ÁMháÒŠ!ÑTBeTA…sc„a¼0 AELc€a…Lh>¡D A4kC8e„C´ AçºDjßD|yÃ5ËàŒ- ‚ò  ÐxÆbûIÿ@uƒÐ´%2aÄ!"ˆà.†h P h`F( ŠV„(òˆ1‚ð”$x`€ºAàÃÀŵ¦R%èÄ!@âh@ª 0)XâˆHLbxÐBäà%Åþ,±ÿ‚8Â7 Ná§?ãÁøê3„΀>ÅÕ{ˆAC# r‡H„¶²S„+´@DÓY<àƒ0¸¤EPy$•I§@ Ƹ#| k(Gt„½1x! RhÑŠ¶Ð’ì1/ !ÙÀ°£øˆ"Bèˆ.RR„Ý\a8(‚ î„Hà„<ЂP‚&AØ 3h@ƒi=£Xã Áx‚ ôµ`T5LU6 Až ¦˜*Åô܃'båTcÀun€ ø û¤˜ÎU@HÈzp„ÈC Â5&&iÝ€Ú˜ÝâØ(`í XbÊPUýþ²b'ˆè (1€ˆZq èÇ ‚0|Ç>DøÔ! ržÎ'>L“.EŒ'<ˆÀG‡`xÐä8C@_úø¨#ÒAä%_É"(Y.AÅHB#¹À5€! ¦ŒÉõ8’0ð`w i‰Ž\…*”a ' ‰KœçNruLèÂX¶Ðšt¡ M¸Ž¤`‹&@a®3  cè/ Ä iO| Ë_ ¨é;„øøÀQšÒA6>öI±ï1Ä žü„:ˆµAD1F9¤=‡‘6DÀ3€À JtÀ 2 „(ð-(ÏÏ©DØ4ôþ¸ MÁ/UA€t°€$¨í[dyd¤$=#ö󅌔2¿EÎ+ïéNHaE ‡ ƒH7š´à8‚¢’v–=?nÁ `ÐM>°‚ï†=Ê Ê®g+øî‘T(ƒ‹‚$‘ëA ó’h÷;2à‹ ÷ú'Çp…Ú²R&.±¤ŒÀÐ….<©.~M`ÜWž0ŒY5[™~= ü**Ñ<ˆ”˜(¿ñïEè“dŸá•Êµ@äøÉ\B5Y¿È`È‹¹@2!‚!0(4 š¥%ŽÐ,¨Á= §QmâøaBªPäÚù ªàA$(p\ ¡þÂD>ÇCëªÀHª`‘ÓE·Ààñ…Ç›„c†çpìõÂàS0ŒÁ -°Èn²³ AGKà¯K®P0€á (•½’àg<ã‘%¨P#¯†U"œìj…Ãp… ÷ÚD-Òž ?fo Ú£ )ÇÀg»¸ SÀÈLT­"™¼µ <˜€þn@îÔN…øF墈C@ieO)Ö}D ²n  © æ3oà‹$¡|Q¹Ô3±ˆ$À@Jði¯š>â*=Ù1Â#¨F1¨>` xp@™Âª€‡G.  7È=ÃD‹3ãâ3¸¥@Dš‚R«`mþ"´ àáÁäç¦VEæ< I§5cÒ'~Œô¹š” FCÀÀ…+4A‡¸‚Ð@É“ÄDÔc€PÐTÍ«CH%ŠJd"*€’­BõŠ¬ †Ž¨×lg^@“ë1a&÷`56†€É„­¬þ»´ÐI‹X#!‘QdÔ xtàÀñ› ¦k& ˆ%!2ð™1”sÁptÌÿ9Ä Œ7JIÍëàYÍ<ðsÄGJU™’7HûÇúGê€|!f.¦sq Á=8^Ÿ"`)ÂÈ‹ “c å._9,\žç˜Ï<¹6Çù"—)–jÀçŠ"ì:„ÞÑ¢‹ë‰Pþúv-çtWoRê®®úÕ³¾õ®[ìb7dgv=ÁojU%¢a!ÑqçGsWwdpw^U"zÇw(âw€×‚Gx†‡mÅ[°xçx·’GyæryÕy†ƒ œ×žz~SLÌd$ŠP|ΤA©ç«×zCðz:Áí0{µ'·wY<&%»|írÀ×ÂG|Æ·‹‘|ª`(Tíð,``!’@D prÈEE”7Ç•»ÁL •LP!7ÛB”9ªà âP9w˜ ™³-{˜SZô ‰2•$mýu<A“×V@Ÿ†`a{ça-t?þà Cã5BÍ` aXa*AU Æ÷üÐÕP9?æÊ‚n‡à.üs Z²h1ÒLñ€q¾p  ¨`„I† q“OOñ Ћ1@ H°Äw,n4P%P@P#P$@ V$†A”D €}°5J`g •Ôáp¸P!—hˆ$tÀ7™,‡¾°bw™£EeuWUr'àëÃ?9v(-Ð]Ò7Q ]'ÐÍ”(Ôà˜> ™  ª P†9% DÉ9†› ‘‘²…º†Ôá¼ÑCB@þo@ð†š;À“jE‘° ›`Å&€ÐE) Q¢@~®VŒ×ˆ¬f©ä¶*ÐIÛ£³x0b”eu[ )öj=Т¦ÿ¥ŒEv{ EðRðu:®w$V&QŠ#µXÓöi$6ww= mÚFbÕ&j-&®\@/Öª!S…‡wì .æ-öbš;° ù¤,üŽG &d‚’pFÀG€¤òpr ÌöŒ2òPÐðà=ø4ä„ѨA}¢·ðâñd"P:KQ 0À°e °° %0 `¾3þËœ—Ú§°³Èņ¼1N€¿4S D 7’Ê ðKQ" °òã žÖVŦ=ÛÐ6žv0yËiMІ˔pU.¶$–«=àP0_VPq4±&øw¡¡cPŠ2áU(Q‰˜X‹XÕUŠÃ#/ºeÕŠ–‡—)±=ž=LÜVWðpùŒs9úiÄ{G@;0`勺ÔáC±FA°„ÀQÍäAÌDXiñVI0Î!ðꢇ&5pP¬p º1-WW0,–!8p ¹&YÐÈLàÈã{¾`¾þ諾|Š©+[‘ïÀ4'6ôk¿B€¿úÛüÛ¿$ À<<œH€À=ÎÑÀ¤óÅìÌ­ vÁÈÆÛÁ~t ,Â$lÂE€ÂW ÂOÀÂaà¶ÿCÃ[`îÆ`¼æU;\#]E?ÄøRx@ŒFü_.A¬Kì€ôJP<®]0ÅU|ÅY¼Å¯äÅ1±x` ƶe|ÆiŒSlì^oÜqÌ“<@Ç]`Ç`šÇÁ°Ç}¬\1‚LÈ;wÈS”Èj°Èœ¬Ñã»ê;É%¾sŠ©9@A€ì»É E„ ’) QG”ù[©‘€Q•ê†–š§ ,@þo¼%2 ÇÓoÇLÜ\ µÌTbàÅ(º¤£Ÿ11)Ál«Ä0qLÌ:VΣDuS`\Ð[Ru=&J?=mWfÐ<×XÐb°Š ñÅ(F\À4Á÷BhË-âa!JN u W¹3®ppC¡#1`Ð@0i1%àFÄ@CÏ1 íå…¹Eã¥LÖÕJ0®ù÷¢U§ukáeéT”‚\›ŠcPpð}ˆ¬ bàÂÑb '@œ à É}šìûDñ›§gÐ áÆÛGdQÏbÀÜ°@ ÔI©:½³Ò%Îþ!ôv.1W^×(Â#+òKœÖH4qßS¸4±Rº[Ŷ ¶^Pf»•‡§w×m£d<2a<Ì#œQŽ'lÄ##^0MÍTE0J`u^ň^ðHeЊ"îx…m<!¯ÐxWÛúŒÐXmV¤às<¯†Ks‹ÅW ?ÀPÀZ #=ãÑ@P—~Tm$¶x]7Ú I |â@¶HðvËVM°i Ò­b0W< ÑY $I7_sÜçk¾Î]‘ €©:+] u°0NÀÉ|’T²Ðü]¶\ΦX"§(akÇ#Lo+¡þžÄWPx&=1P ÖÓü%<.Ê:º”¦ëlV§/Q#±"“î€÷2>iŒÚv[€fþ½"d?2¬$ÙSV+áx–®#&¾­såbÛªŒR «ÃÊÍ•¨ãGC #ßóV[°WP¼u”í”ð4#Âó¢ÆZ¤Ý±A0yrG²êú Yç æ-‘@´g°sJ ]%ýæ#MÒЧ¼½ à u }þð ¥ÅG² PÁæÜv'±"µ(UaÜÓVmŽ·dàeë•(a‘huLàvçŠUÆÆx[Àwâ,O-þp<%ºŸÁê ¯ |ÖžFòÆFÊF8P–˜jHŸvk=qía‡§m—~â0ÑÞ.Ï#åód ¬ñ*Ȥëبm¹]<0WÔjõ>"—ë pÕ{˜éxE¹Pð*HTÞtÛÇݹ²K» ØIÒZ‘¼ý5O@s°à%ñ”_3wÅK² JZUŸ0QªÎ`Zåó-Q0dЕhBàõñ¶W¡v÷ËpeòÐÖöUÒã—§ÔŠ…·"žUÿ“ܬ¤D:YõuÕ,a&áÞýÅv&âiûù5׌¯õ)‘RÍq=¼CŸÄþîuWàA-Ðz ¤ïÚ¯æjoµ(ª#M€rG¯ìúboµ®è¿ì)ÎT²ž€ðtÀPPX8P¤¦†åÄÄ”Xp¶“sÙ€™™ÓÐéy zIzrbùd¨Z˜21áT²*;K[k»ZZpÕtuud ÀEE5FEF66VDFmvLE]=Æ FÖ’½,TÕ½µ¥¤T$Ľ†<ÖÔ䥲Ö……U6¦•® 32ð–)#SlÛ±t›qIF™+Ķù“­ ™pܺ…)²L²oОl)ÆM .]”ÅÛr¤FjÕÈT9§e ¹gÛ®hÐТË)]ŠJáÒþÌŒ]šìX¶ŒZ,Ëü) Ê–Mž<):ôJ:.dÅbä"ˆ*DŠ9‚$ ¥¥r%0À‰u„ú j€©[†r¸zekdžL ÖE·Öâté1)‚q¬<ªQÓÉ)R„“ •+PÃ`ã¦3›?cÛZ£Ç“"a®ðà¡tH_¨e—RÆ‹¨øÆe 1Lº%Ƹ¨îy¬ê609ým¡Rææ¹cWŒ¡ŒÆmÛ³-A‚œ³òO .<ÈX1¶…nñÇ  C†ƒŒ/G,xÄò1t…P]1õ]>-•y1ô/c}ÑD¤I<þý5ñ'µ°àH`D2I%Œ²` @€,)t¢ãaEÌxËdv)–•b«DrEJ\±äZ0)ÖWq4ÑTÕTUP¡Òm:…A–W`lÑÃKT¡Æt£E¡D Òu¶^”9³¼YÑž€¹• ¥£RG`(^Ë8#XTX!(ELÅM"a´ÌMP¹ý€‰†j™bDFQúr ®ýé!¦ÏˆÄM5¥7Æ8dUðĶG‘ˆÏþ]!H[p££]–*V4Ï5ñEVdp!Vã<ד¥É5ÒÙЂ0ÛXeþÔB•? f’1œà™‰ µ +L S×R™š¡l¬‰cßQx,µ%Oe,k"3Ö6RÐDd =P…§öÆ–BHÖ Ž\ "éøÆÿ€¦³f,Qe¨Ô?œp“•lå9!K².ÌÇ+ÑjÂS ”ó#@g:i!ÄK°Ó9€§*äIO{âsúägüùÏ€Ô›}B¡P†:i6•(\acQŒj”£KHïDR“¥´ÂJás,ïÁT¦Ö²BMËsS¯üg§=­ÆO %TÁ*£¨G%CRM™‚¬i®hŠª/©’‚ø£Z…[W¿šM±–'eþ­*Zu[¶þ'kŠ++Ÿj©ºVá®yE _ûZ>Àöj°O(ìai”ØÅ6ö±ùŒÜINäà²N€(ó‘f HsÅ6+‹ÓÁ+ðì…™Œ±UaJW8õ““ 7Š]¡ñ_?BJ Rñàdlƨ€ÌPƒ,"èÆÄóŸd(ãyU¡Î{¨  áBœÁ(x õ6WØO:ÜÁ0ЃÑèSÄàÁ$%0!¢uê °cpÇ›´QŒa ¶zÊ“Ž.Üã*XcüŒ¡„ÛXÁ fx*H2´Ê~ô£3´PÞL »2£aÂMš@04 H“þÂ4†Ùj  H,Y²N(³_A9ÌàÏÝÓLèÄ2qNLØg8+(‰ ì >ÊW?yñ…hS `‚À@ œjaI쀓/³@øgöÐÉD¼„òhaað‚œb…Œ*LD h€}x°„©@ !a ñAP²âÛ‚n:%Šl©Ï¨ä±T°ŒˆÌ9d!ÔC2U ·ñÀ4ç¨ßIzò›bÔ$qÏ•4bHŒð€ ¾ã†žkÅC6ÖÆýœ&ÅÅÕ&P I–’TZ䉲ABÐP…aò€]Uº ª 3vé(•WŠ²…®L² <(ÂþašX d`ìŽ@'xà‰Î(:\^6ÄB[ À‚\Q³nY¸_²1¦%bÈ:ɤ7M oj<&‚1&T5è8[Æ@_Àæ-ðË ‘1.ˆÀ kðyšA†#ÜÇKX>Æ› ¾Pe¾8܈XÐÖ…(táå:ûˆƒ½’„Í•|]×À4ƒƒhRœ0-éh y¦Ô²œÃƒJNmSàÆtâËòàšjj3Òä„.DÑ:ÒÑ$†úéª SÏŠÁ¢¥—=œ;è‚®"Eñ:±ÑöMwPdA(°c—’I r¡þg÷W)é`L ¦a âñ »âVÑÐ{Õ÷mÍsdàÙ'T¥’s Ù *a `QÄP ûHáÐ ¤ek2×"(h ŠP° "3ya 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.15/examples_labltk/clock.ml0000644000175000017500000001146214745615735017015 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$ *) (* Clock/V, a simple clock. Reverts every time you push the right button. Adapted from ASCII/V May 1997 Uses Tk and Unix, so you must link with labltklink unix.cma clock.ml -o clock -cclib -lunix *) open Tk (* pi is not a constant! *) let pi = acos (-1.) (* The main class: * create it with a parent: [new clock parent:top] * initialize with [#init] *) class clock ~parent = object (self) (* Instance variables *) val canvas = Canvas.create ~width:100 ~height:100 parent val mutable height = 100 val mutable width = 100 val mutable rflag = -1 (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) initializer (* Create the oval border *) Canvas.create_oval canvas ~tags:["cadran"] ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) ~width:3 ~outline:`Yellow ~fill:`White; (* Draw the figures *) self#draw_figures; (* Create the arrows with dummy position *) Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["hours"] ~fill:`Red; Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["minutes"] ~fill:`Blue; Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["seconds"] ~fill:`Black; (* Setup a timer every second *) let rec timer () = self#draw_arrows (Unix.localtime (Unix.time ())); Timer.add ~ms:1000 ~callback:timer; () in timer (); (* Redraw when configured (changes size) *) bind canvas ~events:[`Configure] ~action: begin fun _ -> width <- Winfo.width canvas; height <- Winfo.height canvas; self#redraw end; (* Change direction with right button *) bind canvas ~events:[`ButtonPressDetail 3] ~action:(fun _ -> rflag <- -rflag; self#redraw); (* Pack, expanding in both directions *) pack ~fill:`Both ~expand:true [canvas] (* Redraw everything *) method redraw = Canvas.coords_set canvas (`Tag "cadran") ~xys:[ 1, 1; width - 2, height - 2 ]; self#draw_figures; self#draw_arrows (Unix.localtime (Unix.time ())) (* Delete and redraw the figures *) method draw_figures = Canvas.delete canvas [`Tag "figures"]; for i = 1 to 12 do let angle = float (rflag * i - 3) *. pi /. 6. in Canvas.create_text canvas ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) ~tags:["figures"] ~text:(string_of_int i) ~font:"variable" ~anchor:`Center done (* Resize and reposition the arrows *) method draw_arrows tm = Canvas.configure_line ~width:(min width height / 40) canvas (`Tag "hours"); let hangle = float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) *. pi /. 360. in Canvas.coords_set canvas (`Tag "hours") ~xys:[ self#x 0., self#y 0.; self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; Canvas.configure_line ~width:(min width height / 50) canvas (`Tag "minutes"); let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in Canvas.coords_set canvas (`Tag "minutes") ~xys:[ self#x 0., self#y 0.; self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in Canvas.coords_set canvas (`Tag "seconds") ~xys:[ self#x 0., self#y 0.; self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] end (* Initialize the Tcl interpreter *) let top = openTk () (* Create a clock on the main window *) let clock = new clock ~parent:top (* Wait for events *) let _ = mainLoop () labltk-8.06.15/examples_labltk/demo.ml0000644000175000017500000001335314745615735016647 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.15/examples_labltk/eyes.ml0000644000175000017500000000462014745615735016665 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.15/examples_labltk/hello.ml0000644000175000017500000000335214745615735017024 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$ *) (* LablTk4 Demonstration by JPF *) (* First, open this modules for convenience *) open Tk (* initialization of Tk --- the result is a toplevel widget *) let top = openTk () (* create a button on top *) (* Button.create : use of create function defined in button.ml *) (* But you shouldn't open Button module for other widget class modules use *) let b = Button.create ~text: "Hello, LablTk!" top (* Lack of toplevel expressions in lsl, you must use dummy let exp. *) let _ = pack [coe b] (* Last, you must call mainLoop *) (* You can write just let _ = mainLoop () *) (* But Printexc.print will help you *) let _ = Printexc.print mainLoop () labltk-8.06.15/examples_labltk/hello.tcl0000755000175000017500000000217314745615735017201 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.15/examples_labltk/lang.ml0000644000175000017500000000623014745615735016640 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.15/examples_labltk/taquin.ml0000644000175000017500000001145614745615735017226 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 découpe_image img nx ny = let l = Imagephoto.width img and h = Imagephoto.height img in let tx = l / nx and ty = h / ny in let pièces = ref [] in for x = 0 to nx - 1 do for y = 0 to ny - 1 do let pièce = Imagephoto.create ~width:tx ~height:ty () in Imagephoto.copy ~src:img ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pièce; pièces := pièce :: !pièces done done; (tx, ty, List.tl !pièces);; let remplir_taquin c nx ny tx ty pièces = let trou_x = ref (nx - 1) and trou_y = ref (ny - 1) in let trou = Canvas.create_rectangle ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in let taquin = Array.make_matrix nx ny trou in let p = ref pièces in for x = 0 to nx - 1 do for y = 0 to ny - 1 do match !p with | [] -> () | pièce :: reste -> taquin.(x).(y) <- Canvas.create_image ~x:(x * tx) ~y:(y * ty) ~image:pièce ~anchor:`Nw ~tags:["pièce"] c; p := reste done done; let déplacer x y = let pièce = taquin.(x).(y) in Canvas.coords_set c pièce ~xys:[!trou_x * tx, !trou_y * ty]; Canvas.coords_set c trou ~xys:[x * tx, y * ty; tx, ty]; taquin.(!trou_x).(!trou_y) <- pièce; taquin.(x).(y) <- trou; trou_x := x; trou_y := y in let jouer ei = let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) then déplacer x y in Canvas.bind ~events:[`ButtonPress] ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pièce");; let rec permutation = function | [] -> [] | l -> let n = Random.int (List.length l) in let (élément, reste) = partage l n in élément :: permutation reste and partage l n = match l with | [] -> failwith "partage" | tête :: reste -> if n = 0 then (tête, reste) else let (élément, reste') = partage reste (n - 1) in (élément, tête :: reste');; let create_filled_text parent lines = let lnum = List.length lines and lwidth = List.fold_right (fun line max -> let l = String.length line in if l > max then l else max) lines 1 in let txtw = Text.create ~width:lwidth ~height:lnum parent in List.iter (fun line -> Text.insert ~index:(`End, []) ~text:line txtw; Text.insert ~index:(`End, []) ~text:"\n" txtw) lines; txtw;; let give_help parent lines () = let help_window = Toplevel.create parent in Wm.title_set help_window "Help"; let help_frame = Frame.create help_window in let help_txtw = create_filled_text help_frame lines in let quit_help () = destroy help_window in let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in pack ~side:`Bottom [help_txtw]; pack ~side:`Bottom [ok_button ]; pack [help_frame];; let taquin nom_fichier nx ny = let fp = openTk () in Wm.title_set fp "Taquin"; let img = Imagephoto.create ~file:nom_fichier () in let c = Canvas.create ~background:`Black ~width:(Imagephoto.width img) ~height:(Imagephoto.height img) fp in let (tx, ty, pièces) = découpe_image img nx ny in remplir_taquin c nx ny tx ty (permutation pièces); pack [c]; let quit = Button.create ~text:"Quit" ~command:closeTk fp in let help_lines = ["Pour jouer, cliquer sur une des pièces"; "entourant le trou"; ""; "To play, click on a part around the hole"] in let help = Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in pack ~side:`Left ~fill:`X [quit] ; pack ~side:`Left ~fill:`X [help] ; mainLoop ();; if !Sys.interactive then () else begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; labltk-8.06.15/examples_labltk/tetris.ml0000644000175000017500000004273314745615735017241 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.15/frx/0002755000175000017500000000000014745615735013016 5ustar stephstephlabltk-8.06.15/frx/.depend0000644000175000017500000000245614745615735014263 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.15/frx/Makefile0000644000175000017500000000442614745615735014462 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.15/frx/Makefile.nt0000644000175000017500000000211214745615735015070 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.15/frx/README0000644000175000017500000000010714745615735013672 0ustar stephstephThis is Francois Rouaix's widget set library, Frx. It uses CamlTk API. labltk-8.06.15/frx/frx_after.ml0000644000175000017500000000262014745615735015326 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.15/frx/frx_after.mli0000644000175000017500000000226514745615735015504 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.15/frx/frx_color.ml0000644000175000017500000000313514745615735015345 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.15/frx/frx_color.mli0000644000175000017500000000216114745615735015514 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.15/frx/frx_ctext.ml0000644000175000017500000000623614745615735015363 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.15/frx/frx_ctext.mli0000644000175000017500000000256014745615735015530 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.15/frx/frx_dialog.ml0000644000175000017500000001035514745615735015470 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.15/frx/frx_dialog.mli0000644000175000017500000000253714745615735015644 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.15/frx/frx_entry.ml0000644000175000017500000000345314745615735015373 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.15/frx/frx_entry.mli0000644000175000017500000000326614745615735015546 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.15/frx/frx_fileinput.ml0000644000175000017500000000271314745615735016227 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.15/frx/frx_fillbox.ml0000644000175000017500000000607414745615735015673 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.15/frx/frx_fillbox.mli0000644000175000017500000000326314745615735016041 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.15/frx/frx_fit.ml0000644000175000017500000000626714745615735015022 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.15/frx/frx_fit.mli0000644000175000017500000000313314745615735015160 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.15/frx/frx_focus.ml0000644000175000017500000000257614745615735015356 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.15/frx/frx_focus.mli0000644000175000017500000000221214745615735015512 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.15/frx/frx_font.ml0000644000175000017500000000414314745615735015175 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.15/frx/frx_font.mli0000644000175000017500000000245614745615735015353 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.15/frx/frx_group.ml0000644000175000017500000000231314745615735015360 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.15/frx/frx_lbutton.ml0000644000175000017500000000402314745615735015713 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.15/frx/frx_lbutton.mli0000644000175000017500000000234314745615735016067 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.15/frx/frx_listbox.ml0000644000175000017500000000700114745615735015707 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.15/frx/frx_listbox.mli0000644000175000017500000000327514745615735016071 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.15/frx/frx_mem.ml0000644000175000017500000001001114745615735014774 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.15/frx/frx_mem.mli0000644000175000017500000000247714745615735015166 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.15/frx/frx_misc.ml0000644000175000017500000000500014745615735015153 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.15/frx/frx_misc.mli0000644000175000017500000000253214745615735015333 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.15/frx/frx_req.ml0000644000175000017500000001633514745615735015024 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.15/frx/frx_req.mli0000644000175000017500000000425214745615735015170 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.15/frx/frx_rpc.ml0000644000175000017500000000404414745615735015013 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.15/frx/frx_rpc.mli0000644000175000017500000000270014745615735015161 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.15/frx/frx_selection.ml0000644000175000017500000000377414745615735016225 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.15/frx/frx_selection.mli0000644000175000017500000000224314745615735016364 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.15/frx/frx_synth.ml0000644000175000017500000000635514745615735015403 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.15/frx/frx_synth.mli0000644000175000017500000000266114745615735015550 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.15/frx/frx_text.ml0000644000175000017500000002041114745615735015207 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.15/frx/frx_text.mli0000644000175000017500000000413114745615735015361 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.15/frx/frx_toplevel.mli0000644000175000017500000000220414745615735016226 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.15/frx/frx_widget.ml0000644000175000017500000000246614745615735015520 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.15/frx/frx_widget.mli0000644000175000017500000000221614745615735015662 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.15/frx/frxlib.mllib0000644000175000017500000000026314745615735015324 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.15/jpf/0002755000175000017500000000000014745615735012776 5ustar stephstephlabltk-8.06.15/jpf/Makefile0000644000175000017500000000572714745615735014447 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 -I +str -I +unix 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.15/jpf/Makefile.nt0000644000175000017500000000211214745615735015050 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.15/jpf/README0000644000175000017500000000010214745615735013645 0ustar stephstephThis is Jun Furuse's widget set library, Jpf. It uses LablTk API. labltk-8.06.15/jpf/balloon.ml0000644000175000017500000000723514745615735014763 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.15/jpf/balloon.mli0000644000175000017500000000236214745615735015130 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.15/jpf/balloontest.ml0000644000175000017500000000257214745615735015662 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.15/jpf/fileselect.ml0000644000175000017500000003135014745615735015447 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.15/jpf/fileselect.mli0000644000175000017500000000316314745615735015621 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.15/jpf/jpf_font.ml0000644000175000017500000001542114745615735015136 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.15/jpf/jpf_font.mli0000644000175000017500000000403714745615735015310 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.15/jpf/jpflib.mllib0000644000175000017500000000004214745615735015257 0ustar stephstephFileselect Balloon Shell Jpf_font labltk-8.06.15/jpf/shell.ml0000644000175000017500000000323414745615735014437 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.15/jpf/shell.mli0000644000175000017500000000217314745615735014611 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.15/labl.gif0000644000175000017500000000277514745615735013631 0ustar stephstephGIF89a9.ÆÇÃǾ¾¾ž¢ž–š–¶º¶uuuŽ’ŽŽŽŽuqm}yu®®®žžž}‚}]Q<ŽuEMA,EAE†‚†]UM†qE¦ŠMß²]eU4<8  1DÆbÀ„™¾= Ξˆ ePD´~’PƒžÔ¢¦Ã1¸)<",°IG.}^ 9AÁÙÓ3¢AZŒ@stÜDAô„ÊpÓyë¹äîKeZ<·8T òg‰ø$k8ÙP5²Ú±\Ê€BˆŒLJ}£ %"À…/t]…J;labltk-8.06.15/labltk/0002755000175000017500000000000014745615735013470 5ustar stephstephlabltk-8.06.15/labltk/.gitignore0000644000175000017500000000004414745615735015454 0ustar stephsteph.depend *.ml *.mli labltktop labltk labltk-8.06.15/labltk/Makefile0000644000175000017500000000405514745615735015132 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 -I +unix 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.15/labltk/Makefile.gen0000644000175000017500000000502714745615735015702 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.15/labltk/Makefile.gen.nt0000644000175000017500000000211614745615735016316 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.15/labltk/Makefile.nt0000644000175000017500000000211214745615735015542 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.15/labltk/byte.itarget0000644000175000017500000000067314745615735016020 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.15/labltk/modules0000644000175000017500000000512314745615735015062 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.15/labltk/native.itarget0000644000175000017500000000065014745615735016336 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.15/lib/0002755000175000017500000000000014745615735012765 5ustar stephstephlabltk-8.06.15/lib/.gitignore0000644000175000017500000000006114745615735014750 0ustar stephstephlabltktop labltk mltktop mltk .depend *.ml *.mli labltk-8.06.15/lib/Makefile0000644000175000017500000000773514745615735014437 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 -I +unix -I +str unix.cma str.cma \ -I ../labltk -I ../camltk $(LIBNAME).cma \ $(TOPLEVELSTART) $(LIBNAME): Makefile @echo Generate $@ @echo "#!/bin/sh" > $@ @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@ install-script: $(LIBNAME) cp $(LIBNAME) $(INSTALLBINDIR) chmod 755 $(INSTALLBINDIR)/$(LIBNAME) install-batch: cp labltk.bat $(INSTALLBINDIR) ifeq ($USE_FINDLIB,yes) install: ocamlfind install labltk -add $(LIBNAME).cma $(LIBNAME)top$(EXE) chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) @case x$(TOOLCHAIN) in \ xmingw|xmsvc) $(MAKE) install-batch ;; \ *) $(MAKE) install-script ;; \ esac installopt: ocamlfind install labltk -add $(LIBNAME).cmxa $(LIBNAME).$(A) cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) else install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/$(LIBNAME).cma chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) @if test -d $(INSTALLBINDIR); then : ; else mkdir $(INSTALLBINDIR); fi @case x$(TOOLCHAIN) in \ xmingw|xmsvc) $(MAKE) install-batch ;; \ *) $(MAKE) install-script ;; \ esac installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A) endif labltk-8.06.15/lib/Makefile.nt0000644000175000017500000000211214745615735015037 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.15/lib/labltk.bat0000755000175000017500000000007014745615735014724 0ustar stephsteph@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 labltk-8.06.15/support/0002755000175000017500000000000014745615735013733 5ustar stephstephlabltk-8.06.15/support/.depend0000644000175000017500000000227114745615735015173 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.15/support/META0000644000175000017500000000267314745615735014412 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.15/support/Makefile0000644000175000017500000000672414745615735015402 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=-I +unix 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.15/support/Makefile.common0000644000175000017500000000307614745615735016666 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 ifeq (x$(RANLIB),x) RANLIB=":" endif labltk-8.06.15/support/Makefile.nt0000644000175000017500000000211214745615735016005 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.15/support/byte.itarget0000644000175000017500000000016714745615735016261 0ustar stephstephsupport.cmo rawwidget.cmo widget.cmo protocol.cmo textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo tkthread.cmo labltk-8.06.15/support/camltk.h0000644000175000017500000000503414745615735015357 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 /*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 const value *tkerror_exn; extern const value *handler_code; extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, const 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.15/support/camltkwrap.ml0000644000175000017500000000510314745615735016427 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.15/support/camltkwrap.mli0000644000175000017500000002132514745615735016604 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.15/support/cltkCaml.c0000644000175000017500000000555214745615735015636 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" const value * tkerror_exn = NULL; const value * handler_code = NULL; /* The Tcl command for evaluating callback in OCaml */ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, const 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, (char*)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.15/support/cltkDMain.c0000644000175000017500000001645014745615735015751 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 */ Tcl_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.15/support/cltkEval.c0000644000175000017500000001610114745615735015641 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.15/support/cltkEvent.c0000644000175000017500000000354314745615735016041 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; Tcl_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[] = { TCL_DONT_WAIT, /*TCL_X_EVENTS,*/ TCL_FILE_EVENTS, TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, TCL_ALL_EVENTS }; CAMLprim value camltk_dooneevent(value flags) { int ret; CheckInit(); ret = Tcl_DoOneEvent(caml_convert_flag_list(flags, event_flag_table)); return Val_int(ret); } labltk-8.06.15/support/cltkFile.c0000644000175000017500000001101414745615735015627 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.15/support/cltkImg.c0000644000175000017500000001022714745615735015471 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(value *argv, int argn) { return camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } labltk-8.06.15/support/cltkMain.c0000644000175000017500000001273614745615735015650 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 */ Tcl_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); const 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 */ const 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; const char **tkargv; char argcstr[256]; /* string of argc */ tkargv = (const 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.15/support/cltkMisc.c0000644000175000017500000000424714745615735015655 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) { #ifdef TCL_SIZE_MAX Tcl_Size argc; #else int argc; #endif 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.15/support/cltkTimer.c0000644000175000017500000000334714745615735016042 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.15/support/cltkUtf.c0000644000175000017500000000475014745615735015517 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.15/support/cltkVar.c0000644000175000017500000001031214745615735015500 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) (ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags); */ static char * tracevar(ClientData clientdata, Tcl_Interp *interp, const char *name1, const char *name2, int flags) /* interp -> Interpreter containing variable. */ /* name1 -> Name of variable. */ /* name2 -> Second part of variable name. */ /* 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.15/support/cltkWait.c0000644000175000017500000000713114745615735015661 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 (ClientData clientData, XEvent *eventPtr); static void WaitWindowProc (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 clientData, XEvent *eventPtr) { 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.15/support/fileevent.ml0000644000175000017500000000544014745615735016247 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.15/support/fileevent.mli0000644000175000017500000000256614745615735016426 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.15/support/liblabltk.clib0000644000175000017500000000017014745615735016522 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.15/support/native.itarget0000644000175000017500000000016714745615735016604 0ustar stephstephsupport.cmx rawwidget.cmx widget.cmx protocol.cmx textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx tkthread.cmx labltk-8.06.15/support/protocol.ml0000644000175000017500000002145214745615735016130 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.15/support/protocol.mli0000644000175000017500000001117514745615735016302 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.15/support/rawwidget.ml0000644000175000017500000001215014745615735016257 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.15/support/rawwidget.mli0000644000175000017500000000752014745615735016435 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.15/support/slave.ml0000644000175000017500000000402014745615735015371 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.15/support/support.ml0000644000175000017500000000363314745615735016004 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.15/support/support.mli0000644000175000017500000000241314745615735016150 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.15/support/textvariable.ml0000644000175000017500000000773214745615735016766 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.15/support/textvariable.mli0000644000175000017500000000360214745615735017127 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.15/support/timer.ml0000644000175000017500000000423414745615735015406 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.15/support/timer.mli0000644000175000017500000000234714745615735015562 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.15/support/tkthread.ml0000644000175000017500000000440514745615735016074 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.15/support/tkthread.mli0000644000175000017500000000441214745615735016243 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.15/support/tkwait.ml0000644000175000017500000000244014745615735015566 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.15/support/widget.ml0000644000175000017500000000242114745615735015545 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.15/support/widget.mli0000644000175000017500000000744614745615735015732 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*)