commit 887fa59389cbe81f92fba3f0501c9aa9788f852c Author: Don Stewart Date: Sun Apr 24 08:51:33 2005 +0000 Import hs-plugins cvs diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..f3dabc0 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,5 @@ + +Don Stewart +Sean Seefried +Andre Pang + diff --git a/BUILDING.CVS b/BUILDING.CVS new file mode 100644 index 0000000..8eea44f --- /dev/null +++ b/BUILDING.CVS @@ -0,0 +1,25 @@ +CVS BUILDING INSTRUCTIONS +========================= + +These are build instructions if you've checked out hs-plugins +from CVS (instead of downloading a source distribution tarball). + +1. Execute autogen.sh to generate the GNU ./configure script: + + ./autogen.sh + +2. Build hs-plugins as usual with ./configure && make + + +cvsps +===== + +For people who are used to more modern revision control systems +(such as Darcs, Subversion and Arch) and miss working with +'patchsets' instead of the disjoint per-file patches that CVS +uses, take a look at cvsps , +a patchset manager for CVS. While it doesn't, by any means, give +you the many advantages that more modern source control systems +offer you, it certainly makes using CVS and managing patches far +easier! + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b1e3f5a --- /dev/null +++ b/LICENSE @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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! + + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..8517098 --- /dev/null +++ b/Makefile @@ -0,0 +1,104 @@ +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + +# cut down reimplementation of $fptools/mk directory + +.PHONY: build all + +all: headers runplugs plugs + +build: + cd src && $(MAKE) + +plugs: build + ( cd examples/hmake/lib-plugs ; $(MAKE) build ) + cp examples/hmake/lib-plugs/plugs ./ + +runplugs: build + ( cd examples/hmake/one-shot ; $(MAKE) build ) + cp examples/hmake/one-shot/runplugs ./ + +headers: build + cp src/eval/Eval/Haskell_stub.h EvalHaskell.h + +# +# installing +# + +# TODO put these in subdirs +install: + $(INSTALL_DATA_DIR) $(LIBDIR)/include + $(INSTALL_DATA) EvalHaskell.h $(LIBDIR)/include + @(cd src && $(MAKE) install) + $(INSTALL_DATA_DIR) $(PREFIX)/bin + $(INSTALL_PROGRAM) plugs $(PREFIX)/bin/ + $(INSTALL_PROGRAM) runplugs $(PREFIX)/bin/ + +# +# and register the library with ghc package system +# Use this target if installing by hand. May need to be performed as root +# +register: + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/altdata/altdata.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/hi/hi.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/plugins/plugins.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/eval/eval.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/printf/printf.conf.in + +# and unregister the packages +unregister: + $(GHC_PKG) -r printf + $(GHC_PKG) -r eval + $(GHC_PKG) -r plugins + $(GHC_PKG) -r hi + $(GHC_PKG) -r altdata + +# +# regress check. TODO check expected output +# +check: + @if [ ! -f EvalHaskell.h ] ; then \ + echo "run 'make' first" ; \ + exit 1 ;\ + fi + @( d=/tmp/plugins.tmp.$$$$ ; mkdir $$d ; export TMPDIR=$$d ;\ + for i in `find examples ! -name CVS -type d -maxdepth 2 -mindepth 2` ; do \ + printf "=== testing %-50s ... " "$$i" ; \ + ( cd $$i ; if [ -f dont_test ] ; then \ + echo "ignored." ;\ + else ${MAKE} -sk && ${MAKE} -ksi check |\ + sed '/^Compil/d;/^Load/d;/Read/d;/Expan/d;/Savi/d;/Writ/d' ;\ + ${MAKE} -sk clean ;\ + fi ) 2> /dev/null ;\ + done ; rm -rf $$d ) + + +# +# making clean +# + +CLEAN_FILES += *.conf.*.old *~ +EXTRA_CLEANS+=*.conf.inplace* *.conf.in *.h autom4te.cache \ + config.h config.mk config.log config.status configure + +clean: + cd docs && $(MAKE) clean + cd src && $(MAKE) clean + rm -rf $(CLEAN_FILES) + find examples -name '*.a' -exec rm {} \; + find examples -name '*~' -exec rm {} \; + find examples -name 'a.out' -exec rm {} \; + find examples -name '*.hi' -exec rm {} \; + find examples -name '*.o' -exec rm {} \; + find examples -name '*.core' -exec rm {} \; + find examples -name 'package.conf' -exec rm {} \; + rm -rf plugs + rm -rf runplugs + rm -rf examples/hmake/lib-plugs/plugs + rm -rf examples/hmake/one-shot/runplugs + rm -f EvalHaskell.h + +distclean: clean + rm -rf $(EXTRA_CLEANS) + +include config.mk diff --git a/README b/README new file mode 100644 index 0000000..2b33b07 --- /dev/null +++ b/README @@ -0,0 +1,97 @@ + +------------------------------------------------------------------------ + hs-plugins +------------------------------------------------------------------------ + +Compiler and tool support for compiling and loading, and evaluating +Haskell at runtime. + +The library provides a convenient interface to GHC's runtime loader +and linker, letting you load compiled Haskell code. + +It also provides a `make' system for compiling plugin source +automagically and for combining the user's .hs file with a stub of +standard declarations and syntax, saving the user from having to write +standard code themselves. + +It provides an eval() function, for generating new, well-typed, +compiled code from a Haskell source string. + +It also provides a new variation of printf for Haskell-- a runtime +generated, dynamically-typed printf. + +Read the documentation in doc/ for more. + +------------------------------------------------------------------------ +DEPENDENCIES: + +* Requires GNU make or BSD make to build +* Requires GHC > 6.2 (for Typeable.h) +* 'plugs' requires a working readline library. + +* If you wish to use TH in plugins, or to run load()-programs in GHCi, + you require a patch to GHC's linker, that was committed into ghc + 6.3, and ghc 6.2 -stable branch, and is available from 6.2.2 onwards. + +* If you need to regenerate ./configure you need >= autoconf-2.53 + +------------------------------------------------------------------------ +BUILDING: + $ ./configure --prefix=/usr/local + $ make + $ make install + +If you wish to register the libraries as official ghc pkg (probably as +root): + $ make register + +And to unregister (maybe as root). Note that the unistall order +matters: + + $ ghc-pkg -r printf + $ ghc-pkg -r eval + $ ghc-pkg -r plugins + $ ghc-pkg -r hi + $ ghc-pkg -r altdata + +Once it is registered, you can link against the library by just adding +-package plugins or, e.g. -package eval, to your command line. + +The documentation relies on latex, dvips, tex2page: + + $ cd doc && make + +EXAMPLES: + +Have a look in the examples/ directory for many examples of how to +arrange your code. + +LICENSE: + +This library is distributed under the terms of the LGPL. The runtime +loader code is based on code written by André Pang, and others, and is +distributed under the BSD-style Glasgow University license. + +PORTABILITY: + +Requires GHC 6.2 or greater, though most testing has be done on 6.3. +They dynamic loader requires a functional GHCi implementation. + +---------------------+-------------------------------------------------- + Platform | Works Should work* Unknown Won't work +---------------------+-------------------------------------------------- +i386-*-linux | X +i386-*-freebsd | X +i386-*-openbsd | X +powerpc-apple-darwin | X +sparc-*-solaris2 | X +ia64-*-linux | # +i386-*-solaris2 | X +sparc-*-linux | X +sparc-*-openbsd | X +i386-*-netbsd | X +amd64-*-openbsd | X +mips64-sgi-irix | X +---------------------+-------------------------------------------------- + +# .hi file parsing is currently broken diff --git a/TODO b/TODO new file mode 100644 index 0000000..0c1997f --- /dev/null +++ b/TODO @@ -0,0 +1,30 @@ +For 0.1 +---------- + ++ have eval, printf return errors as arguments, not to stdout + ++ nice functions for cleaning up /tmp files, given a module name + ++ PORTABILITY -- pretty much all of this is in main/SysTools.lhs in GHC + -- where to /tmp files go? Use SysTools code from GHC + -- need to dosify file names on in and out + -- try to confirm the implementation of forkProcess + ++ write a script to strip down the release code. + ++ .hi file parser is broken on Itanium, again. + ++ Implement hs_eval by marshalling Dynamics across to the C side for + checking. + ++ Make data structures used by the library Storable, for C programs + ++ insert iface info into the state, building up a dependency graph like + hram's. use this to allow cascading unloading. Does anyone want this? + ++ enable more .hi interface code to provide full GHC-like :t options + to plugs. + ++ replace the String interface to eval with an ExpQ interface. + ++ build way=p and way='' diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..bb2adc1 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +hs-plugins 0.9.8 diff --git a/autogen.sh b/autogen.sh new file mode 100644 index 0000000..45b6ee7 --- /dev/null +++ b/autogen.sh @@ -0,0 +1,6 @@ +#!/bin/sh -x + +# this is the world's most complicated autogen.sh script :) + +exec autoconf + diff --git a/config.guess b/config.guess new file mode 100644 index 0000000..fd30ab0 --- /dev/null +++ b/config.guess @@ -0,0 +1,1354 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-07-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program 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 +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit build system type. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# This shell variable is my proudest work .. or something. --bje + +set_cc_for_build='tmpdir=${TMPDIR-/tmp}/config-guess-$$ ; +(old=`umask` && umask 077 && mkdir $tmpdir && umask $old && unset old) + || (echo "$me: cannot create $tmpdir" >&2 && exit 1) ; +dummy=$tmpdir/dummy ; +files="$dummy.c $dummy.o $dummy.rel $dummy" ; +trap '"'"'rm -f $files; rmdir $tmpdir; exit 1'"'"' 1 2 15 ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c $dummy.c -c -o $dummy.o) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + rm -f $files ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; +unset files' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep __ELF__ >/dev/null + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit 0 ;; + amiga:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + hp300:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + macppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme88k:OpenBSD:*:*) + echo m88k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvmeppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pmax:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sgi:OpenBSD:*:*) + echo mipseb-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sun3:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + wgrisc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + *:OpenBSD:*:*) + echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + alpha:OSF1:*:*) + if test $UNAME_RELEASE = "V4.0"; then + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + fi + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + eval $set_cc_for_build + cat <$dummy.s + .data +\$Lformat: + .byte 37,100,45,37,120,10,0 # "%d-%x\n" + + .text + .globl main + .align 4 + .ent main +main: + .frame \$30,16,\$26,0 + ldgp \$29,0(\$27) + .prologue 1 + .long 0x47e03d80 # implver \$0 + lda \$2,-1 + .long 0x47e20c21 # amask \$2,\$1 + lda \$16,\$Lformat + mov \$0,\$17 + not \$1,\$18 + jsr \$26,printf + ldgp \$29,0(\$26) + mov 0,\$16 + jsr \$26,exit + .end main +EOF + $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null + if test "$?" = 0 ; then + case `$dummy` in + 0-0) + UNAME_MACHINE="alpha" + ;; + 1-0) + UNAME_MACHINE="alphaev5" + ;; + 1-1) + UNAME_MACHINE="alphaev56" + ;; + 1-101) + UNAME_MACHINE="alphapca56" + ;; + 2-303) + UNAME_MACHINE="alphaev6" + ;; + 2-307) + UNAME_MACHINE="alphaev67" + ;; + 2-1307) + UNAME_MACHINE="alphaev68" + ;; + 3-1307) + UNAME_MACHINE="alphaev7" + ;; + esac + fi + rm -f $dummy.s $dummy && rmdir $tmpdir + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + exit 0 ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit 0 ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit 0;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit 0 ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit 0 ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit 0 ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit 0;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit 0;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit 0 ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit 0 ;; + DRS?6000:UNIX_SV:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7 && exit 0 ;; + esac ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit 0 ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit 0 ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit 0 ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit 0 ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit 0 ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit 0 ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit 0 ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit 0 ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit 0 ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit 0 ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy \ + && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ + && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo mips-mips-riscos${UNAME_RELEASE} + exit 0 ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit 0 ;; + Night_Hawk:*:*:PowerMAX_OS) + echo powerpc-harris-powermax + exit 0 ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit 0 ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit 0 ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit 0 ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit 0 ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit 0 ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit 0 ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit 0 ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit 0 ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit 0 ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo rs6000-ibm-aix3.2.5 + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit 0 ;; + *:AIX:*:[45]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit 0 ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit 0 ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit 0 ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit 0 ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit 0 ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit 0 ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit 0 ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null) && HP_ARCH=`$dummy` + if test -z "$HP_ARCH"; then HP_ARCH=hppa; fi + rm -f $dummy.c $dummy && rmdir $tmpdir + fi ;; + esac + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit 0 ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit 0 ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo unknown-hitachi-hiuxwe2 + exit 0 ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit 0 ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit 0 ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit 0 ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit 0 ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit 0 ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit 0 ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit 0 ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit 0 ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit 0 ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit 0 ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit 0 ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3D:*:*:*) + echo alpha-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit 0 ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit 0 ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:FreeBSD:*:*) + # Determine whether the default compiler uses glibc. + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #if __GLIBC__ >= 2 + LIBC=gnu + #else + LIBC= + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + rm -f $dummy.c && rmdir $tmpdir + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC} + exit 0 ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit 0 ;; + i*:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit 0 ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit 0 ;; + x86:Interix*:3*) + echo i386-pc-interix3 + exit 0 ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i386-pc-interix + exit 0 ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit 0 ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit 0 ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + *:GNU:*:*) + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit 0 ;; + arm*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + mips:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` + rm -f $dummy.c && rmdir $tmpdir + test x"${CPU}" != x && echo "${CPU}-pc-linux-gnu" && exit 0 + ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit 0 ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit 0 ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit 0 ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit 0 ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit 0 ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit 0 ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + x86_64:Linux:*:*) + echo x86_64-unknown-linux-gnu + exit 0 ;; + i*86:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. cd to the root directory to prevent + # problems with other programs or directories called `ld' in the path. + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ + | sed -ne '/supported targets:/!d + s/[ ][ ]*/ /g + s/.*supported targets: *// + s/ .*// + p'` + case "$ld_supported_targets" in + elf32-i386) + TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" + ;; + a.out-i386-linux) + echo "${UNAME_MACHINE}-pc-linux-gnuaout" + exit 0 ;; + coff-i386) + echo "${UNAME_MACHINE}-pc-linux-gnucoff" + exit 0 ;; + "") + # Either a pre-BFD a.out linker (linux-gnuoldld) or + # one that does not give us useful --help. + echo "${UNAME_MACHINE}-pc-linux-gnuoldld" + exit 0 ;; + esac + # Determine whether the default compiler is a.out or elf + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #ifdef __INTEL_COMPILER + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + rm -f $dummy.c && rmdir $tmpdir + test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 + test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit 0 ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit 0 ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit 0 ;; + i*86:*:5:[78]*) + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit 0 ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit 0 ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit 0 ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit 0 ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit 0 ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit 0 ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit 0 ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit 0 ;; + M68*:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4.3${OS_REL} && exit 0 + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit 0 ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit 0 ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit 0 ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit 0 ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit 0 ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit 0 ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit 0 ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit 0 ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit 0 ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit 0 ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit 0 ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit 0 ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit 0 ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit 0 ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Darwin:*:*) + echo `uname -p`-apple-darwin${UNAME_RELEASE} + exit 0 ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit 0 ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit 0 ;; + NSR-[GKLNPTVW]:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit 0 ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit 0 ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit 0 ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit 0 ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit 0 ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit 0 ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit 0 ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit 0 ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit 0 ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit 0 ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit 0 ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit 0 ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit 0 ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit 0 ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 +rm -f $dummy.c $dummy && rmdir $tmpdir + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit 0 ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + c34*) + echo c34-convex-bsd + exit 0 ;; + c38*) + echo c38-convex-bsd + exit 0 ;; + c4*) + echo c4-convex-bsd + exit 0 ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/config.h.in b/config.h.in new file mode 100644 index 0000000..73db90a --- /dev/null +++ b/config.h.in @@ -0,0 +1,21 @@ +/* + * Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons + * LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + */ + +/* symbols that must be assigned to variables in Haskell code */ + +/* NOTE: this is not the same as symbols needed for cpp of .hs code */ + +/* path to ghc */ +#define GHC "@GHC@" + +/* path to GHC libraries */ +#define GHC_LIB_PATH "@GHC_LIB_PATH@" + +#define TOP "@TOP@" + +#define LEADING_UNDERSCORE @LEADING_UNDERSCORE@ + +#define CABAL @CABAL@ + diff --git a/config.mk.in b/config.mk.in new file mode 100644 index 0000000..0f0e613 --- /dev/null +++ b/config.mk.in @@ -0,0 +1,57 @@ +# +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +# +# config.mk.in : +# variables that need to be visible in Makefiles +# + +# all is the default rule for everyone +default: all + +PACKAGE = plugins +UPACKAGE = Plugins + +TOP = @TOP@ + +PREFIX = @PREFIX@ +LIBDIR = $(PREFIX)/lib/hs-$(PACKAGE) +BINDIR = $(PREFIX)/bin + +WHOLE_ARCHIVE_FLAG = @WHOLE_ARCHIVE_FLAG@ + +# Are we using the new Cabal packages? +CABAL = @CABAL@ + + +GHC = @GHC@ +GHC_LIB_PATH = @GHC_LIB_PATH@ +GHC_VERSION = @GHC_VERSION@ +GLASGOW_HASKELL = @GLASGOW_HASKELL@ +GHC_EXTRA_OPTS = @SYMS@ @DEBUG_OPTS@ +GHC_LD_OPTS = + +GHC_PKG = @GHCPKG@-@GHC_VERSION@ + +LD = @LD@ +LD_X = -x + +HAPPY = @HAPPY@ +HAPPY_OPTS = -a -g -c +ALEX = @ALEX@ +ALEX_OPTS = --ghc +HADDOCK = @HADDOCK@ + +AR = @AR@ +RANLIB = @RANLIB@ + +RM = @RM@ + +INSTALL = @INSTALL@ + +# A few aliases +INSTALL_PROGRAM = ${INSTALL} -s -m 755 +INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_DATA_DIR= ${INSTALL} -d -m 755 diff --git a/config.sub b/config.sub new file mode 100644 index 0000000..9ff085e --- /dev/null +++ b/config.sub @@ -0,0 +1,1460 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-07-03' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program 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 General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit 0;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | freebsd*-gnu* | storm-chaos* | os2-emx* | windows32-* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | c4x | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | ip2k \ + | m32r | m68000 | m68k | m88k | mcore \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mipsisa32 | mipsisa32el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | ns16k | ns32k \ + | openrisc | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[1234] | sh3e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xstormy16 | xtensa \ + | z8k) + basic_machine=$basic_machine-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12) + # Motorola 68HC11/12. + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* \ + | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c54x-* \ + | clipper-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* \ + | m32r-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | mcore-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64orion-* | mips64orionel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipstx39 | mipstx39el \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[1234]-* | sh3e-* | sh[34]eb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ + | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* | tic30-* | tic54x-* | tic80-* | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ + | xtensa-* \ + | ymp-* \ + | z8k-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + mmix*) + basic_machine=mmix-knuth + os=-mmixware + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + or32 | or32-*) + basic_machine=or32-unknown + os=-coff + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon) + basic_machine=i686-pc + ;; + pentiumii | pentium2) + basic_machine=i686-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3d) + basic_machine=alpha-cray + os=-unicos + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tic54x | c54x*) + basic_machine=tic54x-unknown + os=-coff + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + windows32) + basic_machine=i386-pc + os=-windows32-msvcrt + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh3 | sh4 | sh3eb | sh4eb | sh[1234]le | sh3ele) + basic_machine=sh-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparc | sparcv9 | sparcv9b) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + c4x*) + basic_machine=c4x-none + os=-coff + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* \ + | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* | -powermax*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto*) + os=-nto-qnx + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) + os=-aout + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-ibm) + os=-aix + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit 0 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..fd987be --- /dev/null +++ b/configure.ac @@ -0,0 +1,198 @@ +# +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +# sanity test +AC_INIT(src/plugins/Plugins.hs) + +# untested on earlier than 2.52, but it won't work anyway +AC_PREREQ(2.53) + +# Find out what type of system we're running on +AC_CANONICAL_BUILD + +PREFIX="$prefix" +if test "$prefix" = "NONE" +then + PREFIX="$ac_default_prefix" +fi +AC_SUBST(PREFIX) + +Platform="$build_cpu-$build_vendor-$build_os" + +case $Platform in +powerpc-apple-darwin*) + MACOSX=yes + ;; +*) + MACOSX=no + ;; +esac +if test "$MACOSX" = "yes" +then + WHOLE_ARCHIVE_FLAG=-all_load + LEADING_UNDERSCORE=1 +else + WHOLE_ARCHIVE_FLAG=--whole-archive + LEADING_UNDERSCORE=0 +fi + +AC_SUBST(WHOLE_ARCHIVE_FLAG) +AC_SUBST(LEADING_UNDERSCORE) + + +TOP=`pwd` +AC_SUBST(TOP) + +# necessary tools + +# allow user supplied haskell compiler +AC_ARG_WITH(ghc, + AC_HELP_STRING([--with-ghc=],[use a specific Haskell compiler]), + [ GHC="$withval" + if test ! -f "$GHC" ; then + AC_MSG_ERROR([$GHC not found. You need GHC to build this project]) + fi + ], + [ AC_CHECK_PROG(GHC,ghc,ghc) + if test -z "$GHC" ; then + AC_MSG_ERROR([You need GHC to build this project]) + fi + ] + ) +AC_SUBST(GHC) + +# find path to GHC libs, for runtime_loader +if test -n "$GHC" ; then + AC_MSG_CHECKING([for ghc library directory]) + GHC_LIB_PATH=`$GHC --print-libdir` + AC_MSG_RESULT([$GHC_LIB_PATH]) +fi +AC_SUBST(GHC_LIB_PATH) + +# check ghc version here +if test -n "$GHC" ; then + AC_MSG_CHECKING([for ghc version]) + GHC_VERSION=`$GHC --numeric-version` + AC_MSG_RESULT([$GHC_VERSION]) +fi +AC_SUBST(GHC_VERSION) + +# Work out value of __GLASGOW_HASKELL__ +if test -n "$GHC" ; then + AC_MSG_CHECKING([for value of __GLASGOW_HASKELL__]) + echo "main = print __GLASGOW_HASKELL__" > t.hs + GLASGOW_HASKELL=`echo 'main' | "$GHC" --interactive -v0 -cpp t.hs` + rm t.hs + AC_MSG_RESULT([$GLASGOW_HASKELL]) +fi +AC_SUBST(GLASGOW_HASKELL) + +dnl ** quote char breaks sed +changequote(, )dnl +MAJOR=`echo "$GHC_VERSION" | sed 's/^\([^\.]*\)\.\([^\.]*\).*/\1/'` +MINOR=`echo "$GHC_VERSION" | sed 's/^\([^\.]*\)\.\([^\.]*\).*/\2/'` +changequote([, ])dnl + +if test "$MAJOR" -lt "6"; then + AC_MSG_ERROR(Found major $MAJOR. You need a ghc version >= 6.2) ; +fi +if test "$MINOR" -lt "2"; then + AC_MSG_ERROR(You need a ghc version >= 6.2) ; +fi + +#Allow plugins to be built with Cabal libraries +AC_ARG_ENABLE(cabal, + [ --enable-cabal Enable use of Cabal packages in pluggable-1-branch + of GHC], + [ CABAL=1 ], + [ CABAL=0 ]) + +# used by the Makefile`s to alter dependencies. +if test "$MAJOR" -ge "6" -a "$MINOR" -ge "4"; then + CABAL=1 +fi + +AC_SUBST(CABAL) + +# Allow a debugging version of hs-plugins to be built +AC_ARG_ENABLE(debug, + [ --enable-debug Enable a debug version of hs-plugins to be built], + [ DEBUG_OPTS=-DDEBUG ], + [ DEBUG_OPTS= ]) + +AC_SUBST(DEBUG_OPTS) + +# allow user supplied haskell package manager +AC_ARG_WITH(ghc-pkg, + AC_HELP_STRING([--with-ghc-pkg=],[use a specific ghc-pkg]), + [ GHCPKG="$withval" + if test ! -f "$GHCPKG" ; then + AC_MSG_ERROR([$GHCPKG not found. You need ghc-pkg]) + fi + ], + [ AC_CHECK_PROG(GHCPKG,ghc-pkg,ghc-pkg) + if test -z "$GHCPKG" ; then + AC_MSG_ERROR([You need ghc-pkg]) + fi + ] + ) + +AC_SUBST(GHCPKG) + +AC_CHECK_PROG(HADDOCK,haddock,haddock) +if test -z "$HADDOCK" ; then + AC_MSG_WARN(You need Haddock if you want developer documentation) +fi + +AC_CHECK_PROG(HAPPY,happy,happy) +if test -z "$HAPPY" ; then + AC_MSG_WARN(If you change or remove the parser you'll need Happy) +fi + +AC_CHECK_PROG(ALEX,alex,alex) +if test -z "$ALEX" ; then + AC_MSG_WARN(If you change or remove the lexer files you'll need alex) +fi + +AC_CHECK_PROG(LD,ld,ld) +if test -z "$LD" ; then + AC_MSG_WARN(You need ld -export-dynamic) +fi + +AC_CHECK_PROG(AR,ar,ar) +if test -z "$AR" ; then + AC_MSG_WARN(You need ar to build the library) +fi + +AC_CHECK_PROG(RANLIB,ranlib,ranlib) +if test -z "$RANLIB" ; then + AC_MSG_WARN(You need randlib to build the library) +fi + +AC_CHECK_PROG(RM,rm,rm) +if test -z "$RM" ; then + AC_MSG_WARN(You need rm!) +fi + +AC_CHECK_PROG(TEX,tex,tex) +if test -z "$TEX" ; then + AC_MSG_WARN(You'll need tex if you wish to build the documentation) +fi +AC_CHECK_PROG(TEX2PAGE,tex2page,tex2page) +if test -z "$TEX2PAGE" ; then + AC_MSG_WARN(You'll need tex2page if you wish to build the + documentation: http://www.ccs.neu.edu/home/dorai/tex2page/tex2page-doc.html) +fi + +AC_CHECK_FUNC(arc4random, [SYMS="$SYMS -DHAVE_ARC4RANDOM"]) + +AC_SUBST(SYMS) + +AC_PROG_INSTALL + +AC_CONFIG_FILES(config.mk config.h) + +AC_OUTPUT + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000..bfa3b46 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,31 @@ +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + +.PHONY: build clean html + +SRC = hs-plugins + +build: $(SRC).ps html + +$(SRC).ps: $(SRC).dvi + dvips -f $(SRC).dvi > $@ + +html: $(SRC).tex + tex2page $(SRC) + tex2page $(SRC) + ./munge.sed < $(SRC)/$(SRC).html > tmp.out + mv tmp.out $(SRC)/$(SRC).html + cp $(SRC)/$(SRC).html $(SRC)/index.html + tar czf $(SRC).html.tar.gz $(SRC) + mv $(SRC).html.tar.gz $(SRC)/ + +$(SRC).dvi: $(SRC).tex + latex $(SRC).tex && latex $(SRC).tex + +CLEANS= *.{ps,dvi,aux,log} *~ hs-plugins *-Z-* *.toc + +clean: + rm -rf $(CLEANS) + +all: doc + diff --git a/docs/haskell.sty b/docs/haskell.sty new file mode 100644 index 0000000..5fd028b --- /dev/null +++ b/docs/haskell.sty @@ -0,0 +1,452 @@ +%%% This is a LaTeX2e style file. +%%% +%%% It supports setting functional languages like Haskell. +%%% +%%% Manuel M. T. Chakravarty [1998..2000] +%%% +%%% $Id: haskell.sty,v 1.2 2004/05/16 08:20:09 dons Exp $ +%%% +%%% This file is free software; you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation; either version 2 of the License, or +%%% (at your option) any later version. +%%% +%%% This file 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 General Public License for more details. +%%% +%%% Acknowledegments ========================================================== +%%% +%%% Thanks to Gabriele Keller for beta testing and +%%% code contributions. Thanks to the LaTeX3 project for improving the LaTeX +%%% sources (which helped me writing this code). Furthermore, I am grateful +%%% to Martin Erwig for feedback and +%%% suggestions, and to Conal Elliott for pointing out +%%% a tricky bug. +%%% +%%% TODO ====================================================================== +%%% +%%% B ~ bug; F ~ feature +%%% +%%% * F: Along the lines of the discussion with Martin Erwig add support for +%%% keywords etc (see the emails) +%%% +%%% * B: If we have as input +%%% +%%% \ +%%% +%%% there won't be a `\hsap' inserted!! (Can this be solved by using +%%% \obeylines in \<...\>?) +%%% +%%% * B: A \relax is needed after a & if it immediately followed by a \hsbody{} +%%% (See TeXbook, S.240) +%%% +%%% * F: Implement a \hstext{...} as \(\text{...}\). +%%% +%%% * We would like hswhere* etc that are like haskell* (\hsalign already +%%% supports this, ie, there is a \hsalign*). +%%% +%%% * Star-Versions of if, let etc that use a single line layout (maybe not +%%% with star, because of the above). +%%% +%%% * Support for enforcing and prohibiting breaks in `haskell' displays. +%%% +%%% * Comments in a let-in should be aligned in the same way for the bindings +%%% and the body. +%%% +%%% * It would be nice to have different styles (indentation after in of +%%% let-in or not) etc; either to be set with a package option or in the +%%% preamble (the latter probably makes more sense). +%%% +%%% * Literate programming facility: Variant of the `haskell' env (maybe +%%% `hschunk', which is named and can be used in other chunks). But maybe +%%% it is not necessary to provide a chunk-based reordering mechanism, +%%% because most of the Haskell stuff can be in any order anyway... +%%% Important is to provide a way to define visually pleasing layout +%%% together with the raw Haskell form for program output. (Maybe `haskell*' +%%% as Haskell env that outputs its contents?) +%%% + +%% Initialization +%% ============== + +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{haskell}[2000/10/05 v1.0e Chilli's Haskell Style] + + +%% Parameters +%% ========== + +\newskip\hsmargin +\hsmargin\leftmargini + + +%% Main macros and environments +%% ============================ + +% applications +% +\newcommand{\hsap}{% % application by juxtaposition + \unskip\mskip 4mu plus 1mu} % only the last \hsap counts + +% commands to start and stop setting spaces as \hsap +% +{\obeyspaces\gdef\@hsSpaceToApp{\obeyspaces\let =\hsap}} % spaces matter!!! +{\obeyspaces\gdef\@hsNormalSpace{\let =\space}} + +% commands to start and stop treating numbers specially, ie, we don't want +% them to be affected by font changing commands in Haskell contexts as this +% would give italic numerals; the trick is to redefine their math code such +% that they go into math class 0 and thus don't change families (cf. `The +% TeXbook', Chapter 17, pp152) +% +\newcommand{\@hsRmNumbers}{% + \mathcode`0="0030 + \mathcode`1="0031 + \mathcode`2="0032 + \mathcode`3="0033 + \mathcode`4="0034 + \mathcode`5="0035 + \mathcode`6="0036 + \mathcode`7="0037 + \mathcode`8="0038 + \mathcode`9="0039 + } +\newcommand{\@hsNormalNumbers}{% + \mathcode`0="7030 + \mathcode`1="7031 + \mathcode`2="7032 + \mathcode`3="7033 + \mathcode`4="7034 + \mathcode`5="7035 + \mathcode`6="7036 + \mathcode`7="7037 + \mathcode`8="7038 + \mathcode`9="7039 + } + +% Save the bindings of the standard math commands +% +% This is somewhat subtle as we want to able to enter the original math mode +% within Haskell mode and we have to ensure that the different opening +% commands are matched by the correct versions of the closing commands. +% +\let\@hsmathorg=\( +\let\@hsmathendorg=\) +\let\hs@crorg=\\ +\newcommand{\@hsmath}{% + \relax\hbox\bgroup + \@hsNormalSpace + \@hsNormalNumbers + \let\(=\@hsmathorgx + \let\)=\@hsmathend + \def\\{\hs@crorg}% + \@hsmathorg + } +\newcommand{\@hsmathend}{% + \@hsmathendorg + \egroup + } +\newcommand{\@hsmathorgx}{% + \relax\@hsmathorg + \let\)=\@hsmathendorg + } + +%% Typesetting of Haskell +%% ====================== + +% Inline Haskell phrases are delimited by `\<' and `\>'. +% +% Note: `\>' is only locally redefined. +% +\newcommand{\<}{% + \@hsmathorg + \mathit\bgroup + \@hsSpaceToApp + \@hsRmNumbers + \let\>=\@endhs + \let\(=\@hsmath + \def\\{\cr} % for Haskell alignments + } +\newcommand{\@endhs}{% + \egroup + \@hsmathendorg + } + +% Displayed Haskell (environment `haskell' and `haskell*') +% +% There are two kind of preambles for \halign: \hs@preambleNorm is for +% `amsmath' style alignments and \hs@preambleStar for `equation' style +% alignments (but with an unbound number of columns to its right) +% +% We need #### to get a ## in the \edef building the \halign command. +% +% first the preambles (also used in \hs@align below): +% +\def\hs@preambleNorm{% + \noexpand\<####\unskip\noexpand\>\hfil&&\noexpand% + \<{}####\unskip\noexpand\>\hfil} +\def\hs@preambleStar{% + \noexpand\<####\unskip\noexpand\>\hfil&\hfil\noexpand% + \<{}####\unskip{}\noexpand\>\hfil&&\noexpand\<{}####\noexpand\>\hfil} +% +% the environments: +% +\newenvironment{haskell}{% + \@haskell\hs@preambleNorm}{% + \@endhaskell + } +\newenvironment{haskell*}{% + \@haskell\hs@preambleStar}{% + \@endhaskell + } +% +% auxiliary definition getting the preamble as its first argument and starting +% the environment: +% +\def\@haskell#1{% + \bgroup + \vspace\abovedisplayskip + \let\(=\@hsmath % Important when `\(' occurs after `&'! + \edef\@preamble{% + \halign\bgroup\hskip\hsmargin#1\cr} + \@preamble + } +% +% Auxiliary definition ending environment: +% +\def\@endhaskell{% + \crcr\egroup + \vspace\belowdisplayskip + \egroup\noindent\ignorespaces\global\@ignoretrue% + } + +% single line comment and keyword style +% +\newcommand{\hscom}[1]{% + \relax\(\quad\textnormal{--- #1}\)} +\newcommand{\hskwd}[1]{% + \mathbf{#1}} + +% informal description +% +\newcommand{\hsinf}[1]{% + \(\langle\textnormal{#1}\rangle\)} + +% literals and some special symbols +% +\newcommand{\hschar}[1]{\textrm'\mathrm{#1}\textrm'} % character literals +\newcommand{\hsstr}[1]{"\mathrm{#1}"} % strings literals +\newcommand{\hsfrom}{\leftarrow} % <- + +% aligned subphrases +% +% check for an optional star and combine prefix (in #1) with one of the two +% preambles (with star means to center the material between the first and +% second &) +% +\def\hs@align#1{% + \@ifstar + {\hs@align@pre{#1\hs@preambleStar}}% + {\hs@align@pre{#1\hs@preambleNorm}}% + } +% +% test for optional argument; #1: preamble +% +\def\hs@align@pre#1{% + \@testopt{\hs@align@prealign#1}t} +% +% got all arguments, now for the real code; #1: preamble; #2: alignment; +% #3: body (the material set by the \halign) +% +\def\hs@align@prealign#1[#2]#3{% + \relax\( + \edef\@preamble{% + \halign\bgroup#1\cr} + \if #2t\vtop \else \if#2b\vbox \else \vcenter \fi\fi + \bgroup% + \@preamble + #3% + \crcr\egroup% + \egroup\) + } +% +% user-level command: alignment without a prefix +% +\newcommand{\hsalign}{% + \relax + \hs@align\relax% + } + +% subphrase breaking the surrounding alignment being flushed left +% +\newcommand{\hsnoalign}[1]{% + \noalign{% + \hs@align{\hskip\hsmargin}{#1}% + }% + } + +% body expression breaking the surrounding alignment +% +% * setting \hsmargin to 0pt within the preamble (and _after_ it is used in +% the preamble) is crucial, as we want \hsmargin only to be applied in +% _outermost_ alignments +% +\newcommand{\hsbody}[1]{% + {}\\ + \noalign{% + \hs@align{\hskip\hsmargin\quad\hsmargin0pt}{#1}% + }% + } + + +%% Defining commands for use in the Haskell mode +%% ============================================= +%% +%% We use some of the low-level machinery defined in LaTeX's source file +%% `ltdefns.dtx'. +%% +%% \hscommand is similar to \newcommand, but there is no *-version. +%% +%% We use our own definitions here to insert a strategic `\relax' (see below) +%% and to obey spaces within the bodies of Haskell definitions. + +\newcommand{\hscommand}[1]{\@testopt{\hs@newcommand#1}0} +\def\hs@newcommand#1[#2]{% + \obeyspaces % spaces count in Haskell macros + \@ifnextchar [{\hs@xargdef#1[#2]}% + {\hs@argdef#1[#2]}} + +% All this trouble only to be able to add the `\relax' into the expansion +% process. If we don't that, commands without optional arguments when +% invoked after an alignment character & don't work properly (actually, the +% \obeyspaces doesn't work). I am sure that has to do with the scanning for +% \omit etc in \halign (TeXbook, p240), but I don't understand yet why it +% is problematic in this case. +% +% Furthermore, we switch off \obeyspaces in the end. +% +\long\def\hs@argdef#1[#2]#3{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \relax % in order to stop token expansion after & + \csname\string#1\expandafter\endcsname}% + \expandafter\@yargdef + \csname\string#1\endcsname + \@ne + {#2}% + {#3}}% + \catcode`\ =10% % stop obeying spaces now + } + +% Switch off \obeyspaces in the end. +% +\long\def\hs@xargdef#1[#2][#3]#4{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \expandafter + \@protected@testopt + \expandafter + #1% + \csname\string#1\expandafter\endcsname + {#3}}% + \expandafter\@yargdef + \csname\string#1\endcsname + \tw@ + {#2}% + {#4}}% + \catcode`\ =10% % stop obeying spaces now + } + + +%% Abbreviations +%% ============= + +% infix operators +% +\newcommand{\hsapp}{\mathbin{+\mkern-7mu+}} +\newcommand{\hsifix}[1]{\mathbin{\string`#1\string`}} + +% let expression +% +\hscommand{\hslet}[3][t]{% + \hsalign[#1]{% + \hskwd{let}\\ + \quad\hsalign{#2}\\ + \hskwd{in}\\ + #3 + }% + } + +% if expression +% +\hscommand{\hsif}[4][t]{% + \hsalign[#1]{% + \hskwd{if} #2 \hskwd{then}\\ + \quad\hsalign{#3}\\ + \hskwd{else}\\ + \quad\hsalign{#4}% + }% + } + +% case expression +% +\hscommand{\hscase}[3][t]{% + \hsalign[#1]{% + \hskwd{case} #2 \hskwd{of}\\ + \quad\hsalign{#3}% + }% + } + +% where clause +% +% * it is important to take the \quad into the preamble, so that nested +% \noaligns can break it +% +\hscommand{\hswhere}[1]{% + \hsbody{% + \hskwd{where}\\ + \hs@align{\quad}{#1}% + }% + } + +% do expression +% +\hscommand{\hsdo}[2][t]{% + \hsalign[#1]{% + \hskwd{do}\\ + \quad\hsalign{#2}\\ + }% + } + + +%% Extensions for Distributed Haskell (Goffin) +%% =========================================== +%% +%% These definitions may change in the future. + +\hscommand{\hsunif}{\mathbin{:=:}} +\hscommand{\hsalias}{\mathrel{\sim}} +\hscommand{\hsoutof}{\twoheadleftarrow} +\hscommand{\hsinto}{\twoheadrightarrow} +\hscommand{\hsparc}{\binampersand} +\hscommand{\hsseq}{\Longrightarrow} +\hscommand{\hsex}[2]{{\hskwd{ex} #1 \hskwd{in} #2}} + +\hscommand{\hsexin}[3][t]{% + \hsalign[#1]{% + \hskwd{ex} #2 \hskwd{in}\\ + \quad\hsalign{#3}\\ + }% + } + +\hscommand{\hschoice}[2][t]{% + \hsalign[#1]{% + \hskwd{choice}\\ + \quad\hsalign{#2}\\ + }% + } + + diff --git a/docs/hs-plugins.1 b/docs/hs-plugins.1 new file mode 100644 index 0000000..64cfa9c --- /dev/null +++ b/docs/hs-plugins.1 @@ -0,0 +1,36 @@ +.TH HS-PLUGINS 1 2005-03-26 "hs-plugins version 0.9.8" "User Manual" + +.SH NAME +hs-plugins \- dynamic linker library for Haskell + +.SH DESCRIPTION +.ds c \fIhs-plugins\fP +\*c is a library for loading plugins written in Haskell into an +application at runtime. It also provides a mechanism for (re)compiling +Haskell source at runtime. Thirdly, a combination of runtime compilation +and dynamic loading provides a suite of eval functions. Values exported +by plugins are transparently available to Haskell host applications, and +bindings exist to use Haskell plugins from at least C and Objective C +programs. hs-plugins requires ghc-6.2.2 or greater. + +.SH DOCUMENTATION +The hs-plugins user manual is distributed in html format, and may be +found at + +.SH BUGS +Bug reports, and any other feedback, should be sent to +Don Stewart +.SH COPYRIGHT +Copyright \(co 2004-2005 Don Stewart +.PP +The hs-plugins library modules are distributed under the terms of the +LGPL. +.SH "SEE ALSO" +.BR dlopen (3) + +.SH AUTHOR + +This manual page was written by Don Stewart, based on the man page for +cpphs (written by Ian Lynagh). + + diff --git a/docs/hs-plugins.hdir b/docs/hs-plugins.hdir new file mode 100644 index 0000000..7637edc --- /dev/null +++ b/docs/hs-plugins.hdir @@ -0,0 +1 @@ +hs-plugins diff --git a/docs/hs-plugins.tex b/docs/hs-plugins.tex new file mode 100644 index 0000000..77a8e02 --- /dev/null +++ b/docs/hs-plugins.tex @@ -0,0 +1,1808 @@ +\documentclass{article} + +\usepackage{url} +\usepackage{tex2page} + +% typeset math as ascii +\htmlmathstyle{no-in-text-image no-display-image} + +% something other than | +\verbescapechar\& + +\cssblock +h1 {font-size: 16pt} +h2 {font-size: 15pt} +\endcssblock + +% color of verbatim elements +\cssblock +.verbatim {color: grey20} + +.scheme .variable {color: grey20} +.scheme .keyword {color: navy} +.scheme .builtin {color: maroon} +\endcssblock + +% add some extra keywords +\scmkeyword{as case class data default deriving do else hiding if} +\scmkeyword{import in infix infixl infixr instance let module newtype} +\scmkeyword{of qualified then type where forall \\ } +\scmbuiltin{: :: = -> <- @ ~ => - >>= >> } + +\newcommand{\code}[1]{{\texttt{#1}}} +\newcommand{\hsplugins}{{\texttt{hs-plugins}}} + +\title{hs-plugins\\ + Dynamically Loaded Haskell Modules} + +\author{\urlh{http://www.cse.unsw.edu.au/~dons}{Don Stewart}} + +\begin{document} + +\maketitle + +\medskip +% +{\htmlonly \textbf{Download \endhtmlonly +\urlh{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/hs-plugins-0.9.8.tar.gz} + {version 0.9.8}} +% +\medskip + +\hsplugins{} is a library for loading plugins written in Haskell into an +application at runtime. It also provides a mechanism for (re)compiling +Haskell source at runtime. Thirdly, a combination of runtime compilation +and dynamic loading provides a suite of \code{eval} functions. Values +exported by plugins are transparently available to Haskell host +applications, and bindings exist to use Haskell plugins from at least C +and Objective C programs. \hsplugins{} currently requires ghc-6.2.2. + +\medskip + +% grr. double spaced. + +\tableofcontents + +\newpage + +\section{Download} + +\begin{itemize} + +\item +Download the latest stable release:\\ +\url{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/hs-plugins-0.9.8.tar.gz} + + +\item +Nightly cvs src snapshots are available at:\\ +\url{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/snapshots/} + + +\item +A tarball of the document you are reading:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/hs-plugins.html.tar.gz} + + +\item +A postscript version of the document you are reading:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/hs-plugins.ps.gz} + + +\item +A paper on interesting uses of \hsplugins{} to enable Haskell to be used +as an application extension language:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/paper} + +\end{itemize} + +It is known to run on \code{i386-\{linux,freebsd,openbsd\}}, +\code{ia64-linux}, \code{sparc-solaris2} and \code{powerpc}'s running +Mac OSX. It should run on any machine with a working GHCi +implementation. + +\section{History} + +\begin{itemize} + \item v0.9.8 + \begin{itemize} + \item Fix bug in .hi parsing. + \item Add reloading of packages. + \item Fix bug in canonical module names + (fixing problems with "Foo.o" and "./Foo.o" + \item Fix for hierarchical names, don't guess them, + read them from the .hi file. + \item Add new varients of load. + \item Fix bug in makeAll, such that dependent module + changes were not noticed. + \item Add varient of eval:\code{ unsafeEval\_}, returing + Either. + \item Better, bigger testsuite. + \item Better api. + \end{itemize} + + \item Septemeber 2004. + \begin{itemize} + \item makeAll + \item Better return type for make. + \end{itemize} + + \item Mid August 2004, v0.9.6 release. + \begin{itemize} + \item More portable, thanks to debugging by Niklas Broberg. + \item Other small fixes to the interfaces. + \item Provides a runtime-generated printf. + \end{itemize} + + \item Mid July 2004, added new pdynload strategy. + + \item Mid-June 2004, v0.9.5 release. + \begin{itemize} + \item dynamic typing is working + + \item static typing of interfaces is working + + \item Adds \code{eval}, and \code{hs\_eval} + + \item bugs fixed. + \end{itemize} + + \item Early-June 2004, v0.9.4 release. + \begin{itemize} + + \item Adds a .hi file parser. We use this to work out + plugin dependencies directly, meaning no more + \code{.dep} files or \code{ghcp}. + + \item It also adds a package.conf parser, meaning we + can properly handle packages that either aren't stored + in the normal location, don't have a canonical name, + or are found using a -package-conf argument. Thanks to + Sean for this work. + + \item the interface to load() has changed to allow a + list of package.conf files to search for packages. + + \item the interace to make() has changed, so that you + can get back any stderr output produced during plugin + compilation. + + \item It solves a bug whereby a package that is + required by another package would not be loaded unless + the plugin itself depended on this indirect package. + + \item more stable, more examples. + \end{itemize} + + \item May 2004, v0.9.3 released, adding support for dependency + conflict resolution between multiple plugins. Several plugins with + shared dependencies can now be safely loaded at once. --prefix is now + respected in ./configure. Thanks to Sean for this patch. + + \item v0.9.2 change licence to LGPL + + \item v0.9.1 expand on the documentation + + \item v0.9 released, initial source release + +\end{itemize} + +\section{Acknowledgements} + +\begin{itemize} + +\item Andr\'e Pang's \code{runtime\_loader} was the inspiration and basis +of the dynamic loader (\url{http://www.algorithm.com.au}). +\hsplugins{} has benefited from many discussions with him, +particularly to do with dependency checking and dynamic typing, and +bug reports. Andr\'e wrote an objective C binding to hs-plugins, and +helped with the design of eval(). He also fixed GHC so we could load +the dynamic loader dynamically. + +\item Sean Seefried (\url{http://www.cse.unsw.edu.au/~sseefried}) was +the first user of \hsplugins{} and his code and feedback have helped +make the library much more useful and powerful. + +\item Manuel Chakravarty's \code{take} system provided the basis for +\code{make}, and helped with several issues to do with safety of +plugins, apis and the applications that use them. +Manuel also helped with the design of eval(), and on how to +successfully evaluate polymorphic functions using rank-N types. + +\item Simon Marlow helped with several issues to do with linking and +loading static and dynamic code, and provided many useful suggestions. + +\item Hampus Ram's dynamic loader +(\url{http://www.dtek.chalmers.se/~d00ram/dynamic/}) provided the +design of the state maintained by the loader, and for thread safety +issues relating to this. + +\item Shae Erisson provided several insights into more powerful uses +of the library. Thanks to everyone on \#haskell who provided +discussion about the library. + +\item Malcolm Wallace's \code{hmake} provided some useful insights in +how to compile Haskell source in a way that makes it appear like an +interpreter, used in the interactive environment: \code{plugs}. + +\item Niklas Broberg helped a lot by testing, and providing feedback for +the new make and load API. Thanks Niklas. + +\item Finally, thanks to everyone who has worked on GHC and its +libraries: for GHCi, the .hi interface parser, the package system, and +all the other code the \hsplugins{} depends on. + +\end{itemize} + +\newpage + +\section{Overview} + +\hsplugins{} is a library for compiling and loading Haskell code into a +program at runtime. It allows you to write a Haskell program (which may +be spread over multiple modules) and have an application (implemented in +any language with a Haskell FFI binding, including Haskell) load your +code at runtime, and use the values found within. + +\hsplugins{} provides 3 major features: +% +\begin{itemize} + \item a dynamic loader, + \item a compilation manager, and + \item a Haskell evaluator +\end{itemize} + +The \emph{dynamic loader} loads objects into the address space of an +application, along with any dependencies the plugin may have. The +loader is a binding to the GHC loader, which does single object +loading. GHC also performs the necessary linking of new objects into +the running process. On top of the GHC loader is our Haskell layer +that arranges for module and package dependencies to be found prior to +loading individual modules. + +The \emph{compilation manager} is a \code{make}-like system for +compiling Haskell source code into a form suitable for loading +dynamically. While plugins are normally thought of as strictly object +code, there are a variety of scenarios where it is desirable to be +able to inspect the source code of a plugin, or to be able to +recompile a plugin at runtime. The compilation manager fills this +role. It is particularly useful in the implementation of \code{eval}, +and \code{printf}. + +The \emph{evaluator}, \code{eval}, is a client of the loader and +compilation manager. When passed a string of Haskell code, it compiles +the string to object code, loads the result, and returns a Haskell +value representing the compiled string to the caller. It can be +considered a Haskell interpreter, implemented as a library. + +\section{Dynamic Loader} + +The interface to the \hsplugins{} library can be divided into a number +of sections representing the functional units of the library. +Additionally, depending on the level of trust the application places +in the plugins, a variety of additional checks can be made on the +plugin as it is loaded. The levels of type safety possible are +summarised at the end of Section \ref{sec:compilation-manger} section. +The dynamic loader is available by using \code{-package plugins}. + +\subsection*{Interface} +% +\begin{quote} +\scm{ +load :: FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) +} + +\scm{ +load_ :: FilePath + -> [FilePath] + -> Symbol + -> IO (LoadStatus a) +} + +\scm{ +data LoadStatus a + = LoadSuccess Module a + | LoadFailure Errors +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do mv <- load "Plugin.o" ["api"] [] "resource" + case mv of + LoadFailure msg -> print msg + LoadSuccess _ v -> return v +} +\end{quote} +% +This is the basic interface to the dynamic loader. Load the object file +specified by the first argument into the address space (the library will +preload any module or package dependencies). The second argument is an +include path to any additional objects to load (possibly the API of the +plugin). The third argument is a list of paths to any user-defined +\code{package.conf} files, specifying packages unknown to the GHC +package system. \code{Symbol} is a string specifying the symbol name you +wish to lookup. \code{load} returns a \code{LoadStatus} value representing +failure, or an abstract representation of the module (for calls to +\code{unload} or \code{reload}) with the symbol as a Haskell value. The +value returned must be given an explicit type signature, or provided +with appropriate type constraints such that GHC can determine the +expected type returned by \code{load}, as the return type is notionally +polymorphic. + +\code{load\_} is provided for the common situation where no user-defined +package.conf files are required. + +\begin{quote} +\scm{ +dynload :: Typeable a + => FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do mv <- dynload "Plugin.o" ["api"] ["plugins.conf.inplace"] "resource" + case mv of + LoadFailure msg -> print msg + LoadSuccess _ v -> putStrLn v +} +\end{quote} +% +\code{dynload} is a safer form of \code{load}. It uses dynamic types +to perform a check on the value returned by \code{load} at runtime, to +ensure that it has the type the application expects it to have. +\code{pdynload} is on average 7\% slower than an unchecked load. + +In order to use \code{dynload}, the symbol the plugin exports must be +of type \code{AltData.Dynamic:Dynamic}. (See the \code{AltData} library +distributed with \hsplugins{}, and the \hsplugins{} +\code{examples/dynload} directory. References to \code{Typeable} and +\code{Dynamic} refer to the \hsplugins{} reimplementation of these +libraries. \code{AltData.Dynamic} is used at the moment, as there is a +limitation in the existing Data.Dynamic library in the presence of +dynamic loading. This will be fixed soon). + +The value wrapped up in the \code{Dynamic} must be an instance of +\code{AltData.Typeable}. If the value exported by the plugin \emph{is} +of type \code{Dynamic}, and the value wrapped by the \code{Dynamic} +does not match the type expected of it by the application, +\code{dynload} will return \code{Nothing}, indicating that the plugin +is not typesafe with respect to the application. If the value passes +the typecheck, \code{dynload} will return \code{LoadSuccess}. If the value +exported by the plugin is \emph{not} of type \code{Dynamic}, +\code{dynload} will crash---this is a limitation of the existing +\code{Dynamic} library, it can only type-check \code{Dynamic} values. +Additionally, Data.Dynamic is limited to monomorphic types, or must be +wrapped inside a rank-N type to hide the polymorphism from the +typechecker. This is a bit cumbersome. An alternative typesafe +\code{load} is available via the \code{pdynload} interface, which is +able to enforce the type of the plugin using GHC's type inference +mechanism, and is not restricted in its expressiveness (at the cost of greater load +times): + +\begin{quote} +\scm{ +pdynload :: FilePath + -> [FilePath] + -> [PackageConf] + -> Type + -> Symbol + -> IO (LoadStatus a) +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do v <- pdynload "Plugin.o" ["api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "yay!" + _ -> putStrLn "type error" +} +\end{quote} +% +\code{pdynload} is a replacement for \code{dynload}, which provides a +solution to the various problems caused by the existing dynamics +library in Haskell. Rather than use normal dynamics, which constrain +us to monomorphic types only (or rank-N types), it instead uses GHC's +type inference to unify the plugin's export value with that provided +by the api (via its .hi file). It is a form of \emph{staged type inference} +for module interfaces, allowing plugins to use any type definable in Haskell. +\code{pdynload} is like \code{dynload}, but requires a new \code{Type} +argument. This can be considered a type annotation on the value the plugin +should be constrained to. + +The type of the plugin's resource field must be equivalent to the +\code{Type}. Prior to loading the object, \code{pdynload} generates a +tiny Haskell source file containing, for example: +% +\begin{quote} +\scm{ +module APITypeConstraint where +import qualified API +import qualified Plugin + +_ = Plugin.resource :: API.Interface +} +\end{quote} +% +It then calls GHC's type checker on this file, which runs the full +Haskell type inference machinery. If the file typecheckes, then the +plugin type is correct, and the plugin is safe to load, otherwise it +is an error. + +Because we use the full Haskell type checker, we can have a form of +dynamic typechecking, on any type expressable in Haskell. A plugin's +value may, for example, have class constraints -- something not +checkable using the standard Dyanmic type. The cost is that +\code{pdynload} is roughly 46\% slower than an unchecked load. + +\begin{quote} +\scm{ +unload :: Module -> IO () +} +\end{quote} + +Unload an object, \emph{but not its dependencies} from the address +space. + +\begin{quote} +\scm{ +reload :: Module -> Symbol -> IO (LoadStatus a) +} +\end{quote} + +Unload, and then reload a module that must have been previously +loaded. Doesn't reload the dependencies. \code{reload} is useful in +conjunction with \code{make}---a call to \code{reload} can be +performed if \code{make} has recompiled the plugin source. + +Additionally, some support is provided to manipulation of +libraries of Haskell modules (usually known as packages): + +\begin{quote} +\scm{ +loadPackage :: String -> IO () + +unloadPackage :: String -> IO () + +loadPackageWith :: String -> [PackageConf] -> IO () +} +\end{quote} + +\code{loadPackage} explcitly pulls in a library (which must be visible +in the current package namespace. \code{unloadPackage} unloads it. +\code{loadPackageWith} behaves like \code{loadPackage}, but you are able +to supply extra package.confs to augment the library search path. + +Examples: +\begin{quote} +\scm{ +do loadPackageWith "yi" ["yi.conf"] + unloadPackage "yi" +} +\end{quote} + +\newpage + +\section{Compilation Manager} + +The compilation manager is the system by which Haskell source code is +compiled to object code suitable for loading. + +\subsection*{Interface} + +\begin{quote} +\scm{ +make :: FilePath + -> [Arg] + -> IO MakeStatus + +makeAll :: FilePath + -> [Arg] + -> IO MakeStatus + +data MakeStatus + = MakeSuccess MakeCode FilePath + | MakeFailure Errors + +data MakeCode = ReComp | NotReq +} +\end{quote} + +Compile a Haskell source file to an object file, with any arguments +specified in the argument list passed through to GHC. Returns the +build status. + +\code{make} generates a GHC \code{.hi} file containing a list of +package and objects that the source depends on. Subsequent calls to +\code{load} will use this interface file to load module and library +dependencies prior to loading the object itself. \code{makeAll} also +recursively compiles any dependencies it can find using GHC's +\code{--make} flag. + +\begin{quote} +\scm{ +merge :: FilePath -> FilePath -> IO MergeStatus + +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus + +data MergeStatus + = MergeSuccess MergeCode Args FilePath + | MergeFailure Errors + +type MergeCode = MakeCode +} +\end{quote} + +The merging operation is extremely useful for providing extra default +syntax. An EDSL user then need not worry about declaring module names, +or having required imports. In this way, the stub file can also be +used to provide syntax declarations that would be inconvenient to +require of the plugin author. \code{merge} will include any import and +export declarations written in the stub, as well as any module name, +so that plugin author's need not worry about this compulsory syntax. +Additionally, if a plugin requires some non-standard library, which +must be provided as a \code{-package} flag to GHC, they may specify +this using the non-standard \code{GLOBALOPTIONS} pragma. Options +specified in the source this way will be added to the command line. +This is useful for users who wish to use GHC flags that cannot be +specified using the conventional \code{OPTIONS} pragma. + +\begin{quote} +\scm{ +makeWith :: FilePath + -> FilePath + -> [Arg] + -> IO MakeStatus +} +\end{quote} + +This is a variety of \code{make} that first calls \code{merge} to +combine the plugin source with a syntax stub. The result is then +compiled. This is the preferred interface to EDSL authors who wish to +add extra syntax to a user's source. It is important to note that the +module and types from the second file argument are used to override +any of those that appear in the first argument. For example, consider +the following source files: + +\begin{quote} +\scm{ +module A where + +a :: Integer +a = 1 +} +\end{quote} + +\begin{quote} +\scm{ +module B where + +a :: Int +} +\end{quote} + +Calling \code{makeWith "A" "B" []} will merge the module name and types +from module B into module A, generating a third file: + +\begin{quote} +\scm{ +{-# LINE 1 "A.hs" #-} +module MxYz123 where + +{-# LINE 3 "B.hs" #-} +a :: Int +{-# LINE 4 "A.hs" #-} +a = 1 +} +\end{quote} + +Leading to the desired result that we can ignore user-supplied module +names and types. Knowing the module name, in particular, is important +for dynamic loading, which requires the module name be known when +searching for symbols. + +\subsection*{Levels of Safety} + +The normal dynamic loader, using \code{load} on object files only, +places full trust in the author of the plugin to provide a type-safe +object file, containing valid code. This can be mitigated somewhat via +the use of \code{make} to ensure that the plugin is at least Haskell +code that is well-typed internally (if we trust GHC to compile it +correctly). + +If we trust the user to provide an interface of \code{Dynamic} type, we +can check the plugin type at runtime, but the plugin's value must be +\code{Typeable}, which restricts it to be a monomorphic type (or to +using rank-N tricks). + +The greatest safety can be obtained by using \code{pdynload}, at the +cost of increased load times. \code{pdynload} essentially performs full +type inference on the plugin interface at runtime. The type safety of +the plugin, using \code{pdynload}, is then as safe as if the plugin was +statically compiled into the application. It does not provide any +\emph{further} safety than exists in static compilation. For example, it +does not preclude the use of (evil) \code{unsafeCoerce\#} to defeat +type-checking, either statically or at runtime. An extensive discussion +of type safe plugin loading is available in the \hsplugins{} paper +\urlh{http://www.cse.unsw.edu.au/~dons/hs-plugins/paper}{here}. + +\newpage + +\section{Eval.Haskell} + +\code{eval}, and its siblings, provide a mechanism to compile and run +Haskell code at runtime, in the form of a String. It is provided as a +separate package to the plugins package, and needs to be linked +against using \code{-package eval}. The general framework is that the +string is used to create a plugin source file, which is compiled and +loaded, and type checked against its use. The resulting value is +returned to the caller. It resembles the \code{eval} primitives of +scripting languages. + +\subsection*{Interface} + +\begin{quote} +\scm{ +eval :: Typeable a => String -> [Import] -> IO (Maybe a) +} +\end{quote} + +\code{eval} takes a string, and a list of import module names, and +returns a \code{Maybe} value. \code{Nothing} means the code did not +compile. \code{Just v} gives you \code{v}, the result of evaluating +your code. It is interesting to note that \code{eval} has the type of +an interpreter. The \code{Typeable} constraint is used to type check +the evaluated code when it is loaded, using \code{dynload}. The +existing \code{Data.Dynamic} library requires that only monomorphic +values are \code{Typeable}, so in order to evaluate polymorphic +functions you need to wrap them up using rank-N types. Some +examples: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int) + if isJust i then putStrLn (show (fromJust i)) else return () +} +\end{quote} + +When executed this program calls \code{eval} to compile and load the +simple arithmetic expression, returning the result, which is +displayed. If the value loaded is not of type \code{Int}, +\code{dynload} will throw an exception. + +The following example, due to Manuel Chakravarty, shows how to +evaluate a polymorphic function. Polymorphic values are not easily +made dynamically typeable, but this example shows how to do it. The +module \code{Poly} is imported as the second argument, providing the +type of the polymorphic function: +% +\begin{quote} +\scm{ +import Poly +import Eval.Haskell + +main = do m_f <- eval "Fn (\\x y -> x == y)" ["Poly"] + when (isJust m_f) $ do + let (Fn f) = fromJust m_f + putStrLn $ show (f True True) + putStrLn $ show (f 1 2) +} +\end{quote} +% +And the type of \code{Fn}: +% +\begin{quote} +\scm{ +{-# OPTIONS -fglasgow-exts #-} +module Poly where + +import AltData.Typeable + +data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool} + +instance Typeable Fn where + typeOf _ = mkAppTy (mkTyCon "Poly.Fn") [] +} +\end{quote} +% +When executed, this program produces: +% +\begin{quote} +\begin{verbatim} +$ ./a.out +True +False +\end{verbatim} +\end{quote} + +We thus get dynamically typeable polymorphic functions. + +\begin{quote} +\scm{ +unsafeEval :: String -> [Import] -> IO (Maybe a) + +unsafeEval_ :: String + -> [Import] + -> [String] + -> [FilePath] + -> IO (Either [String] a) +} +\end{quote} + +Wrapping up polymorphic values can be annoying, so we provide a +\code{unsafeEval} function for people who like to live on the edge, +which dispenses with dynamic typing, relying instead on the +application to provide the correct type annotation on the call to +\code{eval}. If the type loaded by \code{eval} is wrong, +\code{unsafeEval} will crash. However, its lets us remove some +restrictions on what types can be evaluated, which can be useful. + +{unsafeEval\_} lets the application have full control over the import +environment and load flags to the eval call, which is useful for +applications that wish to script themselves, and require specific +modules and packages to be in scope in the eval-generated module. + +This example maps a \code{toUpper} over a list: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do s <- unsafeEval "map toUpper \"haskell\"" ["Data.Char"] + when (isJust s) $ putStrLn (fromJust s) +} +\end{quote} + +And here we evaluate a lambda abstraction, applying the result to +construct a tuple. Note the type information that must be supplied in +order for Haskell to type the usage of \code{fn}: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do fn <- unsafeEval "(\\(x::Int) -> (x,x))" [] :: IO (Maybe (Int -> (Int,Int))) + when (isJust fn) $ putStrLn $ show $ (fromJust fn) 7 +} +\end{quote} + +\subsection{Foreign Eval} + +A preliminary binding to \code{eval} has been implemented to allow C +(and Objective C) programs access to the evaluator. Foreign bindings +to the compilation manager and dynamic loader are yet to be +implemented, but shouldn't be too hard. An foreign binding to a +Haskell module that wraps up calls to \code{make} and \code{load} +would be fairly trivial. + +At the moment we have an ad-hoc binding to \code{eval}, so that C +programmers who know the type of value that will be returned by +Haskell can call the appropriate hook into the evaluator. If they get +the type wrong, a nullPtr will be returned (so calling Haskell is +still typesafe). The foreign bindings to \code{eval} all return +\code{NULL} if an error occurred, otherwise a pointer to the value is +returned. + +\begin{quote} +\scm{ +foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt) + +foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar) + +foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt) + +foreign export ccall hs_eval_s :: CString -> IO CString +} +\end{quote} + +An example C program for compiling and evaluating Haskell code at +runtime follows. This program calculates a fibonacci number, returning +it as a \code{CString} to the C program: +% +\begin{quote} +\begin{verbatim} +#include "EvalHaskell.h" +#include + +int main(int argc, char *argv[]) +{ + char *p; + hs_init(&argc, &argv); + p = hs_eval_s("show $ let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20"); + if (p != NULL) + printf("%s\n",p); + else + printf("error in code\n"); + hs_exit(); + return 0; +} +\end{verbatim} +\end{quote} + +\subsection{Eval.Printf} + +It has been noted that \code{printf} format strings are the concrete syntax +of a string formatting interpreter (over 1000 lines long in libc!). By +combining runtime generation of new Haskell code, with dynamic typing, +it becomes possible to implement a typesafe \code{printf} for Haskell. + +This has already been achieved in at least 3 different ways. A standard +solution (Hinze, Danvey) begins by supplying printf with the abstract +syntax of the formatting string, resolving the issue of the lack of +typing in the raw fmt string. An alternative solution (see Ian Lynagh's +Printf library) uses Template Haskell to transform a printf format +string into a new Haskell function at compile time, however this +requires that the format string is known at compile time. By using +runtime compilation we can take a similar approach, but instead generate +the print function at runtime! To make this safe, we then need to use +dynamic typing to check the newly-generated print function against its +arguments. + +\subsection*{Printf Interface} + +The \code{Printf} library implements a reasonable amount of the C +printf's functionality. + +\begin{quote} +\scm{ +printf :: String -> [Dynamic] -> IO () +} +\end{quote} + +\begin{quote} +\scm{ +sprintf :: String -> [Dynamic] -> IO String +} +\end{quote} + +Because the arguments to printf are of differing types, and the number +of arguments is not known at compile time, we simulate variadic +functions by using a heterogenous list of arguments. A special list +constructor, \code{!}, is provided for this. An example, noting the +syntax for constructing a heterogenous argument list: + +\begin{quote} +\scm{ +import Eval.Printf + +main = do printf "%d\n" $ (42::Int) ! [] + printf "0x%X\n" $ (42::Int) ! [] + printf "%f\n" $ (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $ 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $ "haskell" ! [] + printf "%010.4f\n" $ (42.1234 :: Double) ! [] + printf "%10.4s\n" $ "haskell" ! [] + printf "%-10.4s\n" $ "haskell" ! [] +} +\end{quote} + +Compiling this program against \code{-package eval}, and running it +produces the following output: +% +\begin{quote} +\begin{verbatim} +42 +0x2A +42.123400 +a:b:c +haskell +00042.1234 + hask +hask +\end{verbatim} +\end{quote} + +If you mismatch the types specified in the format string, and the +types you apply printf to, printf will generate an exception, like so: + +\begin{quote} +\scm{ +import Eval.Printf + +main = printf "%d\n" ("badstring" ! []) +} +\end{quote} + +The above code will generate this error, indicating that you attempted +to apply a string to a function that expected an Int: +% +\begin{quote} +\begin{verbatim} +paprika$ ./a.out +Fail: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> +\end{verbatim} +\end{quote} + +Note that this isn't the fastest printf implementation in the world. A +call to printf invokes GHC to transform the printf format string into +a Haskell code fragment, which is compiled and dynamically linked back +into the application, and then applied to its arguments. If you need +to use the same printf function against multiple times, you can save +recompilation, in which case printf runs as fast as other native code. + +Additionally, it only implements the most common modifiers to the +basic conversion specifiers, and they have not all been fully tested. + +\section{RTS Binding} + +The low level interface is the binding to GHC's Linker.c. Therefore, +\hsplugins{} only works on platforms with a working GHCi. This library +is based on code from André Pang's runtime loader. The low level +interface is as follows: + +\begin{itemize} + \item \code{initLinker} \em start the linker up + \item \code{loadObject} \em load a vanilla .o + \item \code{loadPackage} \em load a GHC library and its cbits + \item \code{loadShared } \em load a .so object file + \item \code{resolveObjs} \em and resolve symbols +\end{itemize} + +Additionally, \code{Hi.Parser} provides an interface to a GHC +\code{.hi} file parser. Currently we only parse just the dependency +information, import and export information from \code{.hi} files, but +all the code is there for an application to extract other information +from \code{.hi} files. + +\newpage + +\section{Dynamic Loader Implementation} + +The dynamic loader is the system by which modules, and their +dependencies can be loaded, unloaded or reloaded at runtime, and +through which we access the functions we need. + +At its lowest level, the \hsplugins{} loader is a binding to the GHC +runtime loader and linker. This layer is a direct reimplementation of +Andre Pang's \code{runtime\_loader} (barely any code changed). The +code at this level can only load single modules, or packages/archives +(which are just objects too). Any dependency resolution must be +performed by hand. + +On top of Andre's interface is a more convenient interface through +which user's should interact with the dynamic loader. The most +significant extension to Andre's work is the automatic calculation and +loading of a plugin's package or module dependencies via .hi file +information. It also handles initialisation of the loader, and +retrieval of values from the plugin in a more convenient way. Some +state is also stored in the loader to keep track of which modules and +packages have been loaded, to prevent unnecessary (actually, fatal) +loading of object files and packages already loaded. Thus you can +safely load several plugins at once, that share common dependencies, +without worrying about the dependencies being loaded multiple times. +We also store package.conf information in the state, so we can work +out where a package lives and what it depends on. + +The ability to remember which packages and objects have been loaded is +based on ideas in Hampus Ram's dynamic loader, which has a more +advanced dependency tracking system, with the ability to unload the +dependencies of a plugin. \hsplugins{} doesn't provide ``cascading +unloading''. The advantage \hsplugins{} has over Hampus' loader seems +to be the automatic dependency resolution via vanilla .hi files and +the dynamic recompilation stuff. + +Using \code{load}, any library packages, or any \code{.o} files, that a +plugin depends upon will be automatically loaded prior to loading the +module itself. \code{load} then looks up a symbol from the object file, +and returns the value associated with the symbol as a conventional +Haskell value. It should also be possible to load a GHCi-style \code{.o} +archive of object files this way, although there is currently no way +to extract multple plugin interfaces from a archive of objects. + +The application writer is not required to recalculate dependencies if +the plugin changes, and the plugin author does not need to specify +what dependencies exist, as is required in the lower level interface. +This is achieved by using the dependency information calculated by GHC +itself, stored in .hi files, to work out which modules and packages to +load, and in what order. A plugin in \hsplugins{} is really a pair of +an object file (or archive) and a \code{.hi} file, containing package +and module dependency information. + +The \code{.hi} file is created by GHC when the plugin is compiled, +either by hand or via \code{make}. \code{load} uses a binary parser to +extract the relevant information from the \code{.hi} data. Because the +dependency information is stored in a separate file to the application +that loads the plugin, such information can be recalculated without +having to modify the application. Becaues of this, it was easy to +extend the load to support recompilation of module source, even if +dependencies change, because dependencies are no longer hard-coded +into the application source itself, but are specified by the plugin. + +Assuming we have a plugin exporting some data, ``resource'', with a +record name \code{field :: String}, here is an example call to \code{load}: +% +\begin{quote} +\scm{ +do m_v <- load "Test.o" ["."] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +This loads the object file \code{Test.o}, and any packages or objects +\code{Test.o} depends on. It resolves undefined symbols, and returns +from the object file the Haskell value named ``resource'', as the +value ``v''. This must be a value exported by the plugin. We then +retrieve the \code{field} component of \code{v}, and print it out. + +This simple usage assumes that the plugin to load is in the same +directory as the application, and that the api defining the interface +between plugin and application is also in the current directory (hence +the ``.'' in the 2nd argument to \code{load}). + +\subsection*{Dynamically Loading the Dynamic Loader} + +It is also possible to load the \code{plugins} or \code{eval} +libraries in GHC. A couple of recent patches to the linker have made +this possible (available in ghc-6.2.2 or in the head branch). Here, +for example, we load the \code{plugs} interactive environment in GHCi, +and evaluated some code. The source to \code{plugs} is in Appendix +\ref{sec:plugs}. +% +\begin{quote} +\begin{verbatim} +paprika$ ghci -package-conf ../../../plugins.conf.inplace -package eval + ___ ___ _ + / _ \ /\ /\/ __(_) + / /_\// /_/ / / | | GHC Interactive, version 6.3, for Haskell 98. +/ /_\\/ __ / /___| | http://www.haskell.org/ghc/ +\____/\/ /_/\____/|_| Type :? for help. + +Loading package base ... linking ... done. +Loading package altdata ... linking ... done. +Loading package unix ... linking ... done. +Loading package mtl ... linking ... done. +Loading package lang ... linking ... done. +Loading package posix ... linking ... done. +Loading package haskell98 ... linking ... done. +Loading package haskell-src ... linking ... done. +Loading package plugins ... linking ... done. +Loading package eval ... linking ... done. +Prelude> :l Main +Skipping Main ( Main.hs, Main.o ) +Ok, modules loaded: Main. +Prelude Main> main +Loading package readline ... linking ... done. + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... done +plugs> map (\x -> x + 1) [0..10] +[1,2,3,4,5,6,7,8,9,10,11] +plugs> :t "haskell" +"haskell" :: [Char] +plugs> :q +*** Exception: exit: ExitSuccess +Prelude Main> :q +Leaving GHCi. +\end{verbatim} +\end{quote} + +\subsection*{Dynamic Typing} + +Support is also provided to unwrap and check the type of dynamically +typed plugin values (those wrapper in a \code{toDyn}) via +\code{dynload}. This is the same as \code{load}, except that instead +of a returning the value it finds, it unwraps a dynamically typed +value, checks the type, and returns the unwrapped value. This is to +provide further trust that the symbol you are retrieving from the +plugin is of the type you think it is, beyond that trust you have by +knowing that the plugin was compiled against a shared API. By using +\code{dynload} it is not enough for an object file to just have the +same symbol name as the function you require, it must also carry the +\code{Data.Dynamic} representation of the type, too. \code{pdynload} +rectifies most of \code{dynload}'s limitations, but at the cost of +additional running time. + +\section{Compilation Manager Implementation} + +Along side the dynamic loader is the compilation manager. This is a +\code{make}-like system for compiling Haskell source, prior to loading +it. \code{make} checks if a source file is newer than its associated +object file. If so, the source is recompiled to an object file, and a +new dependency file is created, in case the dependencies have changed +in the source. This module can then be loaded. The idea is to allow +EDSL authors to write plugins without having to touch a compiler: it +is all transparent. It also allows us to enforce type safety in the +plugin by injecting type constraints into the plugin source, as has +been discussed eariler. + +The effect is much like \emph{hi} (Hmake Interactive), funnily enough. +An application using both \code{make} and \code{load} behaves like a +Haskell interpreter, using \code{eval}. You modify your plugin, and +the application notices the change, recompiles it (possibly issuing +type errors) and then reloads the object file, providing the +application with the latest version of the code. + +An example: +% +\begin{quote} +\scm{ +do status <- make "Plugin.hs" [] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load obj ["api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +\code{make} accepts a source file as an argument, and a (usually empty) +list of GHC flags needed to compile the object file. It then checks to +see if compilation is required, and if so, it calls GHC to compile the +code, with and arguments supplied. If any errors were generated by +GHC, they are returned as the third component of the triple. + +Usually it will be necessary to ensure that GHC can find the plugin +API to compile against. This can be done by either making sure the API +is in the same directory as the plugin, or by adding a \code{-i} flag to +\code{make}'s arguments. If the API is created as a ``package'' with a +package.conf file, \code{make} can be given \code{-package-conf} arguments +to the same effect. + +Normally, \code{make} generates the \code{.o} and \code{.hi} files in +the same directory as the source file. This is not always desirable, +particularly for interpreter-like applications. To solve this, you can +pass \code{[''-odir'', path]} as elements of the arg list to +\code{make}, and it will respect these arguments, generating the +object and interface file in the directory specified. GHC's argument +\code{''-o''} is also respected in a similar manner, so you could also +say \code{[''-o'', obj]} for the same effect. + +\code{make} is entirely optional. All user's have to do to use the +loader on its own is make sure they only load object files that also +have a \code{.hi} file. This will usually be the case if the plugin is +compiled with GHC. + +\subsection*{makeWith} + +\code{makeWith} merges two source files together, using the function +and value declarations from one file, with any syntax in the second, +creating a new third source file. It then compiles this source file +via \code{make}. + +This function exists as a benefit to EDSL authors and is related to +the original motivation for \hsplugins{}, as a .conf file language +library. Configuration files need to be clean and simple, and you +can't rely, or trust, the user to get all the compulsory details +correct. So the solution is to factor out any compulsory syntax, such +as module names, imports, and also to provide a default instance of +the API, and store this code in a separate file provided by the +application writer, not the user. \code{makeWith} then merges +whatever the user has written, with the syntax stub, generating a +complete Haskell plugin source, with the correct module names and +import declarations. We also ensure the plugin only exports a single +interface value while we are here. + +\code{makeWith} thus requires a Haskell parser to parse two source files +and merge the results. We are merging abstract syntax here. This is +implemented using the Language.Haskell parser library. Unfortunately, +this library doesn't implement all of GHC's extensions, so if you wish +to use \code{makeWith} you can only write Haskell source that can be +parsed by this library, which is just H98 and a few extensions. This +is another short coming in the current design that will be overcome +with \code{-package ghc}. Remember, however, for normal uses of +\code{make} and \code{load} you are unrestricted in what Haskell you use. +This is the same restriction present in happy, the Haskell parser, +placed on the code you can provide in the \code{.y} source. + +\code{makeWith} also makes use of line pragmas. If the merged file +fails to compile, the judicious use of line number pragmas ensure that +the user receives errors messages reported with reference to their +source file, and not line number in the merged file. This is a +property of the Language.Haskell parser that we can make use of. + +An example of \code{makeWith}: +% +\begin{quote} +\scm{ +do status <- makeWith "Plugin.in" "Plugin.stub" [] + obj <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load obj [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +We combine the user's file (\code{Plugin.in}) with a stub of syntax +generating a new, third Haskell file in the default tmpdir. This is +compiled as per usual, producing object and interface files. The +object is then loaded, and we extract the value exported. + +Using \code{makeWith} it is possible to write very simple, clear +Haskell plugins, that appear not to be Haskell at all. It is an easy +way to get EDSL user's writing plugins that are actually Haskell +programs, for .e.g, configuration files. See the examples that come +with the src. + +\newpage + +\section{An Example} + +This is an introductory example. + +\subsection*{API} + +First we need an interface between the application and the plugin. +This module needs to be visible to both the app and the plugin, in the +interest of clear and well-defined interfaces: +% +\begin{quote} +\scm{ +module StringProcAPI (Interface(..), plugin) where + +data Interface = Interface { + stringProcessor :: String -> String +} + +plugin :: Interface +plugin = Interface { stringProcessor = id } +} +\end{quote} + +Here we define \code{Interface} as the inteface signature for the +object passed between plugin and application. We'll use the record +syntax as it looks intuitive in the plugin. We provide a default +instance, the \code{plugin} value, that can be overwritten in the +actual plugin, ensuring sensible behaviour in the absence of any +plugins. The API should theoretically be compiled with \code{-Onot} to +avoid interface details leaking out into the \code{.hi} file. + +\subsection*{The Plugin} + +This is our plugin. Note that the plugin will be compiled entirely +seperately from the application. It must only rely on the API, and +nothing in the application source. +% +\begin{quote} +\scm{ +module StringProcPlugin (resource) where + +import StringProcAPI (plugin) + +resource = plugin { + stringProcessor = reverse +} +} +\end{quote} + +Using the record syntax we overwrite the \code{function} field with our +own value, \code{reverse}. The value \code{resource} is the magic symbol +that must be defined, and which the application will use to find the +data the plugin exports. + +Now, we can make this even easier on the plugin writer by the use of a +``stub'' file. \code{makeWith} lets you merge a plugin source with +another Haskell file, and compiles the result into the actual plugin +object. So the application can provide a stub file containing module +declarations and imports, and a default plugin value. Here is an +application-provided stub, factoring out compulsory syntax and type +declarations from the plugin: +% +\begin{quote} +\scm{ +module StringProcPlugin ( resource ) where + +import StringProcAPI + +resource :: Interface +resource = plugin +} +\end{quote} + +By factoring out compulsory syntax, the plugin author only has to +provide an overriding instance of the \code{resource} field. So all +the plugin actually consists of, is: +% +\begin{quote} +\scm{ +resource = plugin { + stringProcessor = reverse +} +} +\end{quote} + +That is all the code we need! This file may be called anything at all. + +More complex APIs may have more fields, of course. The nice thing +about this arrangement is that the user will write some simple syntax, +which will nonetheless by typechecked safely against the API. Errors +are also reported using line numbers from the source file, not the +stub, which makes things less confusing. + +\subsection*{The Application} + +Now we need to write an application that can use values of the kind +defined in the API, and which can compile and load plugins. The basic +mechanism to compile and load a plugin is as follows: +% +\begin{quote} +\scm{ +do status <- make "StringProcPlugin.hs" [] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load obj ["."] [] "resource" + val <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" +} +\end{quote} +% +This code calls \code{make} to compile the plugin source, yielding +wrapper around a handle to an object file. The object can then be loaded +using \code{load}, and the code associated with the symbol +\code{resource} is retrieved. + +We embed this code in a simple shell-like loop, applying the function +exported by the plugin: +% +\begin{quote} +\scm{ +import Plugins +import StringProcessorAPI +import System.Console.Readline +import System.Exit + +source = "Plugin.hs" +stub = "Plugin.stub" +symbol = "resource" + +main = do s <- makeWith source stub [] + o <- case s of + MakeSuccess _ obj -> do + ls <- load obj ["."] [] symbol + case ls of LoadSuccess m v -> return (m,v) + LoadFailure err -> error "load failed" + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + shell o + +shell o@(m,plugin) = do + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + + s <- makeWith source stub [] -- maybe recompile the source + o' <- case s of + MakeSuccess ReComp o -> do + ls <- reload m symbol + case ls of LoadSuccess m' v' -> return (m',v') + LoadFailure err -> error "reload failed" + MakeSuccess NotReq _ -> return o + MakeFailure e -> mapM_ putStrLn e >> shell o + eval cmd o' + shell o' + +eval ":?" _ = putStrLn ":?\n:q\n" + +eval s (_,plugin) = let fn = (stringProcessor plugin) in putStrLn (fn s) +} +\end{quote} + +We have to import the hs-plugins library, and the API. The main loop +proceeds by compiling and loading the plugin for the first time, and +then calls \code{shell}, the interpeter loop. This loop lets us apply +the function in the plugin to strings we supply. We have to pass +around the \code{(Module, a)} pair we get back from \code{reload}, so +that we can pass it to \code{eval} to do the real work. The first +\code{eval} case is where we use the record syntax to select the +\code{function} field out of \code{v}, the plugin interface object, +and we apply it to s. Try it out: +% +\begin{quote} +\begin{verbatim} +paprika$ ./a.out +Loading package base ... linking ... done +Loading objects API Plugin ... done +> :? +":?" +":q" +"" +> abcdefg +gfedcba +\end{verbatim} +\end{quote} + +Now, if we edit the plugin while the shell is running, the next time +we type something at the prompt the plugin will be unloaded, +recompiled and reloaded. Because the plugin is really an EDSL, we can +use any Haskell we want, so we'll change the plugin to: +% +\begin{quote} +\scm{ +import Data.Char + +resource = plugin { + stringProcessor = my_fn +} + +my_fn s = map toUpper (reverse s) +} +\end{quote} + +Back to the shell: +% +\begin{quote} +\begin{verbatim} +> abcdefg +Compiling plugin ... done +Reloading Plugin ... done +GFEDCBA +\end{verbatim} +\end{quote} + +And that's it: dynamically recompiled and reload Haskell code! + +\section{Multiple Plugins} + +It is quite easy to load multiple plugins, that all implement the +common plugin API, and that all export the same value (though +implemented differently). This make \hsplugins{} suitable for +applications that wish to allow an arbitrary number of plugins. The +main problem with multiple plugins is that they may share +dependencies, and if \code{load} na\"ively loaded all dependencies +found in the set of \code{.hi} files associated with all the plugins, +the GHC rts would crash. To solve this the \hsplugins{} dynamic loader +maintains state storing a list of what modules and packages have been +loaded already. If \code{load} is called on a module that is already +loaded, or dependencies are attempted to load, that have already been +loaded, the dynamic loader ignores these extra dependencies. This +makes it quite easy to write an application that will allows an +arbitrary number of plugins to be loaded. An example follows. + +\subsection*{Definition} + +First we need to define the API that a plugin must type check against, +in order to be valid. +% +\begin{quote} +\scm{ +module API where + +data Interface = Interface { + valueOf :: String -> String +} + +plugin :: Interface +plugin = Interface { valueOf = id } +} +\end{quote} + +We can then implement a number of plugins that provide values of type +"Interface". We show three plugins that export string manipulation functions: +% +\begin{quote} +\scm{ +module Plugin1 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> map toUpper s +} +} +\end{quote} + +\begin{quote} +\scm{ +module Plugin2 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> map toLower s +} +} +\end{quote} + +\begin{quote} +\scm{ +module Plugin3 where + +import API + +resource = plugin { + valueOf = reverse +} +} +\end{quote} + +And finally we need to write an application that would use these +plugins. Remember that the application is written without knowledge of +the plugins, and the plugins are written without knowledge of the +application. They are each implemented only in terms of the API, a +shared module and \code{.hi} file. An application needs to make the +API interface available to plugin authors, by distributing the API +object file and \code{.hi} file with the application. +% +\begin{quote} +\scm{ +import Plugins +import API + +main = do + let plist = ["Plugin1.o", "Plugin2.o", "Plugin3.o"] + plugins <- mapM (\p -> load p ["."] [] "resource") plist + let functions = map (valueOf . fromLoadSuc) plugins + mapM_ (\f -> putStrLn $ f "haskell is for hackers") functions + +fromLoadSuc (LoadFailure _) = error "load failed" +fromLoadSuc (LoadSuccess _ v) = v + +} +\end{quote} + +This application simply loads all the plugins and retrieves the +functions they export. It then applies each of these functions to a +string, printing the result. We assume for this example that the +plugins are compiled once only, and are not compiled dynamically via +\code{make}. This implies that you have to use \code{GHC} to generate +the \code{.hi} file for each plugin. A sample Makefile to compile the +plugins, and the api: +% +\begin{quote} +\begin{verbatim} +all: + ghc -Onot -c API.hs + ghc -O -c Plugin1.hs + ghc -O -c Plugin2.hs + ghc -O -c Plugin3.hs +\end{verbatim} +\end{quote} + +Ghc creates \code{.hi} files for each plugin, which can be inspected +using the \code{Plugins.BinIface.readBinIface} function. It parses the +\code{.hi} file, generating, roughly, the following: +% +\begin{quote} +\begin{verbatim} +interface "Main" Main +module dependencies: A, B +package dependencies: base, haskell98, lang, unix +\end{verbatim} +\end{quote} + +which says that the plugin depends upon a variety of system packages, +and the modules A and B. All these dependencies must be loaded before +the plugin itself. + +You then need to compile the application against the API, and against +the \hsplugins{} library: +% +\begin{quote} +\begin{verbatim} +ghc -O --make -package plugins Main.hs +\end{verbatim} +\end{quote} + +Running the application produces the following result. Note that the +verbose output can be switched off by compiling \hsplugins{} without +the \code{-DDEBUG} flag. If you look at the \code{.hi} file, using +\code{ghc --show-iface}, you'll see that they all depend on the base +package, and on the API, but the state stored in the dynamic loader +ensures that these shared modules are only loaded once: +% +\begin{quote} +\begin{verbatim} +Loading package base ... linking ... done +Loading object API Plugin1 ... done +Loading object Plugin2 ... done +Loading object Plugin3 ... done + +HASKELL IS FOR HACKERS +haskell is for hackers +srekcah rof si lleksah +\end{verbatim} +\end{quote} + +Archives of plugins can be loaded in one go if they have been linked +into a .o GHCi package, see \code{loadPackage}. + +\newpage + +\appendix + +\section{License} + +This library is distributed under the terms of the LGPL: + +\begin{quote} + +Copyright 2004, Don Stewart - \url{http://www.cse.unsw.edu.au/~dons} + +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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +USA + +\end{quote} + +\section{Portability} + +The library tries to be portable. There are two major points that +limit easy portabilty. The first is the dependence on the GHC dynamic +linker. \hsplugins{} is thus limited to platforms to which GHC's dyn +linker has been ported (this is essentially the same as the platforms +that can run GHCi). + +Other than this, there are 3 platform specific items that need to be +defined for new platforms: +\begin{itemize} + \item Where tmp files should be created. Define the + \code{tmpDir} variable in \code{Plugins/Consts.hs} + + \item Process creation, such that we can read stdin and stderr + from the process (this is the POpen library for Posix + systems). For Windows, \hsplugins{} carries Simon + Marlow's \code{forkProcess} library. + + \item Dealing with backslashes in Dos-style path names +\end{itemize} + +I plan to solve the above 3 problems (and thus have a Windows port) once +GHC 6.4 is out. + +\newpage + +\section{A Haskell Interpreter using Plugins} +% \label{sec:plugs} + +Here is a full length example of a Haskell interpreter/compiler in the +style of Malcolm Wallace's \code{hi}. Rather than compiling the +user's code to an executable, we use \hsplugins{} to instead load an +object file and execute that instead, using the \code{eval} interface. +This cuts out the linking phase from the process, making turnaround at +the prompt around twice as fast as \code{hi}. + +\subsection*{Source of Plugs} + +\begin{quote} +\scm{ +import Eval.Haskell +import Plugins.Load + +import System.Exit ( ExitCode(..), exitWith ) +import System.IO +import System.Console.Readline ( readline, addHistory ) + +symbol = "resource" + +main = do + putStrLn banner + putStr "Loading package base" >> hFlush stdout + loadPackage "base" + putStr " ... linking ... " >> hFlush stdout + resolveObjs + putStrLn "done" + + shell [] + +shell :: [String] -> IO () +shell imps = do + s <- readline "plugs> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + imps' <- run cmd imps + shell imps' + +run :: String -> [String] -> IO [String] +run "" is = return is +run ":?" is = putStrLn help >> return is + +run ":l" _ = return [] +run (':':'l':' ':m) is = return (m:is) + +run (':':'t':' ':s) is = do + ty <- typeOf s is + when (not $ null ty) (putStrLn $ s ++ " :: " ++ ty) + return is + +run (':':_) is = putStrLn help >> return is + +run s is = do + s <- unsafeEval ("show $ "++s) is + when (isJust s) (putStrLn (fromJust s)) + return is + +banner = "\ +\ __ \n\ +\ ____ / /_ ______ ______ \n\ +\ / __ \\/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98\n\ +\ / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins\n\ +\ / .___/_/\\__,_/\\__, /____/ Type :? for help \n\ +\/_/ /____/ \n" + +help = "\ +\Commands :\n\ +\ evaluate expression\n\ +\ :t show type of expression (monomorphic only)\n\ +\ :l module bring module in to scope\n\ +\ :l clear module list\n\ +\ :quit quit\n\ +\ :? display this list of commands" +} +\end{quote} + +\subsection*{A Transcript} + +And a transcript: +% +\begin{quote} +\begin{verbatim} +$ ./plugs + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... done +plugs> 1 +1 +plugs> let x = 1 + 2 in x +3 +plugs> :l Data.List +plugs> case [1,3,2] of x -> sort x +[1,2,3] +plugs> reverse [1,3,2] +[2,3,1] +plugs> map (\x -> (x,2^x)) [1,2,3,4,5,6,7,8,9,10] +[(1,2),(2,4),(3,8),(4,16),(5,32),(6,64),(7,128),(8,256),(9,512),(10,1024)] +plugs> :t "haskell" +"haskell" :: [Char] +plugs> :quit +\end{verbatim} +\end{quote} + +\end{document} diff --git a/docs/munge.sed b/docs/munge.sed new file mode 100644 index 0000000..e9f5db2 --- /dev/null +++ b/docs/munge.sed @@ -0,0 +1,17 @@ +#!/usr/bin/sed -f + +# de-boldify and

-ify the Contents. + +/Contents/ { + :loop + /Go to/ { + b end + } + s,

,, + s,,, + s,,, + s,

,, + n + b loop +} +:end diff --git a/docs/tex2page.sty b/docs/tex2page.sty new file mode 100644 index 0000000..28bd5bb --- /dev/null +++ b/docs/tex2page.sty @@ -0,0 +1,9 @@ +% tex2page.sty +% Dorai Sitaram + +% Loading this file in a LaTeX document +% gives it all the macros of tex2page.tex, +% but via a more LaTeX-convenient filename. + +\input{tex2page} + diff --git a/docs/tex2page.tex b/docs/tex2page.tex new file mode 100644 index 0000000..e0bda16 --- /dev/null +++ b/docs/tex2page.tex @@ -0,0 +1,1381 @@ +% tex2page.tex +% Dorai Sitaram + +% TeX files using these macros +% can be converted by the program +% tex2page into HTML + +\message{version 2003-10-26} % last change + +\let\texonly\relax +\let\endtexonly\relax + +\texonly + +\newcount\evalQauxfilecount +\evalQauxfilecount=0 + +\def\eval{\begingroup + \ifx\evalfortexQport\UNDEFINED + \expandafter\csname newwrite\endcsname + \evalfortexQport + \immediate\openout\evalfortexQport + \jobname.eval4tex + \immediate\write\evalfortexQport + {\string\ifx\string\shipout\string\UNDEFINED + \string\eval{(eval-for-tex-only)}% + \string\else\string\endinput\string\fi}% + \fi + \global\advance\evalQauxfilecount by 1 + \edef\evalQauxfile{\jobname-Z-E-\the\evalQauxfilecount}% + {\immediate\openin0=\evalQauxfile.tex + \ifeof0 \immediate\closein0 + \else \input \evalQauxfile.tex \fi}% + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 + \newlinechar=`\^^M% + \evalQii} + +\def\evalQii#1{% + \immediate\write\evalfortexQport{\string\eval{#1}}% + \endgroup} + +%\def\verbwritefile#1 {\relax} +%\let\verbwrite\gobbleencl + +\def\verbwritefile{% + \ifx\verbwritefileQport\UNDEFINED + \expandafter\csname newwrite\endcsname\verbwritefileQport + \else\immediate\closeout\verbwritefileQport + \fi + \futurelet\verbwritefileQnext\verbwritefileQcheckchar} + +\def\verbwritefileQcheckchar{% + \ifx\verbwritefileQnext\bgroup + \let\verbwritefileQnext\verbwritefileQbracedfile + \else + \let\verbwritefileQnext\verbwritefileQspacedfile + \fi\verbwritefileQnext} + +\def\verbwritefileQspacedfile#1 {% + \immediate\openout\verbwritefileQport #1 +} + +\def\verbwritefileQbracedfile#1{% + \verbwritefileQspacedfile #1 +} + +\def\verbwrite{% + \ifx\verbwritefileQport\UNDEFINED + \verbwritefile \jobname.txt \fi + \begingroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 \newlinechar=`\^^M% + \futurelet\verbwriteQopeningchar\verbwriteQii} + +\def\verbwriteQii{\ifx\verbwriteQopeningchar\bgroup + \let\verbwriteQiii\verbwriteQbrace\else + \let\verbwriteQiii\verbwriteQnonbrace\fi + \verbwriteQiii} + +\def\verbwriteQbrace#1{\immediate + \write\verbwritefileQport{#1}\endgroup} + +\def\verbwriteQnonbrace#1{% + \catcode`\{12 \catcode`\}12 + \def\verbwriteQnonbraceQii##1#1{% + \immediate\write\verbwritefileQport{##1}\endgroup}% + \verbwriteQnonbraceQii} + +\ifx\loadonlyQevalfortex1% + \let\maybeloadfollowing\endinput +\else + \let\maybeloadfollowing\relax +\fi\maybeloadfollowing + +\ifx\slatexignorecurrentfile\UNDEFINED\relax\fi + +\edef\atcatcodebeforetiip{\the\catcode`\@ } +\catcode`\@11 + +% margins + +\def\sidemargin{\afterassignment\sidemarginQadjustoffset + \hoffset} + +\def\sidemarginQadjustoffset{% + \advance\hoffset -1true in + \advance\hsize -2\hoffset} + +\def\vertmargin{\afterassignment\vertmarginQadjustoffset + \voffset} + +\def\vertmarginQadjustoffset{% + \advance\voffset -1true in + \advance\vsize -2\voffset} + +% + +\def\defcsactive#1{\defnumactive{`#1}} + +\def\defnumactive#1{\catcode#1\active + \begingroup\lccode`\~#1% + \lowercase{\endgroup\def~}} + +% gobblegobblegobble + +\def\gobblegroup{\bgroup + \def\do##1{\catcode`##1=9 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \gobblegroupI} + +\def\gobblegroupI#1{\egroup} + +\def\gobbleencl{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \futurelet\gobbleenclnext\gobbleenclI} + +\def\gobbleenclI{\ifx\gobbleenclnext\bgroup + \let\gobbleenclnext\gobblegroupI + \else\let\gobbleenclnext\gobbleenclII\fi + \gobbleenclnext} + +\def\gobbleenclII#1{% + \def\gobbleenclIII##1#1{\egroup}% + \gobbleenclIII} + +% \verb +% Usage: \verb{...lines...} or \verb|...lines...| +% In the former case, | can be used as escape char within +% the verbatim text + +\let\verbhook\relax + +\def\verbfont{\tt} +%\hyphenchar\tentt-1 + +\def\verbsetup{\frenchspacing + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\|=12 % needed? + \verbfont + \edef\verbQoldhyphenchar{\the\hyphenchar\font}% + \hyphenchar\font-1 + \def\verbQendgroup{\hyphenchar\font\verbQoldhyphenchar\endgroup}% +} + +% The current font is cmtt iff fontdimen3 = 0 _and_ +% fontdimen7 != 0 + +\def\checkifusingcmtt{\let\usingcmtt n% + \ifdim\the\fontdimen3\the\font=0.0pt + \ifdim\the\fontdimen7\the\font=0.0pt + \else\let\usingcmtt y\fi\fi} + +% In a nonmonospaced font, - followed by a letter +% is a regular hyphen. Followed by anything else, it is a +% typewriter hyphen. + +\def\variablelengthhyphen{\futurelet\variablelengthhyphenI + \variablelengthhyphenII} + +\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI + a-\else{\tt\char`\-}\fi} + +\def\verbavoidligs{% avoid ligatures + \defcsactive\`{\relax\lq}% + \defcsactive\ {\leavevmode\ }% + \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% + \defcsactive\^^M{\leavevmode\endgraf}% + \checkifusingcmtt + \ifx\usingcmtt n% + \defcsactive\<{\relax\char`\<}% + \defcsactive\>{\relax\char`\>}% + \defcsactive\-{\variablelengthhyphen}% + \fi} + +\def\verbinsertskip{% + \let\firstpar y% + \defcsactive\^^M{\ifx\firstpar y% + \let\firstpar n% + \verbdisplayskip + \parskip 0pt + \aftergroup\verbdisplayskip + \else\leavevmode\fi\endgraf}% + \verbhook} + +\ifx\verb\UnDeFiNeD\else +% Save LaTeX's \verb away, because +% we'll be defining our own \verb +\let\LaTeXverb\verb +\fi + +%\def\verb{\begingroup +% \verbsetup\verbI} + +\def\verb{\begingroup + \verbsetup\verbavoidligs\verbQcheckstar} + +\def\verbQcheckstar{% + \futurelet\verbQcheckstarQnext\verbQcheckstarQii} + +\def\verbQcheckstarQii{% + \if\verbQcheckstarQnext*% + \let\verbQcheckstarQnext\verbQcheckstarQiii + \else + \let\verbQcheckstarQnext\verbI + \fi + \verbQcheckstarQnext} + +\def\verbQcheckstarQiii#1{% + \defcsactive\ {\relax\char`\ }% + \verbI} + +\def\verbc{\begingroup + \verbsetup\afterassignment\verbcI + \let\verbcII=} + +\def\verbcI{{\verbfont\verbcII}\endgroup} + +\let\E\verbc + +\newcount\verbbracebalancecount + +\def\verblbrace{\char`\{} +\def\verbrbrace{\char`\}} + +\def\verbescapechar#1{% + \def\escapifyverbescapechar{\catcode`#1=0 }} + +\verbescapechar\| + +{\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\gdef\verbI#1[%\verbavoidligs + \verbinsertskip\verbhook + %\edef\verbQoldhyphenchar{\the\hyphenchar\tentt}% + %\hyphenchar\tentt=-1 + %\def\verbQendgroup{\hyphenchar\tentt\verbQoldhyphenchar\endgroup}% + %\let\verbQendgroup\endgroup% + \if#1{\escapifyverbescapechar + \def\{[\char`\{]% + \def\}[\char`\}]% + \def\|[\char`\|]% + \verbbracebalancecount0 + \defcsactive\{[\advance\verbbracebalancecount by 1 + \verblbrace]% + \defcsactive\}[\ifnum\verbbracebalancecount=0 + \let\verbrbracenext\verbQendgroup\else + \advance\verbbracebalancecount by -1 + \let\verbrbracenext\verbrbrace\fi + \verbrbracenext]\else + \defcsactive#1[\verbQendgroup]\fi + \verbII +]] + +\def\verbII{\futurelet\verbIInext\verbIII} + +{\catcode`\^^M\active% +\gdef\verbIII{\ifx\verbIInext^^M\else% + \defcsactive\^^M{\leavevmode\ }\fi}} + +\let\verbdisplayskip\medbreak + +% \verbatiminput FILENAME +% displays contents of file FILENAME verbatim. + +%\def\verbatiminput#1 {{\verbsetup\verbavoidligs\verbhook +% \input #1 }} + +% ^ original \verbatiminput + +\ifx\verbatiminput\UNDEFINED +% LaTeX's (optional) verbatim package defines a \verbatiminput -- +% don't clobber it +\def\verbatiminput{% + \futurelet\verbatiminputQnext\verbatiminputQcheckchar}% +\fi + +\def\verbatiminputQcheckchar{% + \ifx\verbatiminputQnext\bgroup + \let\verbatiminputQnext\verbatiminputQbracedfile + \else + \let\verbatiminputQnext\verbatiminputQspacedfile + \fi\verbatiminputQnext} + +\def\verbatiminputQbracedfile#1{\verbatiminputQdoit{#1}} + +\def\verbatiminputQspacedfile#1 {\verbatiminputQdoit{#1}} + +\def\verbatiminputQdoit#1{{\verbsetup + \verbavoidligs\verbhook + \input #1 }} + + +% \url{URL} becomes +% URL in HTML, and +% URL in DVI. + +% A-VERY-VERY-LONG-URL in a .bib file +% could be split by BibTeX +% across a linebreak, with % before the newline. +% To accommodate this, %-followed-by-newline will +% be ignored in the URL argument of \url and related +% macros. + +\ifx\url\UnDeFiNeD +\def\url{\bgroup\urlsetup\let\dummy=}% +\fi + +\def\urlsetup{\verbsetup\urlfont\verbavoidligs + \catcode`\{1 \catcode`\}2 + \defcsactive\%{\urlpacifybibtex}% + \defcsactive\ {\relax}% + \defcsactive\^^M{\relax}% + \defcsactive\.{\discretionary{}{\char`\.}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \defcsactive\`{\relax\lq}} + +\let\urlfont\relax + +\def\urlpacifybibtex{\futurelet\urlpacifybibtexnext\urlpacifybibtexI} + +\def\urlpacifybibtexI{\ifx\urlpacifybibtexnext^^M% + \else\%\fi} + +% \mailto{ADDRESS} becomes +% ADDRESS in HTML, and +% ADDRESS in DVI. + +\let\mailto\url + +% \urlh{URL}{TEXT} becomes +% TEXT in HTML, and +% TEXT in DVI. + +% If TEXT contains \\, the part after \\ appears in +% the DVI only. If, further, this part contains \1, +% the latter is replaced by a fixed-width representation +% of URL. + +\def\urlh{\bgroup\urlsetup + \afterassignment\urlhI + \gdef\urlhQurlarg} + +\def\urlhI{\egroup + \bgroup + \let\\\relax + \def\1{{\urlsetup\urlhQurlarg}}% + \let\dummy=} + +\def\urlp#1{{#1} \bgroup\urlsetup + \afterassignment\urlpQwrapparens + \gdef\urlpQurlarg} + +\def\urlpQwrapparens{\egroup + {\rm(}{\urlsetup\urlpQurlarg}{\rm)}} + +% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes +% HTML-TEXT in HTML, and +% DVI-TEXT in DVI + +\def\urlhd{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 + \urlhdQeaturlhtmlargs} + +\def\urlhdQeaturlhtmlargs#1#2{\egroup} + +\ifx\hyperref\UnDeFiNeD +\let\href\urlh +\let\hypertarget\gobblegroup +\let\hyperlink\gobblegroup +\def\hyperref#1#2#3#4{#2\ref{#4}#3} +\fi + +% + +\let\ignorenextinputtimestamp\relax + +% don't let caps disable end-of-sentence spacing + +\def\nocapdot{% +\count255=`\A +\loop +\sfcode\the\count255=1000 +\ifnum\count255<`\Z +\advance\count255 by 1 +\repeat +} + +% + +%\ifx\newenvironment\UnDeFiNeD +\let\htmlonly\iffalse +\let\endhtmlonly\fi +%\else +%\usepackage{comment} +%\excludecomment{htmlonly} +%\fi + +\def\rawhtml{\errmessage{Can't occur outside + \string\htmlonly}} +\def\endrawhtml{\errmessage{Can't occur outside + \string\htmlonly}} + +\let\htmlheadonly\iffalse +\let\endhtmlheadonly\fi + +\let\cssblock\iffalse +\let\endcssblock\fi + +\def\inputcss#1 {\relax} +\let\htmlstylesheet\inputcss +\let\htmladdimg\gobblegroup + +\def\htmlref{\bgroup\aftergroup\gobblegroup\let\dummy=} + +% + +\let\htmlcolophon\gobblegroup +\let\htmlmathstyle\gobblegroup +\let\htmladvancedentities\relax + +% Scheme + +\let\scm\verb +\let\scminput\verbatiminput + +\let\scmwritefile\verbwritefile +\let\scmwrite\verbwrite +\let\scmdribble\scm + +\ifx\slatexversion\UNDEFINED +% SLaTeX compat +\let\scmkeyword\gobblegroup +\let\scmbuiltin\gobblegroup +\let\scmconstant\scmbuiltin +\let\scmvariable\scmbuiltin +\let\setbuiltin\scmbuiltin +\let\setconstant\scmbuiltin +\let\setkeyword\scmkeyword +\let\setvariable\scmvariable +\def\schemedisplay{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemedisplayI}% +\def\schemeresponse{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemeresponseI}% +{\catcode`\|0 |catcode`|\12 + |long|gdef|schemedisplayI#1\endschemedisplay{% + #1|endgroup}% + |long|gdef|schemeresponseI#1\endschemeresponse{% + #1|endgroup}}% +\fi + +\let\slatexlikecomments\relax +\let\noslatexlikecomments\relax + +% definitions (useful in reference manuals) + +\ifx\@@line\UnDeFiNeD +\let\@@line\line +\fi + +\def\defun#1{\def\defuntype{#1}% +\medbreak +\@@line\bgroup + \hbox\bgroup + \aftergroup\enddefun + \vrule width .5ex \thinspace + \vrule \enspace + \vbox\bgroup\setbox0=\hbox{\defuntype}% + \advance\hsize-\wd0 + \advance\hsize-1em + \obeylines + \parindent=0pt + \aftergroup\egroup + \strut + \let\dummy=} + +\def\enddefun{\hfil\defuntype\egroup\smallskip} + + +% Images + +\let\imgdef\def + +%\def\imgpreamble{\let\magnificationoutsideimgpreamble\magnification +% \def\magnification{\count255=}} +% +%\def\endimgpreamble{\let\magnification\magnificationoutsideimgpreamble} + + +\let\imgpreamble\iffalse +\let\endimgpreamble\fi + +\let\makehtmlimage\relax + + +% Tally control sequences are cheap count +% registers: they doesn't use up TeX's limited number of +% real count registers. + +% A tally is a macro that expands to the +% number kept track of. Thus \edef\kount{0} defines a +% tally \kount that currently contains 0. + +% \advancetally\kount n increments \kount by n. +% \globaladvancetally increments the global \kount. +% If \kount is not defined, the \[global]advancetally +% macros define it to be 0 before proceeding with the +% incrementation. + +\def\newtally#1{\edef#1{0}} + +\def\advancetallyhelper#1#2#3{% + \ifx#2\UNDEFINED + #1\edef#2{0}\fi + \edef\setcountCCLV{\count255=#2 }% + \setcountCCLV + \advance\count255 by #3 + #1\edef#2{\the\count255 }} + +\def\advancetally{\advancetallyhelper\relax} +\def\globaladvancetally{\advancetallyhelper\global} + +% plain's \beginsection splits pages too easily + +%\def\beginsection#1\par{\sectionhelp{1}{}{#1}} + +\def\beginsection{\vskip-\lastskip + \bigbreak\noindent + \bgroup\bf + \let\par\sectionafterskip} + +\def\beginsectionstar*{\beginsection} + +% plain's \{left,center,right}line can't handle catcode change +% within their argument + +\def\leftline{\@@line\bgroup\bgroup + \aftergroup\leftlinefinish + \let\dummy=} + +\def\leftlinefinish{\hss\egroup} + +\def\centerline{\@@line\bgroup\bgroup + \aftergroup\leftlinefinish + \hss\let\dummy=} + +\def\rightline{\@@line\bgroup\hss\let\dummy=} + +% + +\let\strike\fiverm % can be much better! + +% + +\let\htmlpagebreak\relax + +\let\htmlpagelabel\gobblegroup + +\def\htmlpageref{\errmessage{Can't occur except inside + \string\htmlonly}} + +% Miscellaneous stuff + +%\def\hr{$$\hbox{---}$$} +\def\hr{\medbreak\centerline{---}\medbreak} +%\def\hr{\par\centerline{$*$}\par} +%\def\hr{\smallskip\@@line{\leaders\hbox{~.~}\hfill}\smallskip} + +%Commonplace math that doesn't require image files. (Avoiding $ +%here because $ triggers image-file generation.) + +\let\nohtmlmathimg\relax +\let\nohtmlmathintextimg\relax +\let\nohtmlmathdisplayimg\relax + +\let\htmlimageformat\gobblegroup +\let\htmlimgmagnification\gobblegroup + +\let\externaltitle\gobblegroup + +\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} +\def\closemathg{$} + +\let\mathp\mathg + +\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} +\def\closemathdg{$$} + +% + + +\let\evalh\gobblegroup +\let\evalq\gobblegroup + +% Backward compatible stuff + +\let\endgifpreamble\endimgpreamble +\let\endhtmlgif\relax +\let\endhtmlimg\relax +\let\gifdef\imgdef +\let\gifpreamble\imgpreamble +%\let\href\urlh +\let\htmlgif\relax +\let\htmlimg\relax +\let\htmlimgformat\htmlimageformat +\let\n\noindent +\let\p\verb +\let\q\scm +\let\schemeeval\eval +\let\scmfile\scmdribble +\let\scmfileonly\scmwrite +\let\scmp\scm +%\let\scmverbatim\scm +\let\scmverbatimfile\scminput +\let\setverbatimescapechar\verbescapechar +%\let\verbatim\verb +\let\verbatimfile\verbatiminput +\let\verbinput\verbatiminput +\let\verbfilename\verbwritefile +\let\scmfilename\scmwritefile + +% uppercase version of \romannumeral + +\def\Romannumeral{\afterassignment\RomannumeralI\count255=} + +\def\RomannumeralI{\uppercase\expandafter{\romannumeral\the\count255 }} + +\def\f{\footnote} + +\ifx\label\UnDeFiNeD +\else +\def\tag#1#2{\@bsphack + \protected@write\@auxout{}% + {\string\newlabel{#1}{{#2}{\thepage}}}% +\@esphack}% +\let\tagref\ref +\fi + +\def\inputexternallabels#1 {\relax} +\def\includeexternallabels#1 {\relax} + +% The rest of the file isn't needed for LaTeX + +\ifx\section\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\catcode`\@\atcatcodebeforetiip +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +% LaTeX stops loading here! + +% Title + +\newwrite\sectionscratchfileport + +\def\subject{% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \subjectI} + +\def\subjectI#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + $$\vbox{\bf \def\\{\cr}% + \halign{\hfil##\hfil\cr + \input Z-sec-temp + \cr}}$$% + \medskip} + +\let\title\subject + +% Sections + +\def\tracksectionchangeatlevel#1{% + \expandafter\let\expandafter\thiscount\csname + sectionnumber#1\endcsname + \ifx\thiscount\relax + \expandafter\edef\csname sectionnumber#1\endcsname{0}% + \fi + \expandafter\advancetally + \csname sectionnumber#1\endcsname 1% + \ifx\doingappendix0% + \edef\recentlabel{\csname sectionnumber1\endcsname}% + \else + %\count255=\expandafter\csname sectionnumber1\endcsname + \edef\recentlabel{\char\csname sectionnumber1\endcsname}% + \fi + \count255=0 + \loop + \advance\count255 by 1 + \ifnum\count255=1 + \else\edef\recentlabel{\recentlabel.\csname + sectionnumber\the\count255\endcsname}\fi + \ifnum\count255<#1% + \repeat + \loop + \advance\count255 by 1 + \expandafter\let\expandafter\nextcount\csname + sectionnumber\the\count255\endcsname + \ifx\nextcount\relax + \let\continue0% + \else + \expandafter\edef\csname + sectionnumber\the\count255\endcsname{0}% + \let\continue1\fi + \ifx\continue1% + \repeat} + +% Vanilla section-header look -- change this macro for new look + +\newcount\secnumdepth + +\secnumdepth=10 + +\def\sectiond#1{\count255=#1% + \ifx\usingchapters1\advance\count255 by 1 \fi + \edef\sectiondlvl{\the\count255 }% + \futurelet\sectionnextchar\sectiondispatch} + +\def\sectiondispatch{\ifx\sectionnextchar*% + \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else + \ifnum\sectiondlvl>\secnumdepth + \def\sectioncontinue{\sectionhelp{\sectiondlvl}{}}\else + \tracksectionchangeatlevel{\sectiondlvl} + \def\sectioncontinue{\sectionhelp{\sectiondlvl}% + {\recentlabel\enspace}}\fi\fi + \sectioncontinue} + +\def\sectionstar#1*{\sectionhelp{#1}{}} + + +\def\sectionhelp#1#2{% + \edef\sectiondepth{#1}% + \def\sectionnr{#2}% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}= 2 + \sectionheader} + +\def\sectionheader#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + \vskip -\lastskip + \ifnum\sectiondepth>\tocdepth\else + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout + {\string\tocentry{\sectiondepth}{\sectionnr}{#1}{\folio}}}% + \temp}\fi + \vskip1.5\bigskipamount +\goodbreak %??? + \noindent + \hbox{\vtop{\pretolerance 10000 + \raggedright + \noindent\bf\sectionnr + \input Z-sec-temp }}% + \bgroup\let\par\sectionafterskip} + +% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% +% \string\vtop{\string\hsize=.7\string\hsize +% \string\noindent\string\raggedright\space #3}\string\par}}\temp + +\def\sectionafterskip{\egroup\nobreak\par\noindent} + +\def\section{\sectiond1} +\def\subsection{\sectiond2} +\def\subsubsection{\sectiond3} +\def\paragraph{\sectiond4} +\def\subparagraph{\sectiond5} + +\let\usingchapters0 + +\def\chapter{\global\let\usingchapters1% +\futurelet\chapternextchar\chapterdispatch} + +\def\chapterdispatch{\ifx\chapternextchar*% + \let\chaptercontinue\chapterstar\else + \tracksectionchangeatlevel{1}% + \def\chaptercontinue{\chapterhelp{\recentlabel\enspace}}\fi + \chaptercontinue} + +\def\chapterstar*{\chapterhelp{}} + +\def\chapterhelp#1{% + % #1=number #2=heading-text + \def\chapternr{#1}% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \chapterheader} + +\def\chapterheader#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{1}{\chapternr}{#1}{\folio}}}% + \temp}% + \vfill\eject + \null\vskip3em + \noindent + \ifx\chapternr\empty\hbox{~}\else + \ifx\doingappendix0% + \hbox{\bf Chapter \chapternr}\else + \hbox{\bf Appendix \chapternr}\fi\fi + \vskip 1em + \noindent + \hbox{\bf\vtop{%\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright\input Z-sec-temp }}% + \bgroup\let\par\chapterafterskip} + +\def\chapterafterskip{\egroup\nobreak\vskip3em \noindent} + +\let\doingappendix=0 + +\def\appendix{\let\doingappendix=1% + \count255=`\A% + \advance\count255 by -1 + \expandafter\edef\csname + sectionnumber1\endcsname{\the\count255 }} + + +% toc + +\let\tocactive0 + +\newcount\tocdepth + +\tocdepth=10 + +\def\tocoutensure{\ifx\tocout\UNDEFINED + \csname newwrite\endcsname\tocout\fi} + +\def\tocactivate{\ifx\tocactive0% + \tocoutensure + \tocsave + \openout\tocout \jobname.toc + \global\let\tocactive1\fi} + +\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} + +\def\tocsave{\openin0=\jobname.toc + \ifeof0 \closein0 \else + \openout\tocout Z-T-\jobname.tex + \let\tocsaved 0% + \loop + \ifeof0 \closeout\tocout + \let\tocsaved1% + \else{\tocspecials + \read0 to \tocsaveline + \edef\temp{\write\tocout{\tocsaveline}}\temp}% + \fi + \ifx\tocsaved0% + \repeat + \fi + \closein0 } + +\def\tocentry#1#2{% + %#1=depth #2=secnum + \ifnum#1=1 + \ifnum\tocdepth>2 + \medbreak\begingroup\bf + \else\begingroup\fi + \else\begingroup\fi + \vtop\bgroup\raggedright + \noindent\hskip #1 em + #2% + \bgroup + \aftergroup\tocentryI + %read section title + \let\dummy=} + +\def\tocentryI#1{% + %#1=page nr + , #1\strut\egroup + \endgroup\par +} + +\def\tableofcontents{% + \ifx\tocactive0% + \openin0 \jobname.toc + \ifeof0 \closein0 \else + \closein0 \input \jobname.toc + \fi + \tocoutensure + \openout\tocout \jobname.toc + \global\let\tocactive1% + \else + \input Z-T-\jobname.tex + \fi} + +% allow {thebibliography} to be used directly +% in (plain-TeX) source document without +% generating it via BibTeX + +\ifx\thebibliography\UnDeFiNeD +\def\thebibliography#1{\vskip-\lastskip + \begingroup + \def\endthebibliography{\endgroup\endgroup}% + \def\input##1 ##2{\relax}% + \setbox0=\hbox{\biblabelcontents{#1}}% + \biblabelwidth=\wd0 + \@readbblfile}% +\fi + +% Cross-references + +% \openxrefout loads all the TAG-VALUE associations in +% \jobname.xrf and then opens \jobname.xrf as an +% output channel that \tag can use + +\def\openxrefout{% + \openin0=\jobname.xrf + \ifeof0 \closein0 + \else \closein0 {\catcode`\\0 \input \jobname.xrf }% + \fi + \expandafter\csname newwrite\endcsname\xrefout + \openout\xrefout=\jobname.xrf +} + +% I'd like to call \openxrefout lazily, but +% unfortunately it produces a bug in MiKTeX. +% So let's call it up front. + +\openxrefout + +% \tag{TAG}{VALUE} associates TAG with VALUE. +% Hereafter, \ref{TAG} will output VALUE. +% \tag stores its associations in \xrefout. +% \tag calls \openxrefout if \jobname.xrf hasn't +% already been opened + +\def\tag#1#2{\ifx\xrefout\UNDEFINED\openxrefout\fi + {\let\folio0% + \edef\temp{% + \write\xrefout{\string\expandafter\string\gdef + \string\csname\space XREF#1\string\endcsname + {#2}\string\relax}}% + \temp}} + +% \tagref{TAG} outputs VALUE, assuming \tag put such +% an association into \xrefout. \tagref calls +% \openxrefout if \jobname.xrf hasn't already +% been opened + +% Later, we will \let \ref = \tagref after making +% sure we aren't in eplain, which uses the ctlseq +% \ref differently + +\def\tagref#1{\ifx\xrefout\UNDEFINED\openxrefout\fi + \expandafter\ifx\csname XREF#1\endcsname\relax + %\message or \write16 ? + \message{\the\inputlineno: Unresolved label `#1'.}?\else + \csname XREF#1\endcsname\fi} + +% \label, as in LaTeX + +\let\recentlabel\relax + +% The sectioning commands +% define \recentlabel so a subsequent call to \label will pick up the +% right label. + +\def\label#1{\tag{#1}{\recentlabel}% + \tag{PAGE#1}{\folio}} + +% \pageref, as in LaTeX + +\def\pageref#1{\ref{PAGE#1}} + +% eplain users see the \ref they are used to. Others +% have \ref = \tagref + +\ifx\eplain\UnDeFiNeD +\let\ref\tagref +\fi + +% + +\ifx\IfFileExists\UnDeFiNeD +\def\IfFileExists#1#2#3{% + \openin0 #1 % + \ifeof0 % + #3% + \else + #2\fi + \closein0 }% +\fi + +\ifx\InputIfFileExists\UnDeFiNeD +\def\InputIfFileExists#1#2#3{% + \IfFileExists{#1}{#2\input #1 }{#3}}% +\fi + +\let\iffileexists\IfFileExists + +% + +% dummy def to let load dvipsnam.def + +\ifx\ProvidesFile\UnDeFiNeD +\def\ProvidesFile#1[#2]{}% +\fi + +% + +% Index generation +% +% Your TeX source contains \index{NAME} to +% signal that NAME should be included in the index. +% Check the makeindex documentation to see the various +% ways NAME can be specified, eg, for subitems, for +% explicitly specifying the alphabetization for a name +% involving TeX control sequences, etc. +% +% The first run of TeX will create \jobname.idx. +% makeindex on \jobname[.idx] will create the sorted +% index \jobname.ind. +% +% Use \inputindex (without arguments) to include this +% sorted index, typically somewhere to the end of your +% document. This will produce the items and subitems. +% It won't produce a section heading however -- you +% will have to typeset one yourself. +% +% Use \printindex instead of \inputindex if you want +% the section heading ``Index'' automatically generated. + +\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% + \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% + \do\@\do\"\do\!\do\|\do\-\do\ \do\'} + +\def\index{%\unskip + \ifx\indexout\UNDEFINED + \csname newwrite\endcsname\indexout + \openout\indexout \jobname.idx\fi + \begingroup + \sanitizeidxletters + \indexI} + +\def\indexI#1{\endgroup + \write\indexout{\string\indexentry{#1}{\folio}}% + \ignorespaces} + +% The following index style indents subitems on a +% separate lines + +\def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\indexitem##1{\par\hangindent30pt \hangafter1 + \hskip ##1 }% + \def\item{\indexitem{0em}}% + \def\subitem{\indexitem{2em}}% + \def\subsubitem{\indexitem{4em}}% + \def\see{{\it see} \bgroup\aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip} + +\def\endtheindex{\endgroup} + +% \packindex declares that subitems be bundled into one +% semicolon-separated paragraph + +\def\packindex{% + \def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\item{\par\hangindent20pt \hangafter1 }% + \def\subitem{\unskip; }% + \def\subsubitem{\unskip; }% + \def\see{\bgroup\it see \aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip}} + +\def\inputindex{% + \openin0 \jobname.ind + \ifeof0 \closein0 + \message{\jobname.ind missing.}% + \else\closein0 + \begingroup + \def\begin##1{\csname##1\endcsname}% + \def\end##1{\csname end##1\endcsname}% + \input\jobname.ind + \endgroup\fi} + +\def\printindex{\csname beginsection\endcsname Index\par + \inputindex} + +% + +\def\italiccorrection{\futurelet\italiccorrectionI + \italiccorrectionII} + +\def\italiccorrectionII{% + \if\noexpand\italiccorrectionI,\else + \if\noexpand\italiccorrectionI.\else + \/\fi\fi} + +\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} + +%\def\emph{\bgroup\it +% \ifmmode\else\aftergroup\italiccorrection\fi +% \let\dummy=} + +\def\quote{\bgroup\narrower\smallbreak} +\def\endquote{\smallbreak\egroup} + +\def\begin#1{\begingroup + \def\end##1{\csname end#1\endcsname\endgroup}% + \csname #1\endcsname} + +\def\raggedleft{% + \leftskip 0pt plus 1fil + \parfillskip 0pt +} + +\def\r#1{{\accent23 #1}} + + +\ifx\strip@pt\UNDEFINED +\begingroup + \catcode`P 12 \catcode`T 12 + \lowercase{\endgroup + \gdef\strip@pt#1PT{#1}}% +\fi + +% color + +\ifx\color\UnDeFiNeD +% +\ifx\pdfoutput\UnDeFiNeD % PostScript +% +\def\colorCurrentColor{color cmyk 0 0 0 1}% +% +\def\colorRestoreCurrentColor{% +\special{\colorCurrentColor}\egroup\egroup}% +% +\def\colorWithModelrgb#1{\bgroup +\def\colorCurrentColor{color rgb #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelRGBaux#1 #2 #3\end{\bgroup +\dimen0=#1pt \divide\dimen0 by 255 +\edef\red{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#2pt \divide\dimen0 by 255 +\edef\green{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#3pt \divide\dimen0 by 255 +\edef\blue{\expandafter\strip@pt\the\dimen0 }% +\def\colorCurrentColor{color rgb \red\space \green\space \blue}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces} +% +\def\colorWithModelcmyk#1{\bgroup +\def\colorCurrentColor{color cmyk #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelgray#1{\bgroup +\def\colorCurrentColor{color gray #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelnamed#1{\bgroup +\edef\colorCurrentColor{\csname +ColorNamed#1\endcsname}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\definecolorWithModelrgb#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color rgb #2}}% +% +\def\definecolorWithModelcmyk#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color cmyk #2}}% +% +\def\definecolorWithModelgray#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color gray #2}}% +% +\else % PDF +% +\def\colorCurrentColor{0 0 0 1 k}% +% +\def\colorRestoreCurrentColor{% +\pdfliteral{\colorCurrentColor}\egroup\egroup}% +% +\def\colorWithModelrgb#1{\bgroup +\def\colorCurrentColor{#1 rg}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelRGBaux#1 #2 #3\end{\bgroup +\dimen0=#1pt \divide\dimen0 by 255 +\edef\red{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#2pt \divide\dimen0 by 255 +\edef\green{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#3pt \divide\dimen0 by 255 +\edef\blue{\expandafter\strip@pt\the\dimen0 }% +\def\colorCurrentColor{\red\space \green\space \blue\space rg}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces} +% +\def\colorWithModelcmyk#1{\bgroup +\def\colorCurrentColor{#1 k}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelgray#1{\bgroup +\def\colorCurrentColor{#1 g}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelnamed#1{\bgroup +\edef\colorCurrentColor{\csname +ColorNamed#1\endcsname}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\definecolorWithModelrgb#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 rg}}% +% +\def\definecolorWithModelcmyk#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 k}}% +% +\def\definecolorWithModelgray#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 g}}% +% +\fi +% +\def\color{\futurelet\colorQpeekchar\colorQpossiblynamed}% +% +\def\colorQpossiblynamed{\bgroup +\defcsactive\,{ }% +\if\colorQpeekchar[% +\let\colorQproceed\colorQexplicitmodel\else +\let\colorQproceed\colorWithModelnamed\fi +\colorQproceed}% +% +\def\colorQexplicitmodel[#1]{% +\csname colorWithModel#1\endcsname}% +% +\def\colorWithModelRGB#1{% +\colorWithModelRGBaux#1\end}% +% +\def\definecolor#1#2{\bgroup +\defcsactive\,{ }% +\csname definecolorWithModel#2\endcsname{#1}}% +% +% foll lets load texmf/tex/latex/graphics/dvipsnam.def +\def\DefineNamedColor#1{\definecolor}% +% +% these colors are standard in latex +\definecolor{red}{rgb}{1 0 0}% +\definecolor{green}{rgb}{0 1 0}% +\definecolor{blue}{rgb}{0 1 1}% +\definecolor{cyan}{cmyk}{1 0 0 0}% +\definecolor{magenta}{cmyk}{0 1 0 0}% +\definecolor{yellow}{cmyk}{0 0 1 0}% +\definecolor{black}{cmyk}{0 0 0 1}% +\definecolor{white}{rgb}{1 1 1}% +% +\fi + +%the rest of the file isn't needed for eplain? + +\def\itemize{\par\begingroup + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \llap{$\bullet$\enspace}\ignorespaces}} + +\def\enditemize{\smallbreak\smallbreak\endgroup\par} + +\newtally\enumeratelevel + +\def\enumerate{\par\begingroup + \advancetally\enumeratelevel1% + \newtally\enumeratenumber + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \advancetally\enumeratenumber1% + \ifnum\enumeratelevel=1 + \edef\enumeratemark{\enumeratenumber}\else + \ifnum\enumeratelevel=2 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `a + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \ifnum\enumeratelevel=3 + \edef\enumeratemark{\romannumeral\enumeratenumber}\else + \ifnum\enumeratelevel=4 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `A + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \edef\enumeratemark{\enumeratenumber}\fi\fi\fi\fi + \edef\recentlabel{\enumeratemark}% needed? + \llap{\enumeratemark.\enspace}\ignorespaces}} + +\def\endenumerate{\smallbreak\smallbreak\endgroup\par} + +% Numbered footnotes + +\ifx\plainfootnote\UNDEFINED + \let\plainfootnote\footnote +\fi + +\newtally\footnotenumber + +\def\numfootnote{\globaladvancetally\footnotenumber 1% + \bgroup\csname footnotehook\endcsname + \plainfootnote{$^{\footnotenumber}$}\bgroup + \edef\recentlabel{\footnotenumber}% + \aftergroup\egroup + \let\dummy=} + +\let\f\numfootnote + +\ifx\frac\UnDeFiNeD +\def\frac#1/#2{{#1\over#2}}% +\fi + +% \path is like \verb except that its argument +% can break across lines at `.' and `/'. + +\ifx\path\UnDeFiNeD +\def\path{\begingroup\verbsetup + \pathfont + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \verbI}% +\fi + +\let\pathfont\relax + +\catcode`\@\atcatcodebeforetiip + +\endtexonly + +% end of file diff --git a/examples/README b/examples/README new file mode 100644 index 0000000..9cc6548 --- /dev/null +++ b/examples/README @@ -0,0 +1,17 @@ +These examples illustrate the various uses of hs-plugins. + +conf a configuration file edsl using plugins +dynload dynamically typed load +eval runtime evaluation of haskell strings, from Haskell and C +hmake the 'plugs' haskell interpreter +iface test the interface file parser +load load a plugin +make build a Haskell file +makewith merge and build a Haskell file +multi load multiple plugins at once +objc load Haskell plugins into object C programs +pkgconf test package.conf parsing +popen test popen +reload reload a plugin when it changes +shell a simple string filter +unload test unloading of plugins diff --git a/examples/TIMINGS b/examples/TIMINGS new file mode 100644 index 0000000..531a2b5 --- /dev/null +++ b/examples/TIMINGS @@ -0,0 +1,45 @@ +Method: + * "pdynload" + comes from pdynload/small + * "load + ghc" + comes from pdynload/null, with lines 13-14 + uncommented from prog/Main.hs + * "dynload" + from dynload/simple + * "load, no check" + from pdynload/null, with lines 13-14 of prog/Main.hs + commented out + +For example, to run the "pdynload" test: + $ cd pdynload/small + $ make + $ make check # to prime caches, etc. + $ time make check + $ time make check + $ time make check # run 'time make check' until value converges + +The converged value is entered into the "Raw" timings, and then the +scaled timing is calculated for each machine. These scaled values were +then averaged over the number of machines, yielding the final +"Average" scores -- the average over a number of machines and os. + +Raw timing: +pdynload load+ghc dynload load, no check + +0.33 0.25 0.22 0.21 -- P4 2.6 , OpenBSD +0.38 0.31 0.29 0.27 -- P4 2.66, Linux +0.84 0.77 0.64 0.55 -- Quad P4 2.4, Linux +0.76 0.60 0.52 0.50 -- AMD 1.1G, Linux +0.95 0.83 0.75 0.72 -- G5 2.0G, Mac OS X + -- Quad Itanium 1,Linux + +Scaled: +1.57 1.19 1.05 1 +1.40 1.15 1.07 +1.52 1.4 1.16 +1.52 1.2 1.04 +1.32 1.15 1.04 + +Average: +=1.46 = 1.218 = 1.07 + diff --git a/examples/build.mk b/examples/build.mk new file mode 100644 index 0000000..d503cd0 --- /dev/null +++ b/examples/build.mk @@ -0,0 +1,41 @@ +# how to build the default projects + +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + +BIN= prog/a.out +OBJ= prog/Main.o +SRC= prog/Main.hs + +BINDIR= prog +REALBIN= ./a.out + +API_OBJ= api/API.o + +INCLUDES= -i$(TOP)/examples/$(TEST)/api +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package plugins +GHCFLAGS= -Onot -cpp -fglasgow-exts + +.SUFFIXES : .o .hs .hi .lhs .hc .s + +all: $(BIN) + +$(BIN) : $(PRIOR_OBJS) $(API_OBJ) $(SRC) $(EXTRA_OBJS) + @rm -f $@ + @$(GHC) --make -o $@ $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) $(API) $(SRC) + +# Standard suffix rules +.o.hi: + @: +.hs.o: + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) -c $< + +clean: + find . -name '*~' -exec rm {} \; + rm -rf *.{o,hi,dep} + rm -rf */*.{hi,o,old} */a.out + rm -rf */*core + rm -rf */*.a + rm -rf */package.conf + rm -rf *.a + diff --git a/examples/check.mk b/examples/check.mk new file mode 100644 index 0000000..b07d859 --- /dev/null +++ b/examples/check.mk @@ -0,0 +1,24 @@ +include $(TOP)/config.mk + +check: $(BIN) + @(cd $(BINDIR) ;\ + expected="expected" ;\ + if [ -f "expected" -o -f "expected.$(GLASGOW_HASKELL)" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + $(REALBIN) > $$actual_out 2>&1 || true ;\ + if [ -f "expected.$(GLASGOW_HASKELL)" ] ; then \ + expected="expected.$(GLASGOW_HASKELL)" ;\ + fi ;\ + diff -u $$expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out $$diff_out ;\ + else \ + $(REALBIN) 2>&1 || true ;\ + fi) diff --git a/examples/conf/simple/Mailrc.conf b/examples/conf/simple/Mailrc.conf new file mode 100644 index 0000000..449cfab --- /dev/null +++ b/examples/conf/simple/Mailrc.conf @@ -0,0 +1,11 @@ +import System.Directory + +resource = mail { +-- editor = do b <- doesFileExist "/usr/bin/emacs" +-- return $ if b then "emacs" else "vi" , + editor = do b <- doesFileExist "/bin/sh" + return "sh", + + attribution = \name -> "Today, "++name++" wrote :" +} + diff --git a/examples/conf/simple/Mailrc.stub b/examples/conf/simple/Mailrc.stub new file mode 100644 index 0000000..21a2128 --- /dev/null +++ b/examples/conf/simple/Mailrc.stub @@ -0,0 +1,28 @@ +module Mailrc ( resource ) where + +import API + +resource :: Interface +resource = mail + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/conf/simple/Makefile b/examples/conf/simple/Makefile new file mode 100644 index 0000000..c7f9b01 --- /dev/null +++ b/examples/conf/simple/Makefile @@ -0,0 +1,4 @@ +TEST= conf/simple + +TOP=../../.. +include ../../build.mk diff --git a/examples/conf/simple/api/API.hs b/examples/conf/simple/api/API.hs new file mode 100644 index 0000000..345bf2a --- /dev/null +++ b/examples/conf/simple/api/API.hs @@ -0,0 +1,27 @@ +-- +-- the configuration file interface. +-- + +module API where + +data Color = Black | Grey | Green | Cyan | Yellow | Magenta | Red + +data Interface = Interface { + editor :: IO String, + attribution :: String -> String, + header_color :: Color, + colorize :: [String], + include :: Bool + } + +-- Default settings +mail :: Interface +mail = Interface { + editor = return "vi", + + attribution = (\user -> user ++ " wrote:"), + header_color = Grey, + colorize = [], + include = True + } + diff --git a/examples/conf/simple/prog/Main.hs b/examples/conf/simple/prog/Main.hs new file mode 100644 index 0000000..7c4fca0 --- /dev/null +++ b/examples/conf/simple/prog/Main.hs @@ -0,0 +1,22 @@ + +import Plugins +import API + +conf = "../Mailrc.conf" +stub = "../Mailrc.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + status <- load o [apipath] [] "resource" + v <- case status of + LoadFailure err -> mapM_ putStrLn err >> error "no" + LoadSuccess _ v -> return v + + user_editor <- editor v + putStrLn user_editor + makeCleaner o + diff --git a/examples/conf/simple/prog/expected b/examples/conf/simple/prog/expected new file mode 100644 index 0000000..b001cf7 --- /dev/null +++ b/examples/conf/simple/prog/expected @@ -0,0 +1 @@ +sh diff --git a/examples/dynload/io/Makefile b/examples/dynload/io/Makefile new file mode 100644 index 0000000..3cf85e7 --- /dev/null +++ b/examples/dynload/io/Makefile @@ -0,0 +1,6 @@ +TEST=dynload/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/io/TestIO.hs b/examples/dynload/io/TestIO.hs new file mode 100644 index 0000000..979e2d2 --- /dev/null +++ b/examples/dynload/io/TestIO.hs @@ -0,0 +1,86 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +module TestIO ( resource_dyn ) where + +import API +import AltData + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + +resource :: TestIO +resource = testio { field = date } + + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/dynload/io/api/API.hs b/examples/dynload/io/api/API.hs new file mode 100644 index 0000000..6e9bdbd --- /dev/null +++ b/examples/dynload/io/api/API.hs @@ -0,0 +1,19 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data TestIO = TestIO { + field :: IO String + } + +instance Typeable TestIO where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.TestIO") [] +#else + typeOf i = mkAppTy (mkTyCon "API.TestIO") [] +#endif + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/dynload/io/prog/Main.hs b/examples/dynload/io/prog/Main.hs new file mode 100644 index 0000000..7c8a70c --- /dev/null +++ b/examples/dynload/io/prog/Main.hs @@ -0,0 +1,12 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../TestIO.o" ["../api"] + ["../../../../plugins.conf.inplace"] "resource_dyn" + case m_v of + LoadFailure _ -> error "couldn't compile" + LoadSuccess _ v -> do + s <- field v + if s /= [] then print True else print False diff --git a/examples/dynload/io/prog/expected b/examples/dynload/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/dynload/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/dynload/poly/Makefile b/examples/dynload/poly/Makefile new file mode 100644 index 0000000..e06d6e6 --- /dev/null +++ b/examples/dynload/poly/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/poly +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/poly/Plugin.hs b/examples/dynload/poly/Plugin.hs new file mode 100644 index 0000000..bf99cde --- /dev/null +++ b/examples/dynload/poly/Plugin.hs @@ -0,0 +1,12 @@ +module Plugin where + +import API +import AltData + +my_fun = plugin { + equals = \x y -> (x /= y) -- a strange equals function :) + } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/examples/dynload/poly/api/API.hs b/examples/dynload/poly/api/API.hs new file mode 100644 index 0000000..0181ef3 --- /dev/null +++ b/examples/dynload/poly/api/API.hs @@ -0,0 +1,24 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData + +data Interface = Interface { + equals :: forall t. Eq t => t -> t -> Bool + } + +-- +-- see how it hides the internal type.. but to compile GHC still checks +-- the type. +-- +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { equals = (==) } + diff --git a/examples/dynload/poly/prog/Main.hs b/examples/dynload/poly/prog/Main.hs new file mode 100644 index 0000000..ff91b2e --- /dev/null +++ b/examples/dynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ (Interface eq) -> do + putStrLn $ show $ 1 `eq` 2 + putStrLn $ show $ 'a' `eq` 'b' + diff --git a/examples/dynload/poly/prog/expected b/examples/dynload/poly/prog/expected new file mode 100644 index 0000000..dbde422 --- /dev/null +++ b/examples/dynload/poly/prog/expected @@ -0,0 +1,2 @@ +True +True diff --git a/examples/dynload/should_fail/Makefile b/examples/dynload/should_fail/Makefile new file mode 100644 index 0000000..c1bff86 --- /dev/null +++ b/examples/dynload/should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail/Plugin.hs b/examples/dynload/should_fail/Plugin.hs new file mode 100644 index 0000000..adad70e --- /dev/null +++ b/examples/dynload/should_fail/Plugin.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData + +v :: Int +v = 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/examples/dynload/should_fail/api/API.hs b/examples/dynload/should_fail/api/API.hs new file mode 100644 index 0000000..ee11e76 --- /dev/null +++ b/examples/dynload/should_fail/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/should_fail/prog/Main.hs b/examples/dynload/should_fail/prog/Main.hs new file mode 100644 index 0000000..3759159 --- /dev/null +++ b/examples/dynload/should_fail/prog/Main.hs @@ -0,0 +1,14 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" + ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ function v + diff --git a/examples/dynload/should_fail/prog/expected b/examples/dynload/should_fail/prog/expected new file mode 100644 index 0000000..5e0f819 --- /dev/null +++ b/examples/dynload/should_fail/prog/expected @@ -0,0 +1,4 @@ +Couldn't match `API.Interface' against `Int' + Expected type: API.Interface + Inferred type: Int +didn't compile diff --git a/examples/dynload/should_fail_1/Makefile b/examples/dynload/should_fail_1/Makefile new file mode 100644 index 0000000..896ff0e --- /dev/null +++ b/examples/dynload/should_fail_1/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_1 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_1/Plugin.hs b/examples/dynload/should_fail_1/Plugin.hs new file mode 100644 index 0000000..5e57fad --- /dev/null +++ b/examples/dynload/should_fail_1/Plugin.hs @@ -0,0 +1,15 @@ +-- +-- trying to be really mean. +-- + +module Plugin where + +import API +import AltData + +v :: Int -> Int +v = \x -> 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/examples/dynload/should_fail_1/api/API.hs b/examples/dynload/should_fail_1/api/API.hs new file mode 100644 index 0000000..ee11e76 --- /dev/null +++ b/examples/dynload/should_fail_1/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/should_fail_1/prog/Main.hs b/examples/dynload/should_fail_1/prog/Main.hs new file mode 100644 index 0000000..cf8f647 --- /dev/null +++ b/examples/dynload/should_fail_1/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] "resource_dyn" + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/examples/dynload/should_fail_1/prog/expected b/examples/dynload/should_fail_1/prog/expected new file mode 100644 index 0000000..821bc22 --- /dev/null +++ b/examples/dynload/should_fail_1/prog/expected @@ -0,0 +1,4 @@ +Couldn't match `API.Interface' against `Int -> Int' + Expected type: API.Interface + Inferred type: Int -> Int +didn't compile diff --git a/examples/dynload/should_fail_2/Makefile b/examples/dynload/should_fail_2/Makefile new file mode 100644 index 0000000..eaf3c29 --- /dev/null +++ b/examples/dynload/should_fail_2/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_2 + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_2/Plugin.in b/examples/dynload/should_fail_2/Plugin.in new file mode 100644 index 0000000..8de0ab7 --- /dev/null +++ b/examples/dynload/should_fail_2/Plugin.in @@ -0,0 +1,19 @@ +-- +-- the plugin doesn't even make the resource_dyn a Dynamic. +-- +-- let's hope that makeWith strips out the invalid declarations +-- + +{-# OPTIONS -fglasgow-exts #-} + +module Plugin where + +import API +import AltData +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf v, unsafeCoerce v) + diff --git a/examples/dynload/should_fail_2/Plugin.stub b/examples/dynload/should_fail_2/Plugin.stub new file mode 100644 index 0000000..efc2f53 --- /dev/null +++ b/examples/dynload/should_fail_2/Plugin.stub @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Plugin ( resource_dyn ) where + +import API +import AltData + +resource = plugin + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/dynload/should_fail_2/api/API.hs b/examples/dynload/should_fail_2/api/API.hs new file mode 100644 index 0000000..85ece49 --- /dev/null +++ b/examples/dynload/should_fail_2/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData +import GHC.Base + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + +unsafeCoerce = unsafeCoerce# diff --git a/examples/dynload/should_fail_2/prog/Main.hs b/examples/dynload/should_fail_2/prog/Main.hs new file mode 100644 index 0000000..ea9b05c --- /dev/null +++ b/examples/dynload/should_fail_2/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api", "-i../../../../src/altdata/"] + case status of + MakeFailure e -> mapM_ putStrLn e >> putStrLn "failed" + MakeSuccess _ o -> do { + ; m_v <- dynload o ["../api"] [] "resource_dyn" + ; makeCleaner o + ; case m_v of + LoadFailure _ -> putStrLn "didn't load" + LoadSuccess _ v -> putStrLn $ (function v) + } + diff --git a/examples/dynload/should_fail_2/prog/expected b/examples/dynload/should_fail_2/prog/expected new file mode 100644 index 0000000..16dbd87 --- /dev/null +++ b/examples/dynload/should_fail_2/prog/expected @@ -0,0 +1,8 @@ + +../Plugin.in:18: + Couldn't match `Dynamic' against `(t, t1)' + Expected type: Dynamic + Inferred type: (t, t1) + In the definition of `resource_dyn': + resource_dyn = (typeOf v, unsafeCoerce v) +failed diff --git a/examples/dynload/should_fail_2/prog/expected.604 b/examples/dynload/should_fail_2/prog/expected.604 new file mode 100644 index 0000000..91d4886 --- /dev/null +++ b/examples/dynload/should_fail_2/prog/expected.604 @@ -0,0 +1,7 @@ + +../Plugin.in:18:15: + Couldn't match `Dynamic' against `(a, b)' + Expected type: Dynamic + Inferred type: (a, b) + In the definition of `resource_dyn': resource_dyn = (typeOf v, unsafeCoerce v) +failed diff --git a/examples/dynload/should_fail_3/Makefile b/examples/dynload/should_fail_3/Makefile new file mode 100644 index 0000000..b0441c4 --- /dev/null +++ b/examples/dynload/should_fail_3/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_3 + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_3/Plugin.in b/examples/dynload/should_fail_3/Plugin.in new file mode 100644 index 0000000..0a4449d --- /dev/null +++ b/examples/dynload/should_fail_3/Plugin.in @@ -0,0 +1,19 @@ +-- +-- the plugin doesn't even make the resource_dyn a Dynamic. +-- let's hope that makeWith strips out the invalid declarations +-- + +{-# OPTIONS -fglasgow-exts #-} + +module Plugin where + +import API + +import AltData +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf plugin, unsafeCoerce v) + diff --git a/examples/dynload/should_fail_3/Plugin.stub b/examples/dynload/should_fail_3/Plugin.stub new file mode 100644 index 0000000..0106f56 --- /dev/null +++ b/examples/dynload/should_fail_3/Plugin.stub @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Plugin ( resource_dyn ) where + +import API +import AltData.Dynamic + +resource = plugin + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/dynload/should_fail_3/api/API.hs b/examples/dynload/should_fail_3/api/API.hs new file mode 100644 index 0000000..7989891 --- /dev/null +++ b/examples/dynload/should_fail_3/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} + +module API where + +import AltData +import GHC.Base + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf _ = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + +unsafeCoerce = unsafeCoerce# diff --git a/examples/dynload/should_fail_3/prog/Main.hs b/examples/dynload/should_fail_3/prog/Main.hs new file mode 100644 index 0000000..d67d64c --- /dev/null +++ b/examples/dynload/should_fail_3/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api", "-i../../../../src/altdata"] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- dynload o ["../api"] [] "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ v -> do putStrLn $ (function v) + makeCleaner o + diff --git a/examples/dynload/should_fail_3/prog/expected b/examples/dynload/should_fail_3/prog/expected new file mode 100644 index 0000000..45f7ea2 --- /dev/null +++ b/examples/dynload/should_fail_3/prog/expected @@ -0,0 +1,9 @@ + +../Plugin.in:18: + Couldn't match `Dynamic' against `(t, t1)' + Expected type: Dynamic + Inferred type: (t, t1) + In the definition of `resource_dyn': + resource_dyn = (typeOf plugin, unsafeCoerce v) + +Fail: failed diff --git a/examples/dynload/should_fail_3/prog/expected.604 b/examples/dynload/should_fail_3/prog/expected.604 new file mode 100644 index 0000000..47d4d61 --- /dev/null +++ b/examples/dynload/should_fail_3/prog/expected.604 @@ -0,0 +1,8 @@ + +../Plugin.in:18:15: + Couldn't match `Dynamic' against `(a, b)' + Expected type: Dynamic + Inferred type: (a, b) + In the definition of `resource_dyn': + resource_dyn = (typeOf plugin, unsafeCoerce v) +a.out: failed diff --git a/examples/dynload/simple/Makefile b/examples/dynload/simple/Makefile new file mode 100644 index 0000000..84cfc6d --- /dev/null +++ b/examples/dynload/simple/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/simple +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/simple/Plugin.hs b/examples/dynload/simple/Plugin.hs new file mode 100644 index 0000000..3850eb7 --- /dev/null +++ b/examples/dynload/simple/Plugin.hs @@ -0,0 +1,11 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData + +my_fun = plugin { function = "plugin says \"hello\"" } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/examples/dynload/simple/api/API.hs b/examples/dynload/simple/api/API.hs new file mode 100644 index 0000000..93035aa --- /dev/null +++ b/examples/dynload/simple/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/simple/prog/Main.hs b/examples/dynload/simple/prog/Main.hs new file mode 100644 index 0000000..eabd02c --- /dev/null +++ b/examples/dynload/simple/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/examples/dynload/simple/prog/expected b/examples/dynload/simple/prog/expected new file mode 100644 index 0000000..0391e1b --- /dev/null +++ b/examples/dynload/simple/prog/expected @@ -0,0 +1 @@ +plugin says "hello" diff --git a/examples/eval.mk b/examples/eval.mk new file mode 100644 index 0000000..879c8f6 --- /dev/null +++ b/examples/eval.mk @@ -0,0 +1,27 @@ +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package eval -package plugins -package printf + +BIN=a.out +SRC=Main.hs + +BINDIR= "." +REALBIN= ./$(BIN) + +.SUFFIXES : .o .hs .hi .lhs .hc .s + +all: $(BIN) + +$(BIN): $(SRC) $(OBJS) + @rm -f $@ + @$(GHC) --make -fglasgow-exts $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) $(SRC) + +# Standard suffix rules +.o.hi: + @: +.hs.o: + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) -c $< + +clean: + rm -rf *.hi *.o *~ $(BIN) diff --git a/examples/eval/eval1/Main.hs b/examples/eval/eval1/Main.hs new file mode 100644 index 0000000..d7fb14c --- /dev/null +++ b/examples/eval/eval1/Main.hs @@ -0,0 +1,5 @@ + +import Eval.Haskell + +main = do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int) + if isJust i then putStrLn $ show (fromJust i) else return () diff --git a/examples/eval/eval1/Makefile b/examples/eval/eval1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval1/expected b/examples/eval/eval1/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/eval/eval1/expected @@ -0,0 +1 @@ +7 diff --git a/examples/eval/eval2/Main.hs b/examples/eval/eval2/Main.hs new file mode 100644 index 0000000..ff75eac --- /dev/null +++ b/examples/eval/eval2/Main.hs @@ -0,0 +1,6 @@ +import Eval.Haskell + +main = do m_s <- eval "map toUpper \"haskell\"" ["Data.Char"] + case m_s of + Nothing -> putStrLn "typechecking failed" + Just s -> putStrLn s diff --git a/examples/eval/eval2/Makefile b/examples/eval/eval2/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval2/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval2/expected b/examples/eval/eval2/expected new file mode 100644 index 0000000..532f1d9 --- /dev/null +++ b/examples/eval/eval2/expected @@ -0,0 +1 @@ +HASKELL diff --git a/examples/eval/eval3/Main.hs b/examples/eval/eval3/Main.hs new file mode 100644 index 0000000..69b0903 --- /dev/null +++ b/examples/eval/eval3/Main.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -cpp #-} +-- +-- Should evaluate to '3', unless something goes wrong. +-- +-- Not so bad to use AltData, as it is already derived for all the basic +-- types. Then, just replace deriving Typeable, with hand-derived +-- instance of Typeable (see hs-plugins/examples/eval/eval_fn1/Poly.hs +-- +-- + +#include "../../../config.h" + +import Eval.Haskell +import AltData.Dynamic + +-- import Data.Dynamic + +pkgconf = TOP ++ "/plugins.conf.inplace" + +main = do + a <- return $ toDyn (3::Int) + + m_b <- unsafeEval_ "\\dyn -> fromMaybe (7 :: Int) (fromDyn dyn)" + ["AltData.Dynamic","Data.Maybe"] -- imports + + [ "-package-conf "++pkgconf , "-package altdata" ] + + [ pkgconf ] + [] + + +{- +-- should work, but doesn't. type check fails +-- (due to static vs dynamic typing issue) + + m_b <- unsafeEval_ "\\dyn -> fromMaybe (7 :: Int) (fromDynamic dyn)" + ["Data.Dynamic","Data.Maybe"] [] [] +-} + + case m_b of + Left s -> mapM_ putStrLn s + Right b -> putStrLn $ show (b a :: Int) diff --git a/examples/eval/eval3/Makefile b/examples/eval/eval3/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval3/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval3/expected b/examples/eval/eval3/expected new file mode 100644 index 0000000..00750ed --- /dev/null +++ b/examples/eval/eval3/expected @@ -0,0 +1 @@ +3 diff --git a/examples/eval/eval_/Main.hs b/examples/eval/eval_/Main.hs new file mode 100644 index 0000000..6bea135 --- /dev/null +++ b/examples/eval/eval_/Main.hs @@ -0,0 +1,9 @@ + +import Eval.Haskell + +main = do i <- eval_ "Just (7 :: Int)" + ["Maybe"] + ["-fglasgow-exts"] + [] + [] :: IO (Either [String] (Maybe (Maybe Int))) + print i diff --git a/examples/eval/eval_/Makefile b/examples/eval/eval_/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_/expected b/examples/eval/eval_/expected new file mode 100644 index 0000000..2432889 --- /dev/null +++ b/examples/eval/eval_/expected @@ -0,0 +1 @@ +Right (Just (Just 7)) diff --git a/examples/eval/eval_fn/Main.hs b/examples/eval/eval_fn/Main.hs new file mode 100644 index 0000000..27b8b8b --- /dev/null +++ b/examples/eval/eval_fn/Main.hs @@ -0,0 +1,10 @@ +-- +-- lambda abstraction! +-- +-- +-- needs unsafeEval because eval has a broken Dynamic check +-- +import Eval.Haskell + +main = do fn <- unsafeEval "(\\(x::Int) -> (x,x))" [] :: IO (Maybe (Int -> (Int,Int))) + when (isJust fn) $ putStrLn $ show $ (fromJust fn) 7 diff --git a/examples/eval/eval_fn/Makefile b/examples/eval/eval_fn/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_fn/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_fn/expected b/examples/eval/eval_fn/expected new file mode 100644 index 0000000..10769d1 --- /dev/null +++ b/examples/eval/eval_fn/expected @@ -0,0 +1 @@ +(7,7) diff --git a/examples/eval/eval_fn1/Main.hs b/examples/eval/eval_fn1/Main.hs new file mode 100644 index 0000000..f106fe2 --- /dev/null +++ b/examples/eval/eval_fn1/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- polymorphic eval! +-- + +module Main where + +import Poly +import Eval.Haskell + +main = do m_f <- eval "Fn (\\x y -> x == y)" ["Poly"] + when (isJust m_f) $ do + let (Fn f) = fromJust m_f + putStrLn $ show (f True True) + putStrLn $ show (f 1 2) diff --git a/examples/eval/eval_fn1/Makefile b/examples/eval/eval_fn1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_fn1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_fn1/Poly.hs b/examples/eval/eval_fn1/Poly.hs new file mode 100644 index 0000000..62fa38f --- /dev/null +++ b/examples/eval/eval_fn1/Poly.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +module Poly where + +import AltData.Typeable + +data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool} + +-- +-- ignore type inside the Fn... is this correct? +-- +instance Typeable Fn where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "Poly.Fn") [] +#else + typeOf _ = mkAppTy (mkTyCon "Poly.Fn") [] +#endif diff --git a/examples/eval/eval_fn1/expected b/examples/eval/eval_fn1/expected new file mode 100644 index 0000000..1cc8b5e --- /dev/null +++ b/examples/eval/eval_fn1/expected @@ -0,0 +1,2 @@ +True +False diff --git a/examples/eval/foreign_eval/Makefile b/examples/eval/foreign_eval/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_eval/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_eval/README b/examples/eval/foreign_eval/README new file mode 100644 index 0000000..2d2b839 --- /dev/null +++ b/examples/eval/foreign_eval/README @@ -0,0 +1 @@ +run a string of Haskell code from a C program. diff --git a/examples/eval/foreign_eval/expected b/examples/eval/foreign_eval/expected new file mode 100644 index 0000000..06a735b --- /dev/null +++ b/examples/eval/foreign_eval/expected @@ -0,0 +1 @@ +10946 diff --git a/examples/eval/foreign_eval/main.c b/examples/eval/foreign_eval/main.c new file mode 100644 index 0000000..cd1e575 --- /dev/null +++ b/examples/eval/foreign_eval/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20 :: Int"); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_eval1/Makefile b/examples/eval/foreign_eval1/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_eval1/expected b/examples/eval/foreign_eval1/expected new file mode 100644 index 0000000..06a735b --- /dev/null +++ b/examples/eval/foreign_eval1/expected @@ -0,0 +1 @@ +10946 diff --git a/examples/eval/foreign_eval1/main.c b/examples/eval/foreign_eval1/main.c new file mode 100644 index 0000000..f5f6e34 --- /dev/null +++ b/examples/eval/foreign_eval1/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + char *p; + hs_init(&argc, &argv); + p = hs_eval_s("show $ let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20"); + if (p == NULL) + printf("failed!\n"); + else + printf("%s\n",p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_should_fail/Makefile b/examples/eval/foreign_should_fail/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_should_fail/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_should_fail/expected b/examples/eval/foreign_should_fail/expected new file mode 100644 index 0000000..d733d74 --- /dev/null +++ b/examples/eval/foreign_should_fail/expected @@ -0,0 +1,2 @@ +:1: parse error on input `in' +failed! diff --git a/examples/eval/foreign_should_fail/expected.604 b/examples/eval/foreign_should_fail/expected.604 new file mode 100644 index 0000000..c7c5b75 --- /dev/null +++ b/examples/eval/foreign_should_fail/expected.604 @@ -0,0 +1 @@ +failed! diff --git a/examples/eval/foreign_should_fail/main.c b/examples/eval/foreign_should_fail/main.c new file mode 100644 index 0000000..d9da5d5 --- /dev/null +++ b/examples/eval/foreign_should_fail/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("show $ case 1 + 2 in{-wrong-} x -> x"); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_should_fail_illtyped/Makefile b/examples/eval/foreign_should_fail_illtyped/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_should_fail_illtyped/expected b/examples/eval/foreign_should_fail_illtyped/expected new file mode 100644 index 0000000..5cd8828 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/expected @@ -0,0 +1,4 @@ +Couldn't match `Int' against `[Char]' + Expected type: Int + Inferred type: [Char] +failed! diff --git a/examples/eval/foreign_should_fail_illtyped/expected.604 b/examples/eval/foreign_should_fail_illtyped/expected.604 new file mode 100644 index 0000000..c7c5b75 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/expected.604 @@ -0,0 +1 @@ +failed! diff --git a/examples/eval/foreign_should_fail_illtyped/main.c b/examples/eval/foreign_should_fail_illtyped/main.c new file mode 100644 index 0000000..ead2118 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("\"an ill-typed string\""); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/unsafeidir/Main.hs b/examples/eval/unsafeidir/Main.hs new file mode 100644 index 0000000..72d47d0 --- /dev/null +++ b/examples/eval/unsafeidir/Main.hs @@ -0,0 +1,16 @@ + +import Plugins.Make +import Eval.Haskell + +main = do make "a/Extra.hs" [] + + i <- unsafeEval_ "show (Just (1 + 6 :: Int)) ++ extra" + ["Data.Maybe", "Extra"] + ["-ia"] -- no make flags + [] -- no package.confs + ["a"] -- include paths to load from + :: IO (Either [String] String) + + case i of + Right i -> putStrLn $ show i + Left es -> mapM_ putStrLn es diff --git a/examples/eval/unsafeidir/Makefile b/examples/eval/unsafeidir/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/unsafeidir/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/unsafeidir/a/Extra.hs b/examples/eval/unsafeidir/a/Extra.hs new file mode 100644 index 0000000..0210d78 --- /dev/null +++ b/examples/eval/unsafeidir/a/Extra.hs @@ -0,0 +1,3 @@ +module Extra where + +extra = "an extra value" diff --git a/examples/eval/unsafeidir/expected b/examples/eval/unsafeidir/expected new file mode 100644 index 0000000..e01bba5 --- /dev/null +++ b/examples/eval/unsafeidir/expected @@ -0,0 +1 @@ +"Just 7an extra value" diff --git a/examples/foreign.mk b/examples/foreign.mk new file mode 100644 index 0000000..6958ac9 --- /dev/null +++ b/examples/foreign.mk @@ -0,0 +1,23 @@ +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + + +INCLUDES= -I$(TOP) +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package eval + +# compile with GHC to save us setting all the necessary include and +# lib flags. use ghc -v to find out what these are if you wish to go +# via gcc. +BIN=./a.out +SRC=main.c + +BINDIR= "." +REALBIN= $(BIN) + +all: $(BIN) + +$(BIN): $(SRC) + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(SRC) + +clean: + rm -rf *.hi *.o *~ $(BIN) diff --git a/examples/hier/hier1/Makefile b/examples/hier/hier1/Makefile new file mode 100644 index 0000000..89ca51a --- /dev/null +++ b/examples/hier/hier1/Makefile @@ -0,0 +1,8 @@ +TEST= hier/hier1 + +EXTRA_OBJS=Plugin.o +PRIOR_OBJS=Modules/Flags.o +EXTRAFLAGS= + +TOP=../../.. +include ../../build.mk diff --git a/examples/hier/hier1/Modules/Flags.hs b/examples/hier/hier1/Modules/Flags.hs new file mode 100644 index 0000000..eb5e10e --- /dev/null +++ b/examples/hier/hier1/Modules/Flags.hs @@ -0,0 +1,15 @@ +-- +-- A simple module +-- + +module Modules.Flags where + + +data FlagRec = FlagRec { + f1 :: Int, + f2 :: Int +} + + +foo :: FlagRec -> Int +foo x = f1 x diff --git a/examples/hier/hier1/Modules/Makefile b/examples/hier/hier1/Modules/Makefile new file mode 100644 index 0000000..58c4ee9 --- /dev/null +++ b/examples/hier/hier1/Modules/Makefile @@ -0,0 +1,6 @@ + +all: + ghc -O -c Flags.hs + +clean: + rm -f *.hi *.o diff --git a/examples/hier/hier1/Plugin.hs b/examples/hier/hier1/Plugin.hs new file mode 100644 index 0000000..0d9b68d --- /dev/null +++ b/examples/hier/hier1/Plugin.hs @@ -0,0 +1,14 @@ +-- +-- Plugin +-- + +module Plugin where + +import API +import Modules.Flags as Flags + + +resource = plugin { + dbFunc = (\x -> Flags.f1 x) +} + diff --git a/examples/hier/hier1/api/API.hs b/examples/hier/hier1/api/API.hs new file mode 100644 index 0000000..deae88e --- /dev/null +++ b/examples/hier/hier1/api/API.hs @@ -0,0 +1,16 @@ +-- +-- API for plugin test +-- + +module API where + +import Modules.Flags as Flags + +data Interface = Interface { + dbFunc :: Flags.FlagRec -> Int +} + + +plugin :: Interface +plugin = Interface { dbFunc = (\x -> 1) } + diff --git a/examples/hier/hier1/prog/Main.hs b/examples/hier/hier1/prog/Main.hs new file mode 100644 index 0000000..ded0247 --- /dev/null +++ b/examples/hier/hier1/prog/Main.hs @@ -0,0 +1,21 @@ +-- +-- Test multiple plugins +-- + + +module Main where + +import Plugins +import API +import Modules.Flags as Flags + + +rec = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 } + + +main = do + status <- load "../Plugin.o" ["../api",".."] [] "resource" + case status of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> do let func = dbFunc v + print (func rec) diff --git a/examples/hier/hier1/prog/expected b/examples/hier/hier1/prog/expected new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/examples/hier/hier1/prog/expected @@ -0,0 +1 @@ +4 diff --git a/examples/hier/hier2/A/B/C/Module.hs b/examples/hier/hier2/A/B/C/Module.hs new file mode 100644 index 0000000..9c5daa5 --- /dev/null +++ b/examples/hier/hier2/A/B/C/Module.hs @@ -0,0 +1,8 @@ +-- +-- A simple module +-- + +module A.B.C.Module where + +symbol = "You found me" + diff --git a/examples/hier/hier2/A/Makefile b/examples/hier/hier2/A/Makefile new file mode 100644 index 0000000..bb9a3be --- /dev/null +++ b/examples/hier/hier2/A/Makefile @@ -0,0 +1,7 @@ + +all: + ghc -c B/C/Module.hs + + +clean: + rm -f B/C/*.hi B/C/*.o diff --git a/examples/hier/hier2/Makefile b/examples/hier/hier2/Makefile new file mode 100644 index 0000000..89631b6 --- /dev/null +++ b/examples/hier/hier2/Makefile @@ -0,0 +1,7 @@ +TEST= hier/hier2 + +PRIOR_OBJS=A/B/C/Module.o +EXTRAFLAGS= + +TOP=../../.. +include ../../build.mk diff --git a/examples/hier/hier2/api/API.hs b/examples/hier/hier2/api/API.hs new file mode 100644 index 0000000..872fd34 --- /dev/null +++ b/examples/hier/hier2/api/API.hs @@ -0,0 +1,4 @@ +module API where + +-- just a dummy for the build system + diff --git a/examples/hier/hier2/prog/Main.hs b/examples/hier/hier2/prog/Main.hs new file mode 100644 index 0000000..afeb097 --- /dev/null +++ b/examples/hier/hier2/prog/Main.hs @@ -0,0 +1,15 @@ +-- +-- Test if we can load a module with a hierarchical name from some weird +-- path. Tests our the module name handling in the .hi file parser. +-- + + +module Main where + +import Plugins + +main = do + status <- load "../A/B/C/Module.o" [".."] [] "symbol" + case status of + LoadFailure ers -> mapM_ putStrLn ers + LoadSuccess _ v -> print (v :: String) diff --git a/examples/hier/hier2/prog/expected b/examples/hier/hier2/prog/expected new file mode 100644 index 0000000..c4a4db5 --- /dev/null +++ b/examples/hier/hier2/prog/expected @@ -0,0 +1 @@ +"You found me" diff --git a/examples/hier/hier3/Main.hs b/examples/hier/hier3/Main.hs new file mode 100644 index 0000000..ae4a152 --- /dev/null +++ b/examples/hier/hier3/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import Plugins + +main = do + + makeAll "One.hs" [] + + load2 "Two.o" + + load2 "./Two.o" -- shouldn't load + load2 "../hier3/Two.o" -- shouldn't load + load2 "././././Two.o" -- shouldn't load + + -- and this one pulls in "../hier3/Two.o" as a dep + y <- load "One.o" ["../hier3"] [] "resource" + case y of + LoadSuccess _ s -> putStrLn $ "One plugin: " ++ s + LoadFailure _ -> putStrLn "Failure: y" + +load2 f = do + x <- load f [".", "../hier3", ""] [] "resource" -- depend on One.o + case x of + LoadSuccess _ s -> putStrLn $ "Two plugin: " ++ s + LoadFailure _ -> putStrLn "Failure: x" diff --git a/examples/hier/hier3/Makefile b/examples/hier/hier3/Makefile new file mode 100644 index 0000000..f15119b --- /dev/null +++ b/examples/hier/hier3/Makefile @@ -0,0 +1,7 @@ +TEST= hier/hier3 + +EXTRA_OBJS=One.o Two.o +EXTRAFLAGS= + +TOP=../../.. +include ../../eval.mk diff --git a/examples/hier/hier3/One.hs b/examples/hier/hier3/One.hs new file mode 100644 index 0000000..da3a764 --- /dev/null +++ b/examples/hier/hier3/One.hs @@ -0,0 +1,7 @@ + +module One where + +import qualified Two + +resource = "This is the sub-plugin of (" ++ Two.resource ++ ")" + diff --git a/examples/hier/hier3/Two.hs b/examples/hier/hier3/Two.hs new file mode 100644 index 0000000..8b0124b --- /dev/null +++ b/examples/hier/hier3/Two.hs @@ -0,0 +1,4 @@ +module Two where + +resource = "This is the top plugin" + diff --git a/examples/hier/hier3/expected b/examples/hier/hier3/expected new file mode 100644 index 0000000..c7dc9d0 --- /dev/null +++ b/examples/hier/hier3/expected @@ -0,0 +1,5 @@ +Two plugin: This is the top plugin +Two plugin: This is the top plugin +Two plugin: This is the top plugin +Two plugin: This is the top plugin +One plugin: This is the sub-plugin of (This is the top plugin) diff --git a/examples/hier/hier4/A.hs b/examples/hier/hier4/A.hs new file mode 100644 index 0000000..10c6c61 --- /dev/null +++ b/examples/hier/hier4/A.hs @@ -0,0 +1,11 @@ + +-- now, the question is: is it possible to not depend on a module or +-- package, but nonetheless have an orphan to it? this could cause +-- problems.... + +module A where + +import B + +u :: Int +u = undefined diff --git a/examples/hier/hier4/B.hs b/examples/hier/hier4/B.hs new file mode 100644 index 0000000..d5bf5db --- /dev/null +++ b/examples/hier/hier4/B.hs @@ -0,0 +1,4 @@ +module B where + +import C () -- instances, to make available to those who use B + diff --git a/examples/hier/hier4/C.hs b/examples/hier/hier4/C.hs new file mode 100644 index 0000000..ba8915a --- /dev/null +++ b/examples/hier/hier4/C.hs @@ -0,0 +1,12 @@ + +-- try to construct an orphan module == an instance decl-only module, +-- that uses classes and types not defined in this module + +module C (C) where + +import D + +instance C a => D (T a) where + +class C a where + diff --git a/examples/hier/hier4/D.hs b/examples/hier/hier4/D.hs new file mode 100644 index 0000000..df13442 --- /dev/null +++ b/examples/hier/hier4/D.hs @@ -0,0 +1,6 @@ + +module D where + +class D a where + +data T a = T diff --git a/examples/hier/hier4/Main.hs b/examples/hier/hier4/Main.hs new file mode 100644 index 0000000..9a3d660 --- /dev/null +++ b/examples/hier/hier4/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Plugins + +main = do + + makeAll "A.hs" [] + + y <- load "A.o" ["."] [] "u" + case y of + LoadSuccess _ _ -> putStrLn $ "YES" + LoadFailure e -> mapM_ putStrLn e diff --git a/examples/hier/hier4/Makefile b/examples/hier/hier4/Makefile new file mode 100644 index 0000000..c327707 --- /dev/null +++ b/examples/hier/hier4/Makefile @@ -0,0 +1,4 @@ +TEST= hier/hier4 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/hier/hier4/expected b/examples/hier/hier4/expected new file mode 100644 index 0000000..f033a50 --- /dev/null +++ b/examples/hier/hier4/expected @@ -0,0 +1 @@ +YES diff --git a/examples/hmake/lib-plugs/Main.hs b/examples/hmake/lib-plugs/Main.hs new file mode 100644 index 0000000..2d977ad --- /dev/null +++ b/examples/hmake/lib-plugs/Main.hs @@ -0,0 +1,69 @@ +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- + +import Eval.Haskell +import Plugins.Load + +import System.Exit ( ExitCode(..), exitWith ) +import System.IO +import System.Console.Readline ( readline, addHistory ) + +symbol = "resource" + +main = do + putStrLn banner + putStr "Loading package base" >> hFlush stdout + loadPackage "base" + putStr " ... linking ... " >> hFlush stdout + resolveObjs + putStrLn "done" + + shell [] + +shell :: [String] -> IO () +shell imps = do + s <- readline "plugs> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + imps' <- run cmd imps + shell imps' + +run :: String -> [String] -> IO [String] +run "" is = return is +run ":?" is = putStrLn help >> return is + +run ":l" _ = return [] +run (':':'l':' ':m) is = return (m:is) + +run (':':'t':' ':s) is = do + ty <- typeOf s is + when (not $ null ty) (putStrLn $ s ++ " :: " ++ ty) + return is + +run (':':_) is = putStrLn help >> return is + +run s is = do + s <- unsafeEval ("show $ "++s) is + when (isJust s) (putStrLn (fromJust s)) + return is + +banner = "\ +\ __ \n\ +\ ____ / /_ ______ ______ \n\ +\ / __ \\/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98\n\ +\ / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins\n\ +\ / .___/_/\\__,_/\\__, /____/ Type :? for help \n\ +\/_/ /____/ \n" + +help = "\ +\Commands :\n\ +\ evaluate expression\n\ +\ :t show type of expression (monomorphic only)\n\ +\ :l module bring module in to scope\n\ +\ :l clear module list\n\ +\ :quit quit\n\ +\ :? display this list of commands" diff --git a/examples/hmake/lib-plugs/Makefile b/examples/hmake/lib-plugs/Makefile new file mode 100644 index 0000000..aa21db8 --- /dev/null +++ b/examples/hmake/lib-plugs/Makefile @@ -0,0 +1,29 @@ +GHCFLAGS= -O +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace +PKGFLAGS+= -package eval -package readline + +all: build + +build: + @$(GHC) $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) Main.hs -o plugs +check: build + @(if [ -f "expected" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + cat test.in | ./plugs > $$actual_out 2>&1 || true ;\ + diff -u expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out ;\ + else \ + cat test.in | ./plugs 2>&1 || true ;\ + fi) +clean: + rm -rf *.hi *.o *~ *.dep ./plugs + +include ../../../config.mk diff --git a/examples/hmake/lib-plugs/expected b/examples/hmake/lib-plugs/expected new file mode 100644 index 0000000..b55bda0 --- /dev/null +++ b/examples/hmake/lib-plugs/expected @@ -0,0 +1,9 @@ + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... plugs> plugs> done +453973694165307953197296969697410619233826 diff --git a/examples/hmake/lib-plugs/test.in b/examples/hmake/lib-plugs/test.in new file mode 100644 index 0000000..e38735d --- /dev/null +++ b/examples/hmake/lib-plugs/test.in @@ -0,0 +1,2 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 +:quit diff --git a/examples/hmake/one-shot/Main.hs b/examples/hmake/one-shot/Main.hs new file mode 100644 index 0000000..bf59e7d --- /dev/null +++ b/examples/hmake/one-shot/Main.hs @@ -0,0 +1,39 @@ +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- + +import Eval.Haskell (unsafeEval) + +import Data.Maybe (isJust, fromJust) +import Control.Monad (when) + +import System.Exit (exitWith, ExitCode(ExitSuccess)) +import System.IO (getContents, putStrLn) +import System.Posix.Resource (setResourceLimit, + Resource(ResourceCPUTime), + ResourceLimits(ResourceLimits), + ResourceLimit(ResourceLimit)) + +rlimit = ResourceLimit 3 + +context = prehier ++ datas ++ controls + +prehier = ["Char", "List", "Maybe", "Numeric", "Random" ] + +datas = map ("Data." ++) [ + "Bits", "Bool", "Char", "Dynamic", "Either", + "FiniteMap", "Graph", "Int", "Ix", "List", + "Maybe", "Ratio", "Set", "Tree", "Tuple", "Typeable", "Word" + ] + +controls = map ("Control." ++) ["Monad", "Arrow"] + +main = do + setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit) + s <- getContents + when (not . null $ s) $ do + s <- unsafeEval ("(take 2048 (show ("++s++")))") context + when (isJust s) (putStrLn (fromJust s)) + exitWith ExitSuccess + diff --git a/examples/hmake/one-shot/Makefile b/examples/hmake/one-shot/Makefile new file mode 100644 index 0000000..8ea2f06 --- /dev/null +++ b/examples/hmake/one-shot/Makefile @@ -0,0 +1,30 @@ +GHCFLAGS= -O +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace +PKGFLAGS+= -package eval -package unix + +all: build + +build: + @$(GHC) $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) Main.hs -o runplugs +include ../../../config.mk +check: build + @(if [ -f "expected" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + cat test.in | ./runplugs > $$actual_out 2>&1 || true ;\ + diff -u expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out ;\ + else \ + cat test.in | ./runplugs 2>&1 || true ;\ + fi) +clean: + rm -rf *.hi *.o *~ *.dep ./runplugs + +include ../../../config.mk diff --git a/examples/hmake/one-shot/expected b/examples/hmake/one-shot/expected new file mode 100644 index 0000000..e4b6306 --- /dev/null +++ b/examples/hmake/one-shot/expected @@ -0,0 +1 @@ +453973694165307953197296969697410619233826 diff --git a/examples/hmake/one-shot/test.in b/examples/hmake/one-shot/test.in new file mode 100644 index 0000000..d75281e --- /dev/null +++ b/examples/hmake/one-shot/test.in @@ -0,0 +1 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 diff --git a/examples/iface/null/A.hs b/examples/iface/null/A.hs new file mode 100644 index 0000000..d843c00 --- /dev/null +++ b/examples/iface/null/A.hs @@ -0,0 +1 @@ +module A where diff --git a/examples/iface/null/B.hs b/examples/iface/null/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/examples/iface/null/B.hs @@ -0,0 +1 @@ +module B where diff --git a/examples/iface/null/Main.hs b/examples/iface/null/Main.hs new file mode 100644 index 0000000..f3cee4c --- /dev/null +++ b/examples/iface/null/Main.hs @@ -0,0 +1,9 @@ +module Main ( main ) where + +import Hi.Parser + +import A +import B + +main = do iface <- readIface "Main.hi" + putStrLn (showIface iface) diff --git a/examples/iface/null/Makefile b/examples/iface/null/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/iface/null/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/iface/null/expected b/examples/iface/null/expected new file mode 100644 index 0000000..bce07ed --- /dev/null +++ b/examples/iface/null/expected @@ -0,0 +1,5 @@ +interface "Main" Main +module dependencies: A, B +package dependencies: base, haskell98, hi +import A +import B diff --git a/examples/iface/null/expected.604 b/examples/iface/null/expected.604 new file mode 100644 index 0000000..3e106e3 --- /dev/null +++ b/examples/iface/null/expected.604 @@ -0,0 +1,5 @@ +interface "unknown" Main +module dependencies: A, B +package dependencies: base-1.0, haskell98-1.0, hi-1.0 +import B +import A diff --git a/examples/load/io/Makefile b/examples/load/io/Makefile new file mode 100644 index 0000000..9531bed --- /dev/null +++ b/examples/load/io/Makefile @@ -0,0 +1,6 @@ +TEST= load/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/io/TestIO.hs b/examples/load/io/TestIO.hs new file mode 100644 index 0000000..58303e1 --- /dev/null +++ b/examples/load/io/TestIO.hs @@ -0,0 +1,84 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +module TestIO ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource = testio { field = date } + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/load/io/api/API.hs b/examples/load/io/api/API.hs new file mode 100644 index 0000000..4b8be53 --- /dev/null +++ b/examples/load/io/api/API.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data TestIO = TestIO { + field :: IO String + } + deriving (Typeable, Show) + +instance Show (IO String) where + show _ = "<>" + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/load/io/prog/Main.hs b/examples/load/io/prog/Main.hs new file mode 100644 index 0000000..76d6f1e --- /dev/null +++ b/examples/load/io/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main :: IO () +main = do + m_v <- load "../TestIO.o" ["../api"] [] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + s <- field v + if null s then print False else print True diff --git a/examples/load/io/prog/expected b/examples/load/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/load/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/load/load_0/Makefile b/examples/load/load_0/Makefile new file mode 100644 index 0000000..9bc144a --- /dev/null +++ b/examples/load/load_0/Makefile @@ -0,0 +1,6 @@ +TEST= load/load_0 + +EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/load_0/Test.hs b/examples/load/load_0/Test.hs new file mode 100644 index 0000000..6c15820 --- /dev/null +++ b/examples/load/load_0/Test.hs @@ -0,0 +1,6 @@ + +module Test where + +import API + +resource = test { field = "success" } diff --git a/examples/load/load_0/api/API.hs b/examples/load/load_0/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/load_0/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/load_0/prog/Main.hs b/examples/load/load_0/prog/Main.hs new file mode 100644 index 0000000..cb8aa5f --- /dev/null +++ b/examples/load/load_0/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +main = do + m_v <- load_ "../Test.o" ["../api"] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/load_0/prog/expected b/examples/load/load_0/prog/expected new file mode 100644 index 0000000..e1baeaa --- /dev/null +++ b/examples/load/load_0/prog/expected @@ -0,0 +1 @@ +"success" diff --git a/examples/load/loadpkg/Main.hs b/examples/load/loadpkg/Main.hs new file mode 100644 index 0000000..1956cfc --- /dev/null +++ b/examples/load/loadpkg/Main.hs @@ -0,0 +1,4 @@ + +import Plugins + +main = loadPackageWith "posix" [] diff --git a/examples/load/loadpkg/Makefile b/examples/load/loadpkg/Makefile new file mode 100644 index 0000000..2d96691 --- /dev/null +++ b/examples/load/loadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/loadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/loadpkg/expected b/examples/load/loadpkg/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/load/null/Makefile b/examples/load/null/Makefile new file mode 100644 index 0000000..b6d39b1 --- /dev/null +++ b/examples/load/null/Makefile @@ -0,0 +1,4 @@ +TEST= load/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/load/null/Null.hs b/examples/load/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/load/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/load/null/api/API.hs b/examples/load/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/load/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/load/null/prog/Main.hs b/examples/load/null/prog/Main.hs new file mode 100644 index 0000000..53faefd --- /dev/null +++ b/examples/load/null/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + let includes = [TOP ++ "/examples/load/null/api"] + m_v <- load "../Null.o" includes [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + + putStrLn ( show (a v) ) diff --git a/examples/load/null/prog/expected b/examples/load/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/load/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/load/rawload/Main.hs b/examples/load/rawload/Main.hs new file mode 100644 index 0000000..28bdb8d --- /dev/null +++ b/examples/load/rawload/Main.hs @@ -0,0 +1,8 @@ + +import Plugins + +main = do + m <- loadRawObject "t.o" + print (path m) + resolveObjs +-- loadFunction m "sym" diff --git a/examples/load/rawload/Makefile b/examples/load/rawload/Makefile new file mode 100644 index 0000000..fb830d4 --- /dev/null +++ b/examples/load/rawload/Makefile @@ -0,0 +1,6 @@ +TEST= load/rawload + +EXTRA_OBJS=c.o + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/rawload/t.c b/examples/load/rawload/t.c new file mode 100644 index 0000000..d889433 --- /dev/null +++ b/examples/load/rawload/t.c @@ -0,0 +1 @@ +int sym(void) { return 1; } diff --git a/examples/load/thiemann0/Makefile b/examples/load/thiemann0/Makefile new file mode 100644 index 0000000..a78b224 --- /dev/null +++ b/examples/load/thiemann0/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann0 + +#EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/thiemann0/Test.hs b/examples/load/thiemann0/Test.hs new file mode 100644 index 0000000..551f196 --- /dev/null +++ b/examples/load/thiemann0/Test.hs @@ -0,0 +1,11 @@ + +-- P.Thiemann reports that 'import Char' leads to undefined symbol for +-- __stginit_Char_. + +module Test where + +import API +import Char + +resource = test { field = map toUpper "success" } + diff --git a/examples/load/thiemann0/api/API.hs b/examples/load/thiemann0/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/thiemann0/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/thiemann0/prog/Main.hs b/examples/load/thiemann0/prog/Main.hs new file mode 100644 index 0000000..d49fbe2 --- /dev/null +++ b/examples/load/thiemann0/prog/Main.hs @@ -0,0 +1,16 @@ + +import Plugins +import API + +main = do + status <- make "../Test.hs" ["-i../api"] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load_ obj ["../api"] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/thiemann0/prog/expected b/examples/load/thiemann0/prog/expected new file mode 100644 index 0000000..5450ed7 --- /dev/null +++ b/examples/load/thiemann0/prog/expected @@ -0,0 +1 @@ +"SUCCESS" diff --git a/examples/load/thiemann2/C.hs b/examples/load/thiemann2/C.hs new file mode 100644 index 0000000..5d937c0 --- /dev/null +++ b/examples/load/thiemann2/C.hs @@ -0,0 +1,6 @@ +module C where + +import API +import qualified A + +resource = let Test s = A.resource in Test { field = s } diff --git a/examples/load/thiemann2/Makefile b/examples/load/thiemann2/Makefile new file mode 100644 index 0000000..28ff4c4 --- /dev/null +++ b/examples/load/thiemann2/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann2 +EXTRAFLAGS+=-iprog + +TOP=../../.. +include ../../build.mk + diff --git a/examples/load/thiemann2/api/API.hs b/examples/load/thiemann2/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/thiemann2/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/thiemann2/prog/A.hs b/examples/load/thiemann2/prog/A.hs new file mode 100644 index 0000000..9ca72b2 --- /dev/null +++ b/examples/load/thiemann2/prog/A.hs @@ -0,0 +1,8 @@ +module A where + +import API + +import qualified B + +resource = Test { field = B.resource } + diff --git a/examples/load/thiemann2/prog/B.hs b/examples/load/thiemann2/prog/B.hs new file mode 100644 index 0000000..4f566ce --- /dev/null +++ b/examples/load/thiemann2/prog/B.hs @@ -0,0 +1,3 @@ +module B where + +resource = "i'm in b" diff --git a/examples/load/thiemann2/prog/Main.hs b/examples/load/thiemann2/prog/Main.hs new file mode 100644 index 0000000..422f7fa --- /dev/null +++ b/examples/load/thiemann2/prog/Main.hs @@ -0,0 +1,20 @@ + +import Plugins +import API + +import A + +main = do + -- compile C (A and B are already compiled) + status <- makeAll "../C.hs" ["-i../api"] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + -- should load C + m_v <- load_ obj ["../api","."] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/thiemann2/prog/expected b/examples/load/thiemann2/prog/expected new file mode 100644 index 0000000..f72f54e --- /dev/null +++ b/examples/load/thiemann2/prog/expected @@ -0,0 +1 @@ +"i'm in b" diff --git a/examples/load/unloadpkg/Main.hs b/examples/load/unloadpkg/Main.hs new file mode 100644 index 0000000..c5fcae4 --- /dev/null +++ b/examples/load/unloadpkg/Main.hs @@ -0,0 +1,6 @@ + +import Plugins + +main = do loadPackage "posix" + unloadPackage "posix" + loadPackage "posix" diff --git a/examples/load/unloadpkg/Makefile b/examples/load/unloadpkg/Makefile new file mode 100644 index 0000000..78fe8ba --- /dev/null +++ b/examples/load/unloadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/unloadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/unloadpkg/expected b/examples/load/unloadpkg/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/make/makeall001/A.hs b/examples/make/makeall001/A.hs new file mode 100644 index 0000000..39df3ef --- /dev/null +++ b/examples/make/makeall001/A.hs @@ -0,0 +1,3 @@ +module A where + +a = "a" diff --git a/examples/make/makeall001/B.hs b/examples/make/makeall001/B.hs new file mode 100644 index 0000000..af38545 --- /dev/null +++ b/examples/make/makeall001/B.hs @@ -0,0 +1,3 @@ +module B where + +b = "b" diff --git a/examples/make/makeall001/C.hs b/examples/make/makeall001/C.hs new file mode 100644 index 0000000..d2f9b2a --- /dev/null +++ b/examples/make/makeall001/C.hs @@ -0,0 +1,3 @@ +module C where + +c = "c" diff --git a/examples/make/makeall001/Makefile b/examples/make/makeall001/Makefile new file mode 100644 index 0000000..2fd41ca --- /dev/null +++ b/examples/make/makeall001/Makefile @@ -0,0 +1,3 @@ +TEST= make/makeall001 +TOP=../../.. +include ../../build.mk diff --git a/examples/make/makeall001/Tiny.hs b/examples/make/makeall001/Tiny.hs new file mode 100644 index 0000000..237aa50 --- /dev/null +++ b/examples/make/makeall001/Tiny.hs @@ -0,0 +1,13 @@ +module Tiny ( resource ) where + +import API + +import A +import B +import C + +resource = tiny { + + field = a ++ b ++ c + +} diff --git a/examples/make/makeall001/api/API.hs b/examples/make/makeall001/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/make/makeall001/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/make/makeall001/prog/Main.hs b/examples/make/makeall001/prog/Main.hs new file mode 100644 index 0000000..3130f48 --- /dev/null +++ b/examples/make/makeall001/prog/Main.hs @@ -0,0 +1,18 @@ + +-- little more complex. use the path to the obj file we get back from +-- 'make'. load() uses this to find the .hi file + +import Plugins +import API + +main = do + status <- makeAll "../Tiny.hs" ["-i../api"] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + m_v <- load o [".."] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + diff --git a/examples/make/makeall001/prog/expected b/examples/make/makeall001/prog/expected new file mode 100644 index 0000000..8baef1b --- /dev/null +++ b/examples/make/makeall001/prog/expected @@ -0,0 +1 @@ +abc diff --git a/examples/make/null/Makefile b/examples/make/null/Makefile new file mode 100644 index 0000000..5c7f194 --- /dev/null +++ b/examples/make/null/Makefile @@ -0,0 +1,4 @@ +TEST= make/null + +TOP=../../.. +include ../../build.mk diff --git a/examples/make/null/Null.hs b/examples/make/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/make/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/make/null/api/API.hs b/examples/make/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/make/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/make/null/prog/Main.hs b/examples/make/null/prog/Main.hs new file mode 100644 index 0000000..d33ec27 --- /dev/null +++ b/examples/make/null/prog/Main.hs @@ -0,0 +1,13 @@ + +-- an example where we want to compile and load a file + +import Plugins +import API + +main = do + make "../Null.hs" ["-i../api"] + m_v <- load "../Null.o" ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn ( show (a v) ) diff --git a/examples/make/null/prog/expected b/examples/make/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/make/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/make/o/Makefile b/examples/make/o/Makefile new file mode 100644 index 0000000..09e51ce --- /dev/null +++ b/examples/make/o/Makefile @@ -0,0 +1,3 @@ +TEST=make/o +TOP =../../.. +include ../../build.mk diff --git a/examples/make/o/Plugin.hs b/examples/make/o/Plugin.hs new file mode 100644 index 0000000..44f2c23 --- /dev/null +++ b/examples/make/o/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/examples/make/o/api/API.hs b/examples/make/o/api/API.hs new file mode 100644 index 0000000..44e6a7b --- /dev/null +++ b/examples/make/o/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Interface = Interface { + field :: String +} + +plugin :: Interface +plugin = Interface { field = undefined } diff --git a/examples/make/o/prog/Main.hs b/examples/make/o/prog/Main.hs new file mode 100644 index 0000000..53a6a4b --- /dev/null +++ b/examples/make/o/prog/Main.hs @@ -0,0 +1,23 @@ +import Plugins +import API + +import System.Directory + +-- note: the name of the original *source* module is used to find +-- symbols in the *object* file. load works out what the source file +-- name was by looking at the object file name, i.e. it assumes they +-- have the same name. so, if you are going to store objects in a +-- tmpdir, you should make a tmp directory, and store them inside that, +-- rather than mkstemp'ing the name of the object file yourself. +-- +-- this should go away once we can read .hi files. + +main = do + make "../Plugin.hs" [ "-i../api", "-o", "/tmp/Plugin.o" ] + m_v <- load "/tmp/Plugin.o" ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + + mapM_ removeFile [ "/tmp/Plugin.o" , "/tmp/Plugin.hi" ] diff --git a/examples/make/o/prog/expected b/examples/make/o/prog/expected new file mode 100644 index 0000000..bd724e5 --- /dev/null +++ b/examples/make/o/prog/expected @@ -0,0 +1 @@ +hello out there diff --git a/examples/make/odir/Makefile b/examples/make/odir/Makefile new file mode 100644 index 0000000..159219a --- /dev/null +++ b/examples/make/odir/Makefile @@ -0,0 +1,3 @@ +TEST= make/odir +TOP=../../.. +include ../../build.mk diff --git a/examples/make/odir/Plugin.hs b/examples/make/odir/Plugin.hs new file mode 100644 index 0000000..44f2c23 --- /dev/null +++ b/examples/make/odir/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/examples/make/odir/api/API.hs b/examples/make/odir/api/API.hs new file mode 100644 index 0000000..44e6a7b --- /dev/null +++ b/examples/make/odir/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Interface = Interface { + field :: String +} + +plugin :: Interface +plugin = Interface { field = undefined } diff --git a/examples/make/odir/prog/Main.hs b/examples/make/odir/prog/Main.hs new file mode 100644 index 0000000..6d95f44 --- /dev/null +++ b/examples/make/odir/prog/Main.hs @@ -0,0 +1,16 @@ +import Plugins +import API +import System.Directory + +main = do + status <- make "../Plugin.hs" [ "-i../api", "-odir", "/tmp" ] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "didn't compile" + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + mapM_ removeFile ["/tmp/Plugin.hi", "/tmp/Plugin.o" ] + diff --git a/examples/make/odir/prog/expected b/examples/make/odir/prog/expected new file mode 100644 index 0000000..bd724e5 --- /dev/null +++ b/examples/make/odir/prog/expected @@ -0,0 +1 @@ +hello out there diff --git a/examples/make/remake001/Bar.hs b/examples/make/remake001/Bar.hs new file mode 100644 index 0000000..4eac815 --- /dev/null +++ b/examples/make/remake001/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undefined diff --git a/examples/make/remake001/Foo.hs b/examples/make/remake001/Foo.hs new file mode 100644 index 0000000..13993fd --- /dev/null +++ b/examples/make/remake001/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/examples/make/remake001/Main.hs b/examples/make/remake001/Main.hs new file mode 100644 index 0000000..29e42fe --- /dev/null +++ b/examples/make/remake001/Main.hs @@ -0,0 +1,36 @@ +-- +-- expected output: +-- $ ./a.out +-- True +-- False +-- True +-- False +-- + +import Plugins +import System.Directory + +main = do + status <- make "Foo.hs" [] -- should make + print status + + status <- make "Foo.hs" [] -- shouldn't make + print status + + status <- merge "Foo.hs" "Bar.hs" + case status of + MergeFailure e -> error $ show e + MergeSuccess _ _ fp -> do { + + ;status <- make fp [] -- should make + ;() <- case status of + MakeSuccess c _ -> print c + MakeFailure e -> error $ show e + + ;status <- make fp [] -- shouldn't make + ;case status of + MakeSuccess c _ -> print c + MakeFailure e -> error $ show e + ;removeFile "Foo.o" + } + diff --git a/examples/make/remake001/Makefile b/examples/make/remake001/Makefile new file mode 100644 index 0000000..a240d27 --- /dev/null +++ b/examples/make/remake001/Makefile @@ -0,0 +1,4 @@ +TEST= merge/remake001 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/make/remake001/expected b/examples/make/remake001/expected new file mode 100644 index 0000000..c35c9dc --- /dev/null +++ b/examples/make/remake001/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +ReComp +NotReq diff --git a/examples/make/remake001_should_fail/Bar.hs b/examples/make/remake001_should_fail/Bar.hs new file mode 100644 index 0000000..eb59d44 --- /dev/null +++ b/examples/make/remake001_should_fail/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undef {- error -} diff --git a/examples/make/remake001_should_fail/Foo.hs b/examples/make/remake001_should_fail/Foo.hs new file mode 100644 index 0000000..13993fd --- /dev/null +++ b/examples/make/remake001_should_fail/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/examples/make/remake001_should_fail/Main.hs b/examples/make/remake001_should_fail/Main.hs new file mode 100644 index 0000000..d3dcbc7 --- /dev/null +++ b/examples/make/remake001_should_fail/Main.hs @@ -0,0 +1,31 @@ + +import Plugins + +import System.Directory + +main = do + status <- make "Foo.hs" [] -- should make + print status + + status <- make "Foo.hs" [] -- shouldn't make + print status + + status <- merge "Foo.hs" "Bar.hs" + case status of + MergeFailure e -> error $ show e + MergeSuccess _ _ fp -> do { + + ;status <- make fp [] -- should make + ;() <- case status of + MakeSuccess c _ -> print c + MakeFailure _ -> print "make failure" + + ;status <- make fp [] -- shouldn't make + ;case status of + MakeSuccess c _ -> print c + MakeFailure _ -> print "make failure" + + ;removeFile "Foo.o" -- make test deterministic + } + + diff --git a/examples/make/remake001_should_fail/Makefile b/examples/make/remake001_should_fail/Makefile new file mode 100644 index 0000000..c8e3a00 --- /dev/null +++ b/examples/make/remake001_should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= make/remake001_should_fail + +TOP=../../.. +include ../../eval.mk diff --git a/examples/make/remake001_should_fail/expected b/examples/make/remake001_should_fail/expected new file mode 100644 index 0000000..475163e --- /dev/null +++ b/examples/make/remake001_should_fail/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +"make failure" +"make failure" diff --git a/examples/make/simple/Makefile b/examples/make/simple/Makefile new file mode 100644 index 0000000..0b211ed --- /dev/null +++ b/examples/make/simple/Makefile @@ -0,0 +1,3 @@ +TEST= make/simple +TOP=../../.. +include ../../build.mk diff --git a/examples/make/simple/Tiny.hs b/examples/make/simple/Tiny.hs new file mode 100644 index 0000000..0159f67 --- /dev/null +++ b/examples/make/simple/Tiny.hs @@ -0,0 +1,14 @@ +module Tiny ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = tiny { + + field = "hello strange world" + +} + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/make/simple/api/API.hs b/examples/make/simple/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/make/simple/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/make/simple/prog/Main.hs b/examples/make/simple/prog/Main.hs new file mode 100644 index 0000000..032c744 --- /dev/null +++ b/examples/make/simple/prog/Main.hs @@ -0,0 +1,19 @@ + +-- little more complex. use the path to the obj file we get back from +-- 'make'. load() uses this to find the .hi file + +import Plugins +import API + +main = do + status <- make "../Tiny.hs" ["-i../api"] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + diff --git a/examples/make/simple/prog/expected b/examples/make/simple/prog/expected new file mode 100644 index 0000000..e681b97 --- /dev/null +++ b/examples/make/simple/prog/expected @@ -0,0 +1 @@ +hello strange world diff --git a/examples/makewith/global_pragma/Makefile b/examples/makewith/global_pragma/Makefile new file mode 100644 index 0000000..5dcd9b0 --- /dev/null +++ b/examples/makewith/global_pragma/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/global_pragma + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/global_pragma/Plugin.hs b/examples/makewith/global_pragma/Plugin.hs new file mode 100644 index 0000000..2c80e71 --- /dev/null +++ b/examples/makewith/global_pragma/Plugin.hs @@ -0,0 +1,17 @@ +{-# GLOBALOPTIONS -package posix #-} + +module M ( resource ) where + +import System.IO.Unsafe +import API +import System.Process +import System.IO + +resource = tiny { field = date } + +date :: String +date = unsafePerformIO $ do + (_,outh,_,proc) <- runInteractiveProcess "echo" ["hello"] Nothing Nothing + waitForProcess proc + s <- hGetContents outh + return s diff --git a/examples/makewith/global_pragma/api/API.hs b/examples/makewith/global_pragma/api/API.hs new file mode 100644 index 0000000..34ec480 --- /dev/null +++ b/examples/makewith/global_pragma/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +data Tiny = Tiny { field :: String } + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/makewith/global_pragma/prog/Main.hs b/examples/makewith/global_pragma/prog/Main.hs new file mode 100644 index 0000000..e31a6ed --- /dev/null +++ b/examples/makewith/global_pragma/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.hs" +apipath = "../api" + +main = do + status <- makeWith conf conf ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + LoadFailure ers -> mapM_ putStrLn ers >> error "load failed" + putStr $ field v + makeCleaner o + diff --git a/examples/makewith/global_pragma/prog/expected b/examples/makewith/global_pragma/prog/expected new file mode 100644 index 0000000..ce01362 --- /dev/null +++ b/examples/makewith/global_pragma/prog/expected @@ -0,0 +1 @@ +hello diff --git a/examples/makewith/io/Makefile b/examples/makewith/io/Makefile new file mode 100644 index 0000000..f1e3069 --- /dev/null +++ b/examples/makewith/io/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/io + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/io/README b/examples/makewith/io/README new file mode 100644 index 0000000..1cad0c3 --- /dev/null +++ b/examples/makewith/io/README @@ -0,0 +1,2 @@ +An example using IO monad fields in the .conf file. + diff --git a/examples/makewith/io/TestIO.conf b/examples/makewith/io/TestIO.conf new file mode 100644 index 0000000..03c5b35 --- /dev/null +++ b/examples/makewith/io/TestIO.conf @@ -0,0 +1,76 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource = testio { field = date } + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/makewith/io/TestIO.stub b/examples/makewith/io/TestIO.stub new file mode 100644 index 0000000..5caee4c --- /dev/null +++ b/examples/makewith/io/TestIO.stub @@ -0,0 +1,10 @@ + +module TestIO ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = testio + +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/makewith/io/api/API.hs b/examples/makewith/io/api/API.hs new file mode 100644 index 0000000..4b8be53 --- /dev/null +++ b/examples/makewith/io/api/API.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data TestIO = TestIO { + field :: IO String + } + deriving (Typeable, Show) + +instance Show (IO String) where + show _ = "<>" + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/makewith/io/prog/Main.hs b/examples/makewith/io/prog/Main.hs new file mode 100644 index 0000000..36d3dc3 --- /dev/null +++ b/examples/makewith/io/prog/Main.hs @@ -0,0 +1,21 @@ + +import Plugins +import API + +conf = "../TestIO.conf" +stub = "../TestIO.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + s <- field v + + makeCleaner o + if null s then print False else print True diff --git a/examples/makewith/io/prog/expected b/examples/makewith/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/makewith/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/makewith/merge00/Bar.hs b/examples/makewith/merge00/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/merge00/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/merge00/Foo.hs b/examples/makewith/merge00/Foo.hs new file mode 100644 index 0000000..73859db --- /dev/null +++ b/examples/makewith/merge00/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/examples/makewith/merge00/Main.hs b/examples/makewith/merge00/Main.hs new file mode 100644 index 0000000..7e88c1e --- /dev/null +++ b/examples/makewith/merge00/Main.hs @@ -0,0 +1,38 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" + +main = do + status <- merge a b + f <- case status of + MergeFailure e -> error "merge failure" + MergeSuccess _ _ f -> return f + + status <- merge a b + f' <- case status of + MergeFailure e -> error "merge failure" + MergeSuccess ReComp _ f -> error "unnec. merge" + MergeSuccess NotReq _ f -> return f + + print ( f == f' ) + + status <- make f' [] + o <- case status of + MakeFailure e -> error "make failed" + MakeSuccess _ o -> return o + + m_v <- load o [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + removeFile o + return () + + makeCleaner f + diff --git a/examples/makewith/merge00/Makefile b/examples/makewith/merge00/Makefile new file mode 100644 index 0000000..da2b197 --- /dev/null +++ b/examples/makewith/merge00/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/merge00 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/merge00/expected b/examples/makewith/merge00/expected new file mode 100644 index 0000000..38cd603 --- /dev/null +++ b/examples/makewith/merge00/expected @@ -0,0 +1,2 @@ +True +2989 diff --git a/examples/makewith/mergeto0/Bar.hs b/examples/makewith/mergeto0/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/mergeto0/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/mergeto0/Foo.hs b/examples/makewith/mergeto0/Foo.hs new file mode 100644 index 0000000..73859db --- /dev/null +++ b/examples/makewith/mergeto0/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/examples/makewith/mergeto0/Main.hs b/examples/makewith/mergeto0/Main.hs new file mode 100644 index 0000000..a6beb82 --- /dev/null +++ b/examples/makewith/mergeto0/Main.hs @@ -0,0 +1,37 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" +c = "Out.hs" + +main = do + status <- mergeTo a b c + f <- case status of + MergeFailure e -> error "mergeto failure" + MergeSuccess _ _ f -> return f + print $ f == c + + status <- mergeTo a b c + f' <- case status of + MergeFailure e -> error "mergeto failure" + MergeSuccess ReComp _ f -> error "unnec. mergeto" + MergeSuccess NotReq _ f -> return f -- good, not req + + print $ f == f' && f == c + + status <- make f' [] + o <- case status of + MakeFailure e -> error "make failed" + MakeSuccess _ o -> return o + + m_v <- load o [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + makeCleaner c + diff --git a/examples/makewith/mergeto0/Makefile b/examples/makewith/mergeto0/Makefile new file mode 100644 index 0000000..c2d2d89 --- /dev/null +++ b/examples/makewith/mergeto0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/mergeto0 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/mergeto0/expected b/examples/makewith/mergeto0/expected new file mode 100644 index 0000000..06afacf --- /dev/null +++ b/examples/makewith/mergeto0/expected @@ -0,0 +1,3 @@ +True +True +2989 diff --git a/examples/makewith/module_name/Bar.hs b/examples/makewith/module_name/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/module_name/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/module_name/Foo.hs b/examples/makewith/module_name/Foo.hs new file mode 100644 index 0000000..b2cf693 --- /dev/null +++ b/examples/makewith/module_name/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/examples/makewith/module_name/Main.hs b/examples/makewith/module_name/Main.hs new file mode 100644 index 0000000..10d4a73 --- /dev/null +++ b/examples/makewith/module_name/Main.hs @@ -0,0 +1,33 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" + +main = do + status <- makeWith a b [] + s <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith a b [] + s' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith a b [] + s'' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + print $ (s == s') && (s' == s'') + + m_v <- load s [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + makeCleaner s'' diff --git a/examples/makewith/module_name/Makefile b/examples/makewith/module_name/Makefile new file mode 100644 index 0000000..fdab0c9 --- /dev/null +++ b/examples/makewith/module_name/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/module_name + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/module_name/expected b/examples/makewith/module_name/expected new file mode 100644 index 0000000..55e8cc5 --- /dev/null +++ b/examples/makewith/module_name/expected @@ -0,0 +1,5 @@ +ReComp +NotReq +NotReq +True +1 diff --git a/examples/makewith/multi_make/Bar.hs b/examples/makewith/multi_make/Bar.hs new file mode 100644 index 0000000..d09e32d --- /dev/null +++ b/examples/makewith/multi_make/Bar.hs @@ -0,0 +1,4 @@ +module Bar where + +resource :: Int +resource = 2 diff --git a/examples/makewith/multi_make/Foo.hs b/examples/makewith/multi_make/Foo.hs new file mode 100644 index 0000000..b2cf693 --- /dev/null +++ b/examples/makewith/multi_make/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/examples/makewith/multi_make/Main.hs b/examples/makewith/multi_make/Main.hs new file mode 100644 index 0000000..1720d88 --- /dev/null +++ b/examples/makewith/multi_make/Main.hs @@ -0,0 +1,37 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- user code +b = "Bar.hs" -- more user code +z = "Stub.hs" -- and a stub + +main = do + status <- makeWith a z [] + s <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith b z [] + s' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + -- shouldn't need to remerge (a,z) + status <- makeWith a z [] + t <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + -- shouldn't need to remerge (b,z) + status <- makeWith b z [] + t' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + print $ s /= s' -- test we got unique modules + print $ t /= t' -- test we got unique modules + + mapM_ makeCleaner [s,s'] + diff --git a/examples/makewith/multi_make/Makefile b/examples/makewith/multi_make/Makefile new file mode 100644 index 0000000..04ffdc9 --- /dev/null +++ b/examples/makewith/multi_make/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/multi_make + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/multi_make/Stub.hs b/examples/makewith/multi_make/Stub.hs new file mode 100644 index 0000000..1be6e6a --- /dev/null +++ b/examples/makewith/multi_make/Stub.hs @@ -0,0 +1,4 @@ +module Stub where + +resource :: Int + diff --git a/examples/makewith/multi_make/expected b/examples/makewith/multi_make/expected new file mode 100644 index 0000000..72713cd --- /dev/null +++ b/examples/makewith/multi_make/expected @@ -0,0 +1,6 @@ +ReComp +ReComp +NotReq +NotReq +True +True diff --git a/examples/makewith/should_fail_0/Makefile b/examples/makewith/should_fail_0/Makefile new file mode 100644 index 0000000..4aa0ebd --- /dev/null +++ b/examples/makewith/should_fail_0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/should_fail_0 + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/should_fail_0/Plugin.in b/examples/makewith/should_fail_0/Plugin.in new file mode 100644 index 0000000..479a79d --- /dev/null +++ b/examples/makewith/should_fail_0/Plugin.in @@ -0,0 +1,3 @@ +module Plugin where + +resource = 0xBAD :: Int diff --git a/examples/makewith/should_fail_0/Plugin.stub b/examples/makewith/should_fail_0/Plugin.stub new file mode 100644 index 0000000..2f8c176 --- /dev/null +++ b/examples/makewith/should_fail_0/Plugin.stub @@ -0,0 +1,6 @@ +module Plugin ( resource ) where + +import API + +resource :: Interface +resource = plugin diff --git a/examples/makewith/should_fail_0/api/API.hs b/examples/makewith/should_fail_0/api/API.hs new file mode 100644 index 0000000..df6c757 --- /dev/null +++ b/examples/makewith/should_fail_0/api/API.hs @@ -0,0 +1,10 @@ + +module API where + +data Interface = Interface { + function :: String + } + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/makewith/should_fail_0/prog/Main.hs b/examples/makewith/should_fail_0/prog/Main.hs new file mode 100644 index 0000000..94b4f06 --- /dev/null +++ b/examples/makewith/should_fail_0/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api"] + case status of + MakeFailure e -> putStrLn "make failed" + MakeSuccess _ o -> do + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ (function v) + makeCleaner o + diff --git a/examples/makewith/should_fail_0/prog/expected b/examples/makewith/should_fail_0/prog/expected new file mode 100644 index 0000000..8f81285 --- /dev/null +++ b/examples/makewith/should_fail_0/prog/expected @@ -0,0 +1 @@ +make failed diff --git a/examples/makewith/tiny/Makefile b/examples/makewith/tiny/Makefile new file mode 100644 index 0000000..bcb0aad --- /dev/null +++ b/examples/makewith/tiny/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/tiny + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/tiny/Tiny.conf b/examples/makewith/tiny/Tiny.conf new file mode 100644 index 0000000..f868e95 --- /dev/null +++ b/examples/makewith/tiny/Tiny.conf @@ -0,0 +1,8 @@ +resource = tiny { + + field = "hello strange world" + +} + + + diff --git a/examples/makewith/tiny/Tiny.stub b/examples/makewith/tiny/Tiny.stub new file mode 100644 index 0000000..2778ddd --- /dev/null +++ b/examples/makewith/tiny/Tiny.stub @@ -0,0 +1,31 @@ +module Tiny ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = tiny + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/makewith/tiny/api/API.hs b/examples/makewith/tiny/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/makewith/tiny/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/makewith/tiny/prog/Main.hs b/examples/makewith/tiny/prog/Main.hs new file mode 100644 index 0000000..a95d0ea --- /dev/null +++ b/examples/makewith/tiny/prog/Main.hs @@ -0,0 +1,21 @@ + +import Plugins +import API +import Data.Either + +conf = "../Tiny.conf" +stub = "../Tiny.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + makeCleaner o + diff --git a/examples/makewith/tiny/prog/expected b/examples/makewith/tiny/prog/expected new file mode 100644 index 0000000..e681b97 --- /dev/null +++ b/examples/makewith/tiny/prog/expected @@ -0,0 +1 @@ +hello strange world diff --git a/examples/makewith/unsafeio/Makefile b/examples/makewith/unsafeio/Makefile new file mode 100644 index 0000000..f975577 --- /dev/null +++ b/examples/makewith/unsafeio/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/unsafeio + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/unsafeio/README b/examples/makewith/unsafeio/README new file mode 100644 index 0000000..d2d987d --- /dev/null +++ b/examples/makewith/unsafeio/README @@ -0,0 +1,3 @@ +hmm. on 6.3 we need to add 'mtl' to a package dependency, other +HSlang complains of a missing symbol. Is this a bug in the +package.conf for HSlang? diff --git a/examples/makewith/unsafeio/Unsafe.conf b/examples/makewith/unsafeio/Unsafe.conf new file mode 100644 index 0000000..69e9761 --- /dev/null +++ b/examples/makewith/unsafeio/Unsafe.conf @@ -0,0 +1,17 @@ +{-# GLOBALOPTIONS -package posix #-} +-- illustrates the use of static options in pragmas + +import System.IO.Unsafe +import System.IO +import System.Process + +resource = unsafe { field = date } + +-- illustrates the use of the devil's work +date :: String +date = unsafePerformIO $ do + (_,outh,_,proc) <- runInteractiveProcess "date" [] Nothing Nothing + waitForProcess proc + s <- hGetContents outh + return s + diff --git a/examples/makewith/unsafeio/Unsafe.stub b/examples/makewith/unsafeio/Unsafe.stub new file mode 100644 index 0000000..296a5c6 --- /dev/null +++ b/examples/makewith/unsafeio/Unsafe.stub @@ -0,0 +1,13 @@ + +module Unsafe ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = unsafe + +-- +-- special +-- +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/makewith/unsafeio/api/API.hs b/examples/makewith/unsafeio/api/API.hs new file mode 100644 index 0000000..7b6564a --- /dev/null +++ b/examples/makewith/unsafeio/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Unsafe = Unsafe { + field :: String + } + deriving (Typeable, Show) + +unsafe :: Unsafe +unsafe = Unsafe { field = "default value" } diff --git a/examples/makewith/unsafeio/prog/Main.hs b/examples/makewith/unsafeio/prog/Main.hs new file mode 100644 index 0000000..b9920b7 --- /dev/null +++ b/examples/makewith/unsafeio/prog/Main.hs @@ -0,0 +1,20 @@ +import Plugins +import API +import Data.Either + +conf = "../Unsafe.conf" +stub = "../Unsafe.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + let s = field v + makeCleaner o + if null s then print False else print True diff --git a/examples/makewith/unsafeio/prog/README b/examples/makewith/unsafeio/prog/README new file mode 100644 index 0000000..d322aed --- /dev/null +++ b/examples/makewith/unsafeio/prog/README @@ -0,0 +1,8 @@ +this is an example of an application that uses the HSConf library to +dynamically load compiled conf files. + +We use the .conf file in the parent directory, and communicate with +the plugin via the API in the api_package/ directory. + +The plugin is a .o file +The api is a GHC package archive diff --git a/examples/makewith/unsafeio/prog/expected b/examples/makewith/unsafeio/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/makewith/unsafeio/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/misc/mkstemps/Main.hs b/examples/misc/mkstemps/Main.hs new file mode 100644 index 0000000..a471bae --- /dev/null +++ b/examples/misc/mkstemps/Main.hs @@ -0,0 +1,69 @@ + +import Plugins.MkTemp + +import Data.Maybe + +import System.IO +import System.Directory + +main = do + createDirectory "t" + + ------------------------------------------------------------------------ + -- Try mkstemp with simple template + -- + ts <- mapM (\_ -> mkstemp "t/t.X" ) [0..(26+26)] -- 1+26+26 files + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemp couldn't create all expected files" + else putStrLn $ "created "++(show $ length $ catMaybes ts)++" files" + closeAll ts + + -- next one shouldn't be possible + t <- mkstemp "t/t.X" + () <- if (not $ isNothing t) + then putStrLn $ "shouldn't have been able to create this file" + else putStrLn $ "correctly ran out of permutations" + closeAll [t] + + rmAll (t:ts) + + ------------------------------------------------------------------------ + -- Try again with large tmp + -- + ts <- mapM (\_->do v <- mkstemp "t/t.XXXXXXXXXX" + case v of Just (t,h) -> hClose h >> return v + _ -> return v ) [1..10000] + + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemp couldn't create all expected files" + else putStrLn $ "mkstemp: created "++(show $ length $ catMaybes ts)++" files" + rmAll ts + + ------------------------------------------------------------------------ + -- test mkstemps + -- + ts <- mapM (\_->do v <- mkstemps "t/t.XXXXXXXXXX.hs" 3 + case v of Just (t,h) -> hClose h >> return v + _ -> return v ) [1..2000] + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemps couldn't create all expected files" + else putStrLn $ "mkstemps: created "++(show $ length $ catMaybes ts)++" files" + rmAll ts + + ------------------------------------------------------------------------ + -- mkdtemp + -- + ts <- mapM (\_ -> mkdtemp "t/XXXXXXXXXX") [1..2000] + () <- if (not $ all isJust ts) + then putStrLn $ "mkdtemp: couldn't create all expected directories" + else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories" + rmAllDirs ts + + ------------------------------------------------------------------------ + + removeDirectory "t" + + where + closeAll ts = mapM_ hClose $ map snd $ catMaybes ts + rmAll ts = mapM_ removeFile $ map fst $ catMaybes ts + rmAllDirs ts = mapM_ removeDirectory $ catMaybes ts diff --git a/examples/misc/mkstemps/Makefile b/examples/misc/mkstemps/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/misc/mkstemps/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/misc/mkstemps/expected b/examples/misc/mkstemps/expected new file mode 100644 index 0000000..e05d35f --- /dev/null +++ b/examples/misc/mkstemps/expected @@ -0,0 +1,5 @@ +created 53 files +correctly ran out of permutations +mkstemp: created 10000 files +mkstemps: created 2000 files +mkdtemp: created 2000 directories diff --git a/examples/multi/3plugins/Makefile b/examples/multi/3plugins/Makefile new file mode 100644 index 0000000..cea7c9d --- /dev/null +++ b/examples/multi/3plugins/Makefile @@ -0,0 +1,6 @@ +TEST= multi/3plugins + +EXTRA_OBJS=Plugin1.o Plugin2.o Plugin3.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/multi/3plugins/Plugin1.hs b/examples/multi/3plugins/Plugin1.hs new file mode 100644 index 0000000..b2c6e8b --- /dev/null +++ b/examples/multi/3plugins/Plugin1.hs @@ -0,0 +1,8 @@ +module Plugin1 where + +import API +import Data.Char + +resource = plugin { + valueOf = map toUpper +} diff --git a/examples/multi/3plugins/Plugin2.hs b/examples/multi/3plugins/Plugin2.hs new file mode 100644 index 0000000..9a58ca6 --- /dev/null +++ b/examples/multi/3plugins/Plugin2.hs @@ -0,0 +1,9 @@ +module Plugin2 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> show $ map ord s +} + diff --git a/examples/multi/3plugins/Plugin3.hs b/examples/multi/3plugins/Plugin3.hs new file mode 100644 index 0000000..e99af2b --- /dev/null +++ b/examples/multi/3plugins/Plugin3.hs @@ -0,0 +1,7 @@ +module Plugin3 where + +import API + +resource = plugin { + valueOf = reverse +} diff --git a/examples/multi/3plugins/api/API.hs b/examples/multi/3plugins/api/API.hs new file mode 100644 index 0000000..25df753 --- /dev/null +++ b/examples/multi/3plugins/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + valueOf :: String -> String +} + +plugin :: Interface +plugin = Interface { valueOf = id } + diff --git a/examples/multi/3plugins/prog/Main.hs b/examples/multi/3plugins/prog/Main.hs new file mode 100644 index 0000000..9ef6175 --- /dev/null +++ b/examples/multi/3plugins/prog/Main.hs @@ -0,0 +1,13 @@ +import Plugins +import API + +main = do + let plist = ["../Plugin1.o", "../Plugin2.o", "../Plugin3.o"] + plugins <- mapM (\p -> load p ["../api"] [] "resource") plist + let functions = map (valueOf . fromLoadSuc) plugins + + -- apply the function from each plugin in turn + mapM_ (\f -> putStrLn $ f "haskell is for hackers") functions + +fromLoadSuc (LoadFailure _) = error "load failed" +fromLoadSuc (LoadSuccess _ v) = v diff --git a/examples/multi/3plugins/prog/expected b/examples/multi/3plugins/prog/expected new file mode 100644 index 0000000..d0ae0cf --- /dev/null +++ b/examples/multi/3plugins/prog/expected @@ -0,0 +1,3 @@ +HASKELL IS FOR HACKERS +[104,97,115,107,101,108,108,32,105,115,32,102,111,114,32,104,97,99,107,101,114,115] +srekcah rof si lleksah diff --git a/examples/objc/expression_parser/ArithmeticExpressionParser.hs b/examples/objc/expression_parser/ArithmeticExpressionParser.hs new file mode 100644 index 0000000..74fbdc7 --- /dev/null +++ b/examples/objc/expression_parser/ArithmeticExpressionParser.hs @@ -0,0 +1,30 @@ +module ArithmeticExpressionParser where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr + +resource :: String -> IO String +resource text = do + parsedText <- mapM parseString (lines text) + return (unlines parsedText) + +parseString s = do + case (parse expr "" s) of + Left err -> return ("Error " ++ show err) + Right num -> return (show num) + +expr :: Parser Integer +expr = buildExpressionParser table factor "expression" + +table = [ [op "*" (*) AssocLeft, op "/" div AssocLeft] + , [op "+" (+) AssocLeft, op "-" (-) AssocLeft] ] + where + op s f assoc = Infix (do { string s; return f }) assoc + +factor = do { char '('; x <- expr; char ')'; return x } + <|> number + "simple expression" + +number :: Parser Integer +number = do { ds <- many1 digit; return (read ds) } "number" + diff --git a/examples/objc/expression_parser/English.lproj/Credits.rtf b/examples/objc/expression_parser/English.lproj/Credits.rtf new file mode 100644 index 0000000..46576ef --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/Credits.rtf @@ -0,0 +1,29 @@ +{\rtf0\ansi{\fonttbl\f0\fswiss Helvetica;} +{\colortbl;\red255\green255\blue255;} +\paperw9840\paperh8400 +\pard\tx560\tx1120\tx1680\tx2240\tx2800\tx3360\tx3920\tx4480\tx5040\tx5600\tx6160\tx6720\ql\qnatural + +\f0\b\fs24 \cf0 Engineering: +\b0 \ + Some people\ +\ + +\b Human Interface Design: +\b0 \ + Some other people\ +\ + +\b Testing: +\b0 \ + Hopefully not nobody\ +\ + +\b Documentation: +\b0 \ + Whoever\ +\ + +\b With special thanks to: +\b0 \ + Mom\ +} diff --git a/examples/objc/expression_parser/English.lproj/InfoPlist.strings b/examples/objc/expression_parser/English.lproj/InfoPlist.strings new file mode 100644 index 0000000..f21c270 Binary files /dev/null and b/examples/objc/expression_parser/English.lproj/InfoPlist.strings differ diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib new file mode 100644 index 0000000..b9b4b09 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib @@ -0,0 +1,4 @@ +{ + IBClasses = ({CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }); + IBVersion = 1; +} \ No newline at end of file diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib new file mode 100644 index 0000000..138ebce --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib @@ -0,0 +1,21 @@ + + + + + IBDocumentLocation + 116 123 356 240 0 0 1600 1178 + IBEditorPositions + + 29 + 117 405 318 44 0 0 1600 1178 + + IBFramework Version + 328.0 + IBOpenObjects + + 29 + + IBSystem Version + 7B8 + + diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib new file mode 100644 index 0000000..f265b7f Binary files /dev/null and b/examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib differ diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib new file mode 100644 index 0000000..17cfa47 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib @@ -0,0 +1,13 @@ +{ + IBClasses = ( + {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, + { + ACTIONS = {chooseParser = id; evaluateExpression = id; }; + CLASS = MyDocument; + LANGUAGE = ObjC; + OUTLETS = {evaluation = id; expressionEntry = id; parser = id; }; + SUPERCLASS = NSDocument; + } + ); + IBVersion = 1; +} \ No newline at end of file diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib new file mode 100644 index 0000000..285ee38 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib @@ -0,0 +1,16 @@ + + + + + IBDocumentLocation + 79 43 356 240 0 0 1280 832 + IBFramework Version + 349.0 + IBOpenObjects + + 21 + + IBSystem Version + 7F44 + + diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib new file mode 100644 index 0000000..291235b Binary files /dev/null and b/examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib differ diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib new file mode 100644 index 0000000..b4b3512 Binary files /dev/null and b/examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib differ diff --git a/examples/objc/expression_parser/Info.plist b/examples/objc/expression_parser/Info.plist new file mode 100644 index 0000000..f746309 --- /dev/null +++ b/examples/objc/expression_parser/Info.plist @@ -0,0 +1,47 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleDocumentTypes + + + CFBundleTypeExtensions + + ???? + + CFBundleTypeIconFile + + CFBundleTypeName + DocumentType + CFBundleTypeOSTypes + + ???? + + CFBundleTypeRole + Editor + NSDocumentClass + MyDocument + + + CFBundleExecutable + PluginExpressionParser + CFBundleIconFile + + CFBundleIdentifier + com.apple.yourCocoaDocApp + CFBundleInfoDictionaryVersion + 6.0 + CFBundlePackageType + APPL + CFBundleSignature + ???? + CFBundleVersion + 0.1 + NSMainNibFile + MainMenu + NSPrincipalClass + NSApplication + + diff --git a/examples/objc/expression_parser/KeyValueParser.hs b/examples/objc/expression_parser/KeyValueParser.hs new file mode 100644 index 0000000..dada1a1 --- /dev/null +++ b/examples/objc/expression_parser/KeyValueParser.hs @@ -0,0 +1,33 @@ +module KeyValueParser where + +import Text.ParserCombinators.Parsec + +parseKeyValue = do + key <- parseKey + char '=' + value <- parseValue + return (key, value) + +parseKey = many1 letter + +parseValue = + do + openQuote <- char '"' <|> char '\'' + value <- many1 letter + char openQuote + return value + <|> + do + value <- many1 letter + return value + +parseString s = do + case (parse parseKeyValue "" s) of + Left err -> return ("Error " ++ show err) + Right (key, value) -> return ("Key: " ++ key ++ ", Value: " ++ value) + +resource :: String -> IO String +resource text = do + parsedText <- mapM parseString (lines text) + return (unlines parsedText) + diff --git a/examples/objc/expression_parser/Makefile b/examples/objc/expression_parser/Makefile new file mode 100644 index 0000000..5b368d7 --- /dev/null +++ b/examples/objc/expression_parser/Makefile @@ -0,0 +1,67 @@ +APP_DIR = build/PluginExpressionParser.app +APP_CONTENTS_DIR = $(APP_DIR)/Contents +APP_ARCH_EXEC_DIR = $(APP_CONTENTS_DIR)/MacOS +APP_RESOURCES_DIR = $(APP_CONTENTS_DIR)/Resources +EXECUTABLE = $(APP_ARCH_EXEC_DIR)/PluginExpressionParser + +OBJECT_FILES = main.o MyDocument.o PluginEvalAux.o +BUILD_OBJECT_FILES = $(addprefix build/,$(OBJECT_FILES)) \ + build/PluginEvalAux_stub.o + +HOST = $(shell uname) + +ifeq ($(HOST),Darwin) +default: app +else +default: no_app +endif + +app: $(APP_CONTENTS_DIR) $(APP_RESOURCES_DIR) $(EXECUTABLE) + +# + +$(EXECUTABLE): $(APP_ARCH_EXEC_DIR) $(BUILD_OBJECT_FILES) + ghc \ + -o "$(EXECUTABLE)" \ + -framework Cocoa \ + -package-conf ../../../plugins.conf.inplace \ + -package plugins \ + -no-hs-main \ + $(BUILD_OBJECT_FILES) + +build/MyDocument.o: MyDocument.m MyDocument.h + gcc -c -o "$@" -Wall -I`ghc --print-libdir`/include "$<" + +build/main.o: main.m + gcc -c -o "$@" -Wall -I`ghc --print-libdir`/include "$<" + +build/PluginEvalAux.o: PluginEvalAux.hs + ghc --make \ + -package-conf ../../../plugins.conf.inplace \ + -package plugins \ + -odir build/ \ + -hidir build/ \ + "$<" + +# + +$(APP_DIR): + mkdir -p "$@" + +$(APP_ARCH_EXEC_DIR): $(APP_DIR) + mkdir -p "$@" + +$(APP_CONTENTS_DIR): $(APP_DIR) Info.plist + mkdir -p "$(APP_CONTENTS_DIR)" + cp Info.plist "$@" + echo -n 'APPL????' > "$@"/PkgInfo + +$(APP_RESOURCES_DIR): $(APP_DIR) English.lproj + mkdir -p "$(APP_RESOURCES_DIR)" + cp -R English.lproj "$@" + +# + +clean: + -rm -rf build *_stub.? + diff --git a/examples/objc/expression_parser/MyDocument.h b/examples/objc/expression_parser/MyDocument.h new file mode 100644 index 0000000..6d0585f --- /dev/null +++ b/examples/objc/expression_parser/MyDocument.h @@ -0,0 +1,16 @@ +/* MyDocument */ + +#import + +#include "RunHaskell.h" + +@interface MyDocument : NSDocument +{ + IBOutlet id evaluation; + IBOutlet id expressionEntry; + IBOutlet id parser; +} +- (IBAction)chooseParser:(id)sender; +- (IBAction)evaluateExpression:(id)sender; + +@end diff --git a/examples/objc/expression_parser/MyDocument.m b/examples/objc/expression_parser/MyDocument.m new file mode 100644 index 0000000..b79b767 --- /dev/null +++ b/examples/objc/expression_parser/MyDocument.m @@ -0,0 +1,52 @@ +#import "MyDocument.h" + +@implementation MyDocument + +- (NSString *)windowNibName { + return @"MyDocument"; +} + +- (NSData *)dataRepresentationOfType:(NSString *)type { + return nil; +} + +- (BOOL)loadDataRepresentation:(NSData *)data ofType:(NSString *)type { + return NO; +} + + +- (IBAction)chooseParser:(id)sender +{ + int result; + NSArray *fileTypes = [NSArray arrayWithObject:@"hs"]; + NSOpenPanel *oPanel = [NSOpenPanel openPanel]; + + result = [oPanel runModalForDirectory:nil file:nil types:fileTypes]; + if (result == NSOKButton) + { + NSArray *filesToOpen = [oPanel filenames]; + [parser setStringValue:[filesToOpen objectAtIndex:0]]; + } +} + +- (IBAction)evaluateExpression:(id)sender +{ + NSLog(@"evaluateExpression"); + NSString *filePathNSS = [parser stringValue]; + char *filePath = [filePathNSS cString]; + + NSString *expressionNSS = [[expressionEntry textStorage] string]; + char *expression = [expressionNSS cString]; + + NSLog (@"filePath:%s expression:%s", filePath, expression); + + char *result = evalhaskell_CString(filePath, expression); + NSString *resultNSS = [NSString stringWithCString:result]; + NSAttributedString *resultNSAS = [[NSAttributedString alloc] + initWithString:resultNSS + attributes:nil]; + [[evaluation textStorage] setAttributedString:resultNSAS]; + +} + +@end diff --git a/examples/objc/expression_parser/PluginEvalAux.hs b/examples/objc/expression_parser/PluginEvalAux.hs new file mode 100644 index 0000000..3ffbefb --- /dev/null +++ b/examples/objc/expression_parser/PluginEvalAux.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -fglasgow-exts -fffi #-} + +module PluginEvalAux where + +import Plugins.Make +import Plugins.Load +import Plugins.Utils + +import Foreign.C +import Control.Exception ( evaluate ) +import System.IO +import System.Directory ( renameFile, removeFile ) + +symbol = "resource" + +evalWithStringResult :: FilePath -> String -> IO String +evalWithStringResult srcFile s = do + status <- make srcFile ["-Onot"] + case status of + MakeFailure err -> putStrLn "error occured" >> return (show err) + MakeSuccess _ obj -> load' obj + where + load' obj = do + loadResult <- load obj [] [] symbol + case loadResult of + LoadFailure errs -> putStrLn "load error" >> return (show errs) + LoadSuccess m (rsrc :: String -> IO String) -> do + v' <- rsrc s + unload m + mapM_ removeFile [ obj, replaceSuffix obj ".hi" ] + return v' + +foreign export ccall evalhaskell_CString :: CString -> CString -> IO CString + +evalhaskell_CString :: CString -> CString -> IO CString +evalhaskell_CString filePathCS sCS = do + s <- peekCString sCS + filePath <- peekCString filePathCS + retval <- evalWithStringResult filePath s + newCString retval + +-- vi:sw=2 sts=2 + diff --git a/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj b/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj new file mode 100644 index 0000000..ede92e6 --- /dev/null +++ b/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj @@ -0,0 +1,602 @@ +// !$*UTF8*$! +{ + archiveVersion = 1; + classes = { + }; + objectVersion = 39; + objects = { + 089C165FFE840EACC02AAC07 = { + children = ( + 089C1660FE840EACC02AAC07, + ); + isa = PBXVariantGroup; + name = InfoPlist.strings; + refType = 4; + sourceTree = ""; + }; + 089C1660FE840EACC02AAC07 = { + fileEncoding = 10; + isa = PBXFileReference; + lastKnownFileType = text.plist.strings; + name = English; + path = English.lproj/InfoPlist.strings; + refType = 4; + sourceTree = ""; + }; +//080 +//081 +//082 +//083 +//084 +//100 +//101 +//102 +//103 +//104 + 1058C7A6FEA54F5311CA2CBB = { + children = ( + 1058C7A7FEA54F5311CA2CBB, + ); + isa = PBXGroup; + name = "Linked Frameworks"; + refType = 4; + sourceTree = ""; + }; + 1058C7A7FEA54F5311CA2CBB = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = Cocoa.framework; + path = /System/Library/Frameworks/Cocoa.framework; + refType = 0; + sourceTree = ""; + }; + 1058C7A8FEA54F5311CA2CBB = { + children = ( + 2A37F4C5FDCFA73011CA2CEA, + 2A37F4C4FDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = "Other Frameworks"; + refType = 4; + sourceTree = ""; + }; +//100 +//101 +//102 +//103 +//104 +//190 +//191 +//192 +//193 +//194 + 19C28FB0FE9D524F11CA2CBB = { + children = ( + 8D15AC370486D014006FF6A4, + ); + isa = PBXGroup; + name = Products; + refType = 4; + sourceTree = ""; + }; +//190 +//191 +//192 +//193 +//194 +//2A0 +//2A1 +//2A2 +//2A3 +//2A4 + 2A37F4A9FDCFA73011CA2CEA = { + buildSettings = { + }; + buildStyles = ( + 4A9504D0FFE6A4CB11CA0CBA, + 4A9504D1FFE6A4CB11CA0CBA, + ); + hasScannedForEncodings = 1; + isa = PBXProject; + mainGroup = 2A37F4AAFDCFA73011CA2CEA; + projectDirPath = ""; + targets = ( + 8D15AC270486D014006FF6A4, + 7B5F81A4067389B000AC9FA4, + ); + }; + 2A37F4AAFDCFA73011CA2CEA = { + children = ( + 7B5F81A1067383A700AC9FA4, + 7B5F81980673839D00AC9FA4, + 2A37F4ABFDCFA73011CA2CEA, + 2A37F4AFFDCFA73011CA2CEA, + 2A37F4B8FDCFA73011CA2CEA, + 2A37F4C3FDCFA73011CA2CEA, + 19C28FB0FE9D524F11CA2CBB, + ); + isa = PBXGroup; + name = PluginExpressionParser; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4ABFDCFA73011CA2CEA = { + children = ( + 2A37F4AEFDCFA73011CA2CEA, + 2A37F4ACFDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = Classes; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4ACFDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.objc; + path = MyDocument.m; + refType = 4; + sourceTree = ""; + }; + 2A37F4AEFDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = MyDocument.h; + refType = 4; + sourceTree = ""; + }; + 2A37F4AFFDCFA73011CA2CEA = { + children = ( + 7B5F81990673839D00AC9FA4, + 32DBCF750370BD2300C91783, + 7B5F819506737AAC00AC9FA4, + 2A37F4B0FDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = "Other Sources"; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B0FDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.objc; + path = main.m; + refType = 4; + sourceTree = ""; + }; + 2A37F4B4FDCFA73011CA2CEA = { + children = ( + 2A37F4B5FDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = MyDocument.nib; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B5FDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = wrapper.nib; + name = English; + path = English.lproj/MyDocument.nib; + refType = 4; + sourceTree = ""; + }; + 2A37F4B6FDCFA73011CA2CEA = { + children = ( + 2A37F4B7FDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = MainMenu.nib; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B7FDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = wrapper.nib; + name = English; + path = English.lproj/MainMenu.nib; + refType = 4; + sourceTree = ""; + }; + 2A37F4B8FDCFA73011CA2CEA = { + children = ( + 2A37F4B9FDCFA73011CA2CEA, + 2A37F4B6FDCFA73011CA2CEA, + 2A37F4B4FDCFA73011CA2CEA, + 8D15AC360486D014006FF6A4, + 089C165FFE840EACC02AAC07, + ); + isa = PBXGroup; + name = Resources; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B9FDCFA73011CA2CEA = { + children = ( + 2A37F4BAFDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = Credits.rtf; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4BAFDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = text.rtf; + name = English; + path = English.lproj/Credits.rtf; + refType = 4; + sourceTree = ""; + }; + 2A37F4C3FDCFA73011CA2CEA = { + children = ( + 1058C7A6FEA54F5311CA2CBB, + 1058C7A8FEA54F5311CA2CBB, + ); + isa = PBXGroup; + name = Frameworks; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4C4FDCFA73011CA2CEA = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = AppKit.framework; + path = /System/Library/Frameworks/AppKit.framework; + refType = 0; + sourceTree = ""; + }; + 2A37F4C5FDCFA73011CA2CEA = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = Foundation.framework; + path = /System/Library/Frameworks/Foundation.framework; + refType = 0; + sourceTree = ""; + }; +//2A0 +//2A1 +//2A2 +//2A3 +//2A4 +//320 +//321 +//322 +//323 +//324 + 32DBCF750370BD2300C91783 = { + fileEncoding = 4; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = PluginExpressionParser_Prefix.pch; + refType = 4; + sourceTree = ""; + }; +//320 +//321 +//322 +//323 +//324 +//4A0 +//4A1 +//4A2 +//4A3 +//4A4 + 4A9504D0FFE6A4CB11CA0CBA = { + buildRules = ( + ); + buildSettings = { + COPY_PHASE_STRIP = NO; + DEBUGGING_SYMBOLS = YES; + GCC_DYNAMIC_NO_PIC = NO; + GCC_ENABLE_FIX_AND_CONTINUE = YES; + GCC_GENERATE_DEBUGGING_SYMBOLS = YES; + GCC_OPTIMIZATION_LEVEL = 0; + OPTIMIZATION_CFLAGS = "-O0"; + ZERO_LINK = YES; + }; + isa = PBXBuildStyle; + name = Development; + }; + 4A9504D1FFE6A4CB11CA0CBA = { + buildRules = ( + ); + buildSettings = { + COPY_PHASE_STRIP = YES; + GCC_ENABLE_FIX_AND_CONTINUE = NO; + ZERO_LINK = NO; + }; + isa = PBXBuildStyle; + name = Deployment; + }; +//4A0 +//4A1 +//4A2 +//4A3 +//4A4 +//7B0 +//7B1 +//7B2 +//7B3 +//7B4 + 7B5F819506737AAC00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = RunHaskell.h; + refType = 4; + sourceTree = ""; + }; + 7B5F819606737AAC00AC9FA4 = { + fileRef = 7B5F819506737AAC00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F81970673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = KeyValueParser.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F81980673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.make; + path = Makefile; + refType = 4; + sourceTree = ""; + }; + 7B5F81990673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = PluginEvalAux.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F819A0673839D00AC9FA4 = { + fileRef = 7B5F81970673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819B0673839D00AC9FA4 = { + fileRef = 7B5F81980673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819C0673839D00AC9FA4 = { + fileRef = 7B5F81990673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819D067383A400AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = ArithmeticExpressionParser.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F819E067383A400AC9FA4 = { + fileRef = 7B5F819D067383A400AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F81A1067383A700AC9FA4 = { + children = ( + 7B5F819D067383A400AC9FA4, + 7B5F81970673839D00AC9FA4, + ); + isa = PBXGroup; + name = Parsers; + refType = 4; + sourceTree = ""; + }; + 7B5F81A4067389B000AC9FA4 = { + buildArgumentsString = "$(ACTION)"; + buildPhases = ( + ); + buildSettings = { + OPTIMIZATION_CFLAGS = ""; + OTHER_CFLAGS = ""; + OTHER_LDFLAGS = ""; + OTHER_REZFLAGS = ""; + PRODUCT_NAME = "PluginExpressionParser (GNU make)"; + SECTORDER_FLAGS = ""; + WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas"; + }; + buildToolPath = /usr/bin/make; + dependencies = ( + ); + isa = PBXLegacyTarget; + name = "PluginExpressionParser (GNU make)"; + passBuildSettingsInEnvironment = 1; + productName = "PluginExpressionParser (GNU make)"; + }; +//7B0 +//7B1 +//7B2 +//7B3 +//7B4 +//8D0 +//8D1 +//8D2 +//8D3 +//8D4 + 8D15AC270486D014006FF6A4 = { + buildPhases = ( + 8D15AC280486D014006FF6A4, + 8D15AC2B0486D014006FF6A4, + 8D15AC300486D014006FF6A4, + 8D15AC330486D014006FF6A4, + ); + buildRules = ( + ); + buildSettings = { + FRAMEWORK_SEARCH_PATHS = ""; + GCC_ENABLE_TRIGRAPHS = NO; + GCC_GENERATE_DEBUGGING_SYMBOLS = NO; + GCC_PRECOMPILE_PREFIX_HEADER = YES; + GCC_PREFIX_HEADER = PluginExpressionParser_Prefix.pch; + GCC_WARN_ABOUT_MISSING_PROTOTYPES = NO; + GCC_WARN_FOUR_CHARACTER_CONSTANTS = NO; + GCC_WARN_UNKNOWN_PRAGMAS = NO; + HEADER_SEARCH_PATHS = ""; + INFOPLIST_FILE = Info.plist; + INSTALL_PATH = "$(HOME)/Applications"; + LIBRARY_SEARCH_PATHS = ""; + OTHER_CFLAGS = ""; + OTHER_LDFLAGS = ""; + PRODUCT_NAME = PluginExpressionParser; + SECTORDER_FLAGS = ""; + WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas"; + WRAPPER_EXTENSION = app; + }; + dependencies = ( + ); + isa = PBXNativeTarget; + name = PluginExpressionParser; + productInstallPath = "$(HOME)/Applications"; + productName = PluginExpressionParser; + productReference = 8D15AC370486D014006FF6A4; + productType = "com.apple.product-type.application"; + }; + 8D15AC280486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC290486D014006FF6A4, + 8D15AC2A0486D014006FF6A4, + 7B5F819606737AAC00AC9FA4, + ); + isa = PBXHeadersBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC290486D014006FF6A4 = { + fileRef = 32DBCF750370BD2300C91783; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2A0486D014006FF6A4 = { + fileRef = 2A37F4AEFDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2B0486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC2C0486D014006FF6A4, + 8D15AC2D0486D014006FF6A4, + 8D15AC2E0486D014006FF6A4, + 8D15AC2F0486D014006FF6A4, + 7B5F819A0673839D00AC9FA4, + 7B5F819B0673839D00AC9FA4, + 7B5F819C0673839D00AC9FA4, + 7B5F819E067383A400AC9FA4, + ); + isa = PBXResourcesBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC2C0486D014006FF6A4 = { + fileRef = 2A37F4B9FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2D0486D014006FF6A4 = { + fileRef = 2A37F4B6FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2E0486D014006FF6A4 = { + fileRef = 2A37F4B4FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2F0486D014006FF6A4 = { + fileRef = 089C165FFE840EACC02AAC07; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC300486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC310486D014006FF6A4, + 8D15AC320486D014006FF6A4, + ); + isa = PBXSourcesBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC310486D014006FF6A4 = { + fileRef = 2A37F4ACFDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + ATTRIBUTES = ( + ); + }; + }; + 8D15AC320486D014006FF6A4 = { + fileRef = 2A37F4B0FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + ATTRIBUTES = ( + ); + }; + }; + 8D15AC330486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC340486D014006FF6A4, + ); + isa = PBXFrameworksBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC340486D014006FF6A4 = { + fileRef = 1058C7A7FEA54F5311CA2CBB; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC360486D014006FF6A4 = { + fileEncoding = 4; + isa = PBXFileReference; + lastKnownFileType = text.plist; + path = Info.plist; + refType = 4; + sourceTree = ""; + }; + 8D15AC370486D014006FF6A4 = { + explicitFileType = wrapper.application; + includeInIndex = 0; + isa = PBXFileReference; + path = PluginExpressionParser.app; + refType = 3; + sourceTree = BUILT_PRODUCTS_DIR; + }; + }; + rootObject = 2A37F4A9FDCFA73011CA2CEA; +} diff --git a/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch b/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch new file mode 100644 index 0000000..4d1db1d --- /dev/null +++ b/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch @@ -0,0 +1,7 @@ +// +// Prefix header for all source files of the 'PluginExpressionParser' target in the 'PluginExpressionParser' project +// + +#ifdef __OBJC__ + #import +#endif diff --git a/examples/objc/expression_parser/README b/examples/objc/expression_parser/README new file mode 100644 index 0000000..eb902c3 --- /dev/null +++ b/examples/objc/expression_parser/README @@ -0,0 +1,6 @@ +This little application is an example of using hs-plugins to embed a Haskell +'interpreter' inside an Objective-C, Cocoa-based program. You will need Mac OS +X for this to be of any use! + +To build it, type 'make', which will build a .app bundle in the build/ directory. Or, 'open *.xcode', and hit the build button in there. + diff --git a/examples/objc/expression_parser/RunHaskell.h b/examples/objc/expression_parser/RunHaskell.h new file mode 100644 index 0000000..40c781d --- /dev/null +++ b/examples/objc/expression_parser/RunHaskell.h @@ -0,0 +1,4 @@ +#include "HsFFI.h" + +extern HsPtr evalhaskell_CString(HsPtr a1, HsPtr a2); + diff --git a/examples/objc/expression_parser/dont_test b/examples/objc/expression_parser/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/objc/expression_parser/main.m b/examples/objc/expression_parser/main.m new file mode 100644 index 0000000..26b35dd --- /dev/null +++ b/examples/objc/expression_parser/main.m @@ -0,0 +1,26 @@ +// +// main.m +// PluginExpressionParser +// +// Created by AndrŽ Pang on Mon Jun 07 2004. +// Copyright (c) 2004 __MyCompanyName__. All rights reserved. +// + +#import + +#include "HsFFI.h" + +extern void __stginit_PluginEvalAux (void); + +int main(int argc, char *argv[]) +{ + hs_init(&argc, &argv); + hs_add_root(__stginit_PluginEvalAux); + const char *c_argv = (const char *) argv; + int retval = NSApplicationMain(argc, &c_argv); + hs_exit(); + return retval; +} + +/* vi:sw=4 */ + diff --git a/examples/objc/expression_parser/version.plist b/examples/objc/expression_parser/version.plist new file mode 100644 index 0000000..a293201 --- /dev/null +++ b/examples/objc/expression_parser/version.plist @@ -0,0 +1,16 @@ + + + + + BuildVersion + 17 + CFBundleShortVersionString + 0.1 + CFBundleVersion + 0.1 + ProjectName + NibPBTemplates + SourceVersion + 1150000 + + diff --git a/examples/pdynload/badint/Makefile b/examples/pdynload/badint/Makefile new file mode 100644 index 0000000..3b2a729 --- /dev/null +++ b/examples/pdynload/badint/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/badint + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/badint/Plugin.hs b/examples/pdynload/badint/Plugin.hs new file mode 100644 index 0000000..8cfe36d --- /dev/null +++ b/examples/pdynload/badint/Plugin.hs @@ -0,0 +1,4 @@ +module Plugin where + +resource :: Num t => t +resource = 0xBAD diff --git a/examples/pdynload/badint/api/API.hs b/examples/pdynload/badint/api/API.hs new file mode 100644 index 0000000..7198219 --- /dev/null +++ b/examples/pdynload/badint/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + transform :: String -> String + } + +rsrc :: Interface +rsrc = Interface { transform = id } + diff --git a/examples/pdynload/badint/prog/Main.hs b/examples/pdynload/badint/prog/Main.hs new file mode 100644 index 0000000..e60e2bf --- /dev/null +++ b/examples/pdynload/badint/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e-> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn $ (transform a) "foo" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/badint/prog/expected b/examples/pdynload/badint/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/badint/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/null/Makefile b/examples/pdynload/null/Makefile new file mode 100644 index 0000000..3589848 --- /dev/null +++ b/examples/pdynload/null/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/null +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/null/Plugin.hs b/examples/pdynload/null/Plugin.hs new file mode 100644 index 0000000..465d956 --- /dev/null +++ b/examples/pdynload/null/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = D 1 diff --git a/examples/pdynload/null/api/API.hs b/examples/pdynload/null/api/API.hs new file mode 100644 index 0000000..a3b8d8e --- /dev/null +++ b/examples/pdynload/null/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/examples/pdynload/null/prog/Main.hs b/examples/pdynload/null/prog/Main.hs new file mode 100644 index 0000000..3c3f831 --- /dev/null +++ b/examples/pdynload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import Plugins.Utils +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e-> mapM_ putStrLn e + + where f = do v <- load "../Plugin.o" ["../api"] [] "resource" + -- (i,_) <- exec "ghc" ["--numeric-version"] + -- mapM_ putStrLn i + putStrLn "done." + diff --git a/examples/pdynload/null/prog/expected b/examples/pdynload/null/prog/expected new file mode 100644 index 0000000..70ff8e5 --- /dev/null +++ b/examples/pdynload/null/prog/expected @@ -0,0 +1 @@ +done. diff --git a/examples/pdynload/numclass/Makefile b/examples/pdynload/numclass/Makefile new file mode 100644 index 0000000..6681e6a --- /dev/null +++ b/examples/pdynload/numclass/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/numclass +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/numclass/Plugin.hs b/examples/pdynload/numclass/Plugin.hs new file mode 100644 index 0000000..fcbd7b8 --- /dev/null +++ b/examples/pdynload/numclass/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +-- import API + +resource = "error" diff --git a/examples/pdynload/numclass/api/API.hs b/examples/pdynload/numclass/api/API.hs new file mode 100644 index 0000000..a3b8d8e --- /dev/null +++ b/examples/pdynload/numclass/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/examples/pdynload/numclass/prog/Main.hs b/examples/pdynload/numclass/prog/Main.hs new file mode 100644 index 0000000..0f4f515 --- /dev/null +++ b/examples/pdynload/numclass/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeFailure _ -> putStrLn "make failed" + MakeSuccess _ _ -> do { + + ;v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface Integer" "resource" + ;case v of + LoadSuccess _ a -> let D i = snd a in putStrLn $ show i + _ -> putStrLn "wrong types" + + } diff --git a/examples/pdynload/numclass/prog/expected b/examples/pdynload/numclass/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/numclass/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/poly/Makefile b/examples/pdynload/poly/Makefile new file mode 100644 index 0000000..ebdb53b --- /dev/null +++ b/examples/pdynload/poly/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/poly + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/poly/Plugin.hs b/examples/pdynload/poly/Plugin.hs new file mode 100644 index 0000000..c65d495 --- /dev/null +++ b/examples/pdynload/poly/Plugin.hs @@ -0,0 +1,9 @@ +module Plugin where + +import Data.Generics.Schemes + +import API + +resource = rsrc { + field = id listify +} diff --git a/examples/pdynload/poly/api/API.hs b/examples/pdynload/poly/api/API.hs new file mode 100644 index 0000000..1cabdab --- /dev/null +++ b/examples/pdynload/poly/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} +-- a really nasty type: + +module API where + +import Data.Generics + +data Interface = Interface { field :: Typeable r => (r -> Bool) -> GenericQ [r] } + +rsrc :: Interface +rsrc = Interface { field = listify } + diff --git a/examples/pdynload/poly/prog/Main.hs b/examples/pdynload/poly/prog/Main.hs new file mode 100644 index 0000000..00c61a1 --- /dev/null +++ b/examples/pdynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/poly/prog/expected b/examples/pdynload/poly/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/poly/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/poly1/Makefile b/examples/pdynload/poly1/Makefile new file mode 100644 index 0000000..6d6440e --- /dev/null +++ b/examples/pdynload/poly1/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/poly1 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/poly1/Plugin.hs b/examples/pdynload/poly1/Plugin.hs new file mode 100644 index 0000000..af7585e --- /dev/null +++ b/examples/pdynload/poly1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) } diff --git a/examples/pdynload/poly1/api/API.hs b/examples/pdynload/poly1/api/API.hs new file mode 100644 index 0000000..c551700 --- /dev/null +++ b/examples/pdynload/poly1/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: (Num a) => a -> a -> a +} + +plugin :: Interface +plugin = Interface { function = error "no function defined" } + diff --git a/examples/pdynload/poly1/prog/Main.hs b/examples/pdynload/poly1/prog/Main.hs new file mode 100644 index 0000000..98c72e7 --- /dev/null +++ b/examples/pdynload/poly1/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> let fn = function a in putStrLn $ show $ 1 `fn` 2 + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/poly1/prog/expected b/examples/pdynload/poly1/prog/expected new file mode 100644 index 0000000..00750ed --- /dev/null +++ b/examples/pdynload/poly1/prog/expected @@ -0,0 +1 @@ +3 diff --git a/examples/pdynload/should_fail0/Makefile b/examples/pdynload/should_fail0/Makefile new file mode 100644 index 0000000..30ef2c1 --- /dev/null +++ b/examples/pdynload/should_fail0/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/should_fail0 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/should_fail0/Plugin.hs b/examples/pdynload/should_fail0/Plugin.hs new file mode 100644 index 0000000..f7998f9 --- /dev/null +++ b/examples/pdynload/should_fail0/Plugin.hs @@ -0,0 +1,9 @@ +module Plugin where + +import API + +resource = 0xBAD :: Int + +-- resource = tiny { +-- field = "hello strange world" +-- } diff --git a/examples/pdynload/should_fail0/api/API.hs b/examples/pdynload/should_fail0/api/API.hs new file mode 100644 index 0000000..ad0a0a3 --- /dev/null +++ b/examples/pdynload/should_fail0/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Interface = Interface { field :: String } + deriving (Show) + +rsrc :: Interface +rsrc = Interface { field = "default value" } + diff --git a/examples/pdynload/should_fail0/prog/Main.hs b/examples/pdynload/should_fail0/prog/Main.hs new file mode 100644 index 0000000..ed9bb2c --- /dev/null +++ b/examples/pdynload/should_fail0/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + where + f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/should_fail0/prog/expected b/examples/pdynload/should_fail0/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/should_fail0/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/should_fail1/Makefile b/examples/pdynload/should_fail1/Makefile new file mode 100644 index 0000000..207da6e --- /dev/null +++ b/examples/pdynload/should_fail1/Makefile @@ -0,0 +1,5 @@ +# Missing class constraint... can't do that in Clean + +TEST= pdynload/should_fail1 +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/should_fail1/Plugin.hs b/examples/pdynload/should_fail1/Plugin.hs new file mode 100644 index 0000000..c73d571 --- /dev/null +++ b/examples/pdynload/should_fail1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +data I = I Int + +resource = I 1 diff --git a/examples/pdynload/should_fail1/api/API.hs b/examples/pdynload/should_fail1/api/API.hs new file mode 100644 index 0000000..50380ee --- /dev/null +++ b/examples/pdynload/should_fail1/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +newtype Interface = I Int + +rsrc :: Interface +rsrc = I 1 + diff --git a/examples/pdynload/should_fail1/prog/Main.hs b/examples/pdynload/should_fail1/prog/Main.hs new file mode 100644 index 0000000..5b02b81 --- /dev/null +++ b/examples/pdynload/should_fail1/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/should_fail1/prog/expected b/examples/pdynload/should_fail1/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/should_fail1/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/small/Makefile b/examples/pdynload/small/Makefile new file mode 100644 index 0000000..c142a87 --- /dev/null +++ b/examples/pdynload/small/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/small +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/small/Plugin.hs b/examples/pdynload/small/Plugin.hs new file mode 100644 index 0000000..a30c85d --- /dev/null +++ b/examples/pdynload/small/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = "good" } diff --git a/examples/pdynload/small/api/API.hs b/examples/pdynload/small/api/API.hs new file mode 100644 index 0000000..101d6d9 --- /dev/null +++ b/examples/pdynload/small/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: String +} + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/pdynload/small/prog/Main.hs b/examples/pdynload/small/prog/Main.hs new file mode 100644 index 0000000..001c5da --- /dev/null +++ b/examples/pdynload/small/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/small/prog/expected b/examples/pdynload/small/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/small/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/spj1/Makefile b/examples/pdynload/spj1/Makefile new file mode 100644 index 0000000..b0cfd89 --- /dev/null +++ b/examples/pdynload/spj1/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj1/Plugin.hs b/examples/pdynload/spj1/Plugin.hs new file mode 100644 index 0000000..d753ed9 --- /dev/null +++ b/examples/pdynload/spj1/Plugin.hs @@ -0,0 +1,17 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +-- import API +-- resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a + +-- import API + +resource :: Num a => a +resource = 7 diff --git a/examples/pdynload/spj1/api/API.hs b/examples/pdynload/spj1/api/API.hs new file mode 100644 index 0000000..111fc82 --- /dev/null +++ b/examples/pdynload/spj1/api/API.hs @@ -0,0 +1,9 @@ + +module API where + +-- data Interface = Interface { field :: Int } + +-- newtype Interface = Interface Int + +type Interface = Int + diff --git a/examples/pdynload/spj1/dont_test b/examples/pdynload/spj1/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/pdynload/spj1/prog/Main.hs b/examples/pdynload/spj1/prog/Main.hs new file mode 100644 index 0000000..7cea83c --- /dev/null +++ b/examples/pdynload/spj1/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> print $ a -- will crash + LoadFailure es -> putStrLn $ show es diff --git a/examples/pdynload/spj1/prog/expected b/examples/pdynload/spj1/prog/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/pdynload/spj2/Makefile b/examples/pdynload/spj2/Makefile new file mode 100644 index 0000000..b0cfd89 --- /dev/null +++ b/examples/pdynload/spj2/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj2/Plugin.hs b/examples/pdynload/spj2/Plugin.hs new file mode 100644 index 0000000..eca2a0d --- /dev/null +++ b/examples/pdynload/spj2/Plugin.hs @@ -0,0 +1,13 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +import API +resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a +resource = 7 diff --git a/examples/pdynload/spj2/api/API.hs b/examples/pdynload/spj2/api/API.hs new file mode 100644 index 0000000..cd017bf --- /dev/null +++ b/examples/pdynload/spj2/api/API.hs @@ -0,0 +1,6 @@ + +module API where + +-- simple type +type Interface = Int + diff --git a/examples/pdynload/spj2/prog/Main.hs b/examples/pdynload/spj2/prog/Main.hs new file mode 100644 index 0000000..3eb236e --- /dev/null +++ b/examples/pdynload/spj2/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> putStrLn $ show a -- will crash + LoadFailure es -> putStrLn $ show es diff --git a/examples/pdynload/spj2/prog/expected b/examples/pdynload/spj2/prog/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/pdynload/spj2/prog/expected @@ -0,0 +1 @@ +7 diff --git a/examples/pdynload/spj3/Makefile b/examples/pdynload/spj3/Makefile new file mode 100644 index 0000000..79e5015 --- /dev/null +++ b/examples/pdynload/spj3/Makefile @@ -0,0 +1,3 @@ +TEST= pdynload/spj3 +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj3/Plugin.hs b/examples/pdynload/spj3/Plugin.hs new file mode 100644 index 0000000..b1f6297 --- /dev/null +++ b/examples/pdynload/spj3/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) :: Int -> Int -> Int } diff --git a/examples/pdynload/spj3/api/API.hs b/examples/pdynload/spj3/api/API.hs new file mode 100644 index 0000000..c551700 --- /dev/null +++ b/examples/pdynload/spj3/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: (Num a) => a -> a -> a +} + +plugin :: Interface +plugin = Interface { function = error "no function defined" } + diff --git a/examples/pdynload/spj3/prog/Main.hs b/examples/pdynload/spj3/prog/Main.hs new file mode 100644 index 0000000..98c72e7 --- /dev/null +++ b/examples/pdynload/spj3/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> let fn = function a in putStrLn $ show $ 1 `fn` 2 + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/spj3/prog/expected b/examples/pdynload/spj3/prog/expected new file mode 100644 index 0000000..72db92b --- /dev/null +++ b/examples/pdynload/spj3/prog/expected @@ -0,0 +1,8 @@ + +../Plugin.hs:5: + Cannot unify the type-signature variable `a' with the type `Int' + Expected type: a -> a -> a + Inferred type: Int -> Int -> Int + When checking the type signature of the expression: + (+) :: Int -> Int -> Int + In the `function' field of a record diff --git a/examples/pdynload/spj3/prog/expected.604 b/examples/pdynload/spj3/prog/expected.604 new file mode 100644 index 0000000..6e0b917 --- /dev/null +++ b/examples/pdynload/spj3/prog/expected.604 @@ -0,0 +1,9 @@ + +../Plugin.hs:5:31: + Couldn't match the rigid variable `a' against `Int' + `a' is bound by the polymorphic type `forall a. (Num a) => a -> a -> a' + at ../Plugin.hs:5:11-56 + Expected type: a -> a -> a + Inferred type: Int -> Int -> Int + In the expression: (+) :: Int -> Int -> Int + In the `function' field of a record diff --git a/examples/pdynload/spj4/Makefile b/examples/pdynload/spj4/Makefile new file mode 100644 index 0000000..95fe9fe --- /dev/null +++ b/examples/pdynload/spj4/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj4 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj4/Plugin.hs b/examples/pdynload/spj4/Plugin.hs new file mode 100644 index 0000000..e81f688 --- /dev/null +++ b/examples/pdynload/spj4/Plugin.hs @@ -0,0 +1,16 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +-- import API +-- resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a + +import API + +resource = Interface { field = 7 :: Num a => a } diff --git a/examples/pdynload/spj4/api/API.hs b/examples/pdynload/spj4/api/API.hs new file mode 100644 index 0000000..ae5a35a --- /dev/null +++ b/examples/pdynload/spj4/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +newtype Interface = Interface { field :: Int } + diff --git a/examples/pdynload/spj4/prog/Main.hs b/examples/pdynload/spj4/prog/Main.hs new file mode 100644 index 0000000..7a138e1 --- /dev/null +++ b/examples/pdynload/spj4/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> error "there was a type error" + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> print $ field a -- will crash + LoadFailure es -> mapM_ putStrLn es diff --git a/examples/pdynload/spj4/prog/expected b/examples/pdynload/spj4/prog/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/pdynload/spj4/prog/expected @@ -0,0 +1 @@ +7 diff --git a/examples/pdynload/typealias/Makefile b/examples/pdynload/typealias/Makefile new file mode 100644 index 0000000..dfd644b --- /dev/null +++ b/examples/pdynload/typealias/Makefile @@ -0,0 +1,5 @@ +# Missing class constraint... can't do that in Clean + +TEST= pdynload/typealias +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/typealias/Plugin.hs b/examples/pdynload/typealias/Plugin.hs new file mode 100644 index 0000000..de60ef2 --- /dev/null +++ b/examples/pdynload/typealias/Plugin.hs @@ -0,0 +1,3 @@ +module Plugin where + +resource = 1 :: Int diff --git a/examples/pdynload/typealias/api/API.hs b/examples/pdynload/typealias/api/API.hs new file mode 100644 index 0000000..8502215 --- /dev/null +++ b/examples/pdynload/typealias/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +type Interface = Int + +rsrc :: Interface +rsrc = 1 + diff --git a/examples/pdynload/typealias/prog/Main.hs b/examples/pdynload/typealias/prog/Main.hs new file mode 100644 index 0000000..9f30df5 --- /dev/null +++ b/examples/pdynload/typealias/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + + diff --git a/examples/pdynload/typealias/prog/expected b/examples/pdynload/typealias/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/typealias/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/univquant/Makefile b/examples/pdynload/univquant/Makefile new file mode 100644 index 0000000..e96b597 --- /dev/null +++ b/examples/pdynload/univquant/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/univquant +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/univquant/Plugin.hs b/examples/pdynload/univquant/Plugin.hs new file mode 100644 index 0000000..8e88cea --- /dev/null +++ b/examples/pdynload/univquant/Plugin.hs @@ -0,0 +1,8 @@ +module Plugin where + +import API + +resource = plugin { function = my_id } + +my_id :: forall a. a -> a +my_id x = x diff --git a/examples/pdynload/univquant/api/API.hs b/examples/pdynload/univquant/api/API.hs new file mode 100644 index 0000000..31bdac8 --- /dev/null +++ b/examples/pdynload/univquant/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: forall a. a -> a +} + +plugin :: Interface +plugin = Interface { function = id } + diff --git a/examples/pdynload/univquant/prog/Main.hs b/examples/pdynload/univquant/prog/Main.hs new file mode 100644 index 0000000..7aca2d4 --- /dev/null +++ b/examples/pdynload/univquant/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/univquant/prog/expected b/examples/pdynload/univquant/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/univquant/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pkgconf/null/Makefile b/examples/pkgconf/null/Makefile new file mode 100644 index 0000000..810d1e6 --- /dev/null +++ b/examples/pkgconf/null/Makefile @@ -0,0 +1,16 @@ +all: + @echo "test disabled" + +#true_api:: +# ( cd api ;\ +# $(GHC) -Onot $(EXTRAFLAGS) -c $(API).hs ;\ +# $(RM) -f libHSapi.a ;\ +# $(AR) cq libHSapi.a API.o ;\ +# $(RANLIB) libHSapi.a ;\ +# $(LD) -r $(LD_X) $(WHOLE_ARCHIVE_FLAG) -o HSapi.o libHSapi.a ;\ +# rm API.o ;\ +# echo [] > package.conf ;\ +# env PREFIX=`pwd` $(GHC_PKG) -f package.conf -u < package.conf.in ) +# $(GHC) -package-conf ${TOP}/plugins.conf.inplace -package plugins \ +# -package-conf api/package.conf -package api \ +# -O $(EXTRAFLAGS) -c Null.hs diff --git a/examples/pkgconf/null/Null.hs b/examples/pkgconf/null/Null.hs new file mode 100644 index 0000000..7f9b962 --- /dev/null +++ b/examples/pkgconf/null/Null.hs @@ -0,0 +1,6 @@ +module Null ( resource ) where + +import API + +resource = plugin { a = 7 } + diff --git a/examples/pkgconf/null/api/API.hs b/examples/pkgconf/null/api/API.hs new file mode 100644 index 0000000..0b1624a --- /dev/null +++ b/examples/pkgconf/null/api/API.hs @@ -0,0 +1,10 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +data Null = Null { a, b :: Int } + deriving Show + +plugin :: Null +plugin = Null { a = 42 , b = 1 } + diff --git a/examples/pkgconf/null/api/package.conf.in b/examples/pkgconf/null/api/package.conf.in new file mode 100644 index 0000000..f037800 --- /dev/null +++ b/examples/pkgconf/null/api/package.conf.in @@ -0,0 +1,18 @@ +Package { + name = "api", + auto = False, + + import_dirs = [ "${PREFIX}" ], + library_dirs = [ "${PREFIX}" ], + hs_libraries = [ "HSapi" ], + + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} + diff --git a/examples/pkgconf/null/dont_test b/examples/pkgconf/null/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/pkgconf/null/prog/Main.hs b/examples/pkgconf/null/prog/Main.hs new file mode 100644 index 0000000..cbe81ac --- /dev/null +++ b/examples/pkgconf/null/prog/Main.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + let includes = TOP ++ "/examples/load/null/api" + (_,v) <- load "../Null.o" ["."] ["../api/package.conf"] "resource" + putStrLn ( show (a v) ) + diff --git a/examples/popen/test1/Main.hs b/examples/popen/test1/Main.hs new file mode 100644 index 0000000..befda24 --- /dev/null +++ b/examples/popen/test1/Main.hs @@ -0,0 +1,10 @@ +-- +-- test the popen function +-- + +import Plugins.Utils +import System.IO + +main = do + (sout,serr) <- exec "date" [] + mapM_ putStrLn serr diff --git a/examples/popen/test1/Makefile b/examples/popen/test1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/popen/test1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/popen/test1/expected b/examples/popen/test1/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/printf/000/Main.hs b/examples/printf/000/Main.hs new file mode 100644 index 0000000..67788aa --- /dev/null +++ b/examples/printf/000/Main.hs @@ -0,0 +1,37 @@ +import Printf + +main = do printf "%d\n" $> (42::Int) ! [] + printf "%u\n" $> (42::Int) ! [] + printf "0%o\n" $> (42::Int) ! [] + printf "0x%x\n" $> (42::Int) ! [] + printf "0x%X\n" $> (42::Int) ! [] + + printf "%e\n" $> (42.1234 :: Double) ! [] + printf "%E\n" $> (42.1234 :: Double) ! [] + printf "%g\n" $> (42.1234 :: Double) ! [] + printf "%G\n" $> (42.1234 :: Double) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "printf" ! [] + + printf "%+d\n" $> (42::Int) ! [] + printf "%+0d\n" $> (42::Int) ! [] + printf "%0+d\n" $> (42::Int) ! [] + printf "%10d\n" $> (42::Int) ! [] + printf "%-010d\n" $> (42::Int) ! [] + printf "%-010.2d\n" $> (42::Int) ! [] + + printf "%+f\n" $> (42.1234 :: Double) ! [] + printf "%+0f\n" $> (42.1234 :: Double) ! [] + printf "%0+f\n" $> (42.1234 :: Double) ! [] + printf "%10f\n" $> (42.1234 :: Double) ! [] + printf "%-010f\n" $> (42.1234 :: Double) ! [] + printf "%-010.2f\n" $> (42.1234 :: Double) ! [] + + printf "%10s\n" $> "printf" ! [] + printf "%-10s\n" $> "printf" ! [] + printf "%10.2s\n" $> "printf" ! [] + printf "%2.10s\n" $> "printf" ! [] + printf "%-2.10s\n" $> "printf" ! [] + printf "%-10.2s\n" $> "printf" ! [] diff --git a/examples/printf/000/Makefile b/examples/printf/000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/000/expected b/examples/printf/000/expected new file mode 100644 index 0000000..6268409 --- /dev/null +++ b/examples/printf/000/expected @@ -0,0 +1,30 @@ +42 +42 +052 +0x2a +0x2A +4.212340e1 +4.212340E1 +42.123400 +42.123400 +42.123400 +a:b:c +printf ++42 ++42 ++42 + 42 +42 +42 ++42.123400 ++42.123400 ++42.123400 + 42.123400 +42.123400 +42.12 + printf +printf + pr +printf +printf +pr diff --git a/examples/printf/000/printf.sh b/examples/printf/000/printf.sh new file mode 100644 index 0000000..0f8e459 --- /dev/null +++ b/examples/printf/000/printf.sh @@ -0,0 +1,36 @@ +#!/bin/sh +printf "%d\n" 42 +printf "%u\n" 42 +printf "0%o\n" 42 +printf "0x%x\n" 42 +printf "0x%X\n" 42 + +printf "%e\n" 42.1234 +printf "%E\n" 42.1234 +printf "%g\n" 42.1234 +printf "%G\n" 42.1234 +printf "%f\n" 42.1234 + +printf "%c:%c:%c\n" 'a' 'b' 'c' +printf "%s\n" "printf" + +printf "%+d\n" 42 +printf "%+0d\n" 42 +printf "%0+d\n" 42 +printf "%10d\n" 42 +printf "%-010d\n" 42 +printf "%-010.2d\n" 42 + +printf "%+f\n" 42.1234 +printf "%+0f\n" 42.1234 +printf "%0+f\n" 42.1234 +printf "%10f\n" 42.1234 +printf "%-010f\n" 42.1234 +printf "%-010.2f\n" 42.1234 + +printf "%10s\n" "printf" +printf "%-10s\n" "printf" +printf "%10.2s\n" "printf" +printf "%2.10s\n" "printf" +printf "%-2.10s\n" "printf" +printf "%-10.2s\n" "printf" diff --git a/examples/printf/001/Main.hs b/examples/printf/001/Main.hs new file mode 100644 index 0000000..dfaed56 --- /dev/null +++ b/examples/printf/001/Main.hs @@ -0,0 +1,13 @@ +import Printf + +main = do + printf "%d\n" $> (42 :: Int) ! [] + printf "0x%X\n" $> (42 :: Int) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "haskell" ! [] + printf "%-010.4d\n" $> (42 :: Int) ! [] + printf "%010.4f\n" $> (42.1234 :: Double) ! [] + printf "%10.4s\n" $> (show (7 :: Int)) ! [] + printf "%-10.4s\n" $> "haskell" ! [] + diff --git a/examples/printf/001/Makefile b/examples/printf/001/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/001/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/001/expected b/examples/printf/001/expected new file mode 100644 index 0000000..e48936f --- /dev/null +++ b/examples/printf/001/expected @@ -0,0 +1,9 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 + 7 +hask diff --git a/examples/printf/002/Main.hs b/examples/printf/002/Main.hs new file mode 100644 index 0000000..0871a76 --- /dev/null +++ b/examples/printf/002/Main.hs @@ -0,0 +1,12 @@ +import Printf +import Control.Exception ( evaluate ) + +main = do + fn <- evaluate $! printf "%10.4f\n" + fn $> (10.0 :: Double) ! [] + fn $> (-10.0 :: Double) ! [] + fn $> (10.1010 :: Double) ! [] + fn $> (0.0 :: Double) ! [] + fn $> (0.987654321 :: Double) ! [] + fn $> (987654321 :: Double) ! [] + fn $> (-987654321 :: Double) ! [] diff --git a/examples/printf/002/Makefile b/examples/printf/002/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/002/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/002/expected b/examples/printf/002/expected new file mode 100644 index 0000000..bd20026 --- /dev/null +++ b/examples/printf/002/expected @@ -0,0 +1,7 @@ + 10.0000 + -10.0000 + 10.1010 + 0.0000 + 0.9877 +987654321.0000 +-987654321.0000 diff --git a/examples/printf/should_fail_000/Main.hs b/examples/printf/should_fail_000/Main.hs new file mode 100644 index 0000000..7859483 --- /dev/null +++ b/examples/printf/should_fail_000/Main.hs @@ -0,0 +1,3 @@ +import Printf + +main = printf "%x\n" $> "badstring" ! [] diff --git a/examples/printf/should_fail_000/Makefile b/examples/printf/should_fail_000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/should_fail_000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/should_fail_000/expected b/examples/printf/should_fail_000/expected new file mode 100644 index 0000000..b380af1 --- /dev/null +++ b/examples/printf/should_fail_000/expected @@ -0,0 +1,3 @@ + +Fail: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> diff --git a/examples/printf/should_fail_000/expected.604 b/examples/printf/should_fail_000/expected.604 new file mode 100644 index 0000000..0b47c40 --- /dev/null +++ b/examples/printf/should_fail_000/expected.604 @@ -0,0 +1,2 @@ +a.out: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> diff --git a/examples/printf/should_fail_001/Main.hs b/examples/printf/should_fail_001/Main.hs new file mode 100644 index 0000000..b00156a --- /dev/null +++ b/examples/printf/should_fail_001/Main.hs @@ -0,0 +1,13 @@ +import Printf + +main = do + printf "%d\n" $> (42 :: Int) ! [] + printf "0x%X\n" $> (42 :: Int) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "haskell" ! [] + printf "%-010.4d\n" $> (42 :: Int) ! [] + printf "%010.4f\n" $> (42.1234 :: Double) ! [] + printf "%10.4s\n" $> (7 :: Int)! [] + printf "%-10.4s\n" $> "haskell" ! [] + diff --git a/examples/printf/should_fail_001/Makefile b/examples/printf/should_fail_001/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/should_fail_001/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/should_fail_001/expected b/examples/printf/should_fail_001/expected new file mode 100644 index 0000000..9c7691f --- /dev/null +++ b/examples/printf/should_fail_001/expected @@ -0,0 +1,10 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 + +Fail: Type error in dynamic application. +Can't apply function <[Char] -> [Char]> to argument diff --git a/examples/printf/should_fail_001/expected.604 b/examples/printf/should_fail_001/expected.604 new file mode 100644 index 0000000..77d79da --- /dev/null +++ b/examples/printf/should_fail_001/expected.604 @@ -0,0 +1,9 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 +a.out: Type error in dynamic application. +Can't apply function <[Char] -> [Char]> to argument diff --git a/examples/reload/null/Makefile b/examples/reload/null/Makefile new file mode 100644 index 0000000..4a71f74 --- /dev/null +++ b/examples/reload/null/Makefile @@ -0,0 +1,4 @@ +TEST= reload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/reload/null/Null.hs b/examples/reload/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/reload/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/reload/null/api/API.hs b/examples/reload/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/reload/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/reload/null/prog/Main.hs b/examples/reload/null/prog/Main.hs new file mode 100644 index 0000000..c30251f --- /dev/null +++ b/examples/reload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + (m,v) <- case m_v of + LoadSuccess m v -> return (m,v) + _ -> error "load failed" + putStrLn ( show (a v) ) + + m_v <- reload m "resource" -- get a new version + v' <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn ( show (a v') ) + diff --git a/examples/reload/null/prog/expected b/examples/reload/null/prog/expected new file mode 100644 index 0000000..daaac9e --- /dev/null +++ b/examples/reload/null/prog/expected @@ -0,0 +1,2 @@ +42 +42 diff --git a/examples/shell/shell/API.hs b/examples/shell/shell/API.hs new file mode 100644 index 0000000..da26a69 --- /dev/null +++ b/examples/shell/shell/API.hs @@ -0,0 +1,8 @@ +module API where + +-- the interface between the app and the plugin +data Interface = Interface { function :: String -> String } + +-- default values for the interface +plugin :: Interface +plugin = Interface { function = id } diff --git a/examples/shell/shell/Main.hs b/examples/shell/shell/Main.hs new file mode 100644 index 0000000..67f4767 --- /dev/null +++ b/examples/shell/shell/Main.hs @@ -0,0 +1,85 @@ +-- +-- a simple shell for loading plugins and evaluating their functions +-- + +import Plugins +import API + +import Data.Either +import Data.Char +import Control.Monad ( when ) +import System.Console.Readline ( readline ) +import System.Exit ( ExitCode(..), exitWith ) + + +source = "Plugin.hs" +stub = "Plugin.stub" + +sym = "resource" + +main = do + status <- makeWith source stub [] + p <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed to compile" + MakeSuccess _ obj -> do + m_v <- load obj ["."] [] sym + case m_v of + LoadSuccess m v -> return (m,v) + LoadFailure e -> do mapM_ putStrLn e + error "failed to load" + shell p + + where + shell p@(m,v) = do + + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just ":q" -> exitWith ExitSuccess + Just s -> return (chomp s) + + status <- makeWith source stub [] + case status of + MakeFailure e -> do + mapM_ putStrLn e + shell p -- print error and back to prompt + + MakeSuccess NotReq o -> do + p' <- eval cmd p + shell p' -- eval str again + + MakeSuccess ReComp o -> do + m_v' <- reload m sym + case m_v' of + LoadFailure e -> mapM_ putStrLn e >> error "failed to load" + LoadSuccess _ v' -> do + let p' = (m,v') + p'' <- eval cmd p' + shell p'' + +-- +-- shell commands +-- +eval "" p = return p + +eval ":clear" p = do + let loop i = when (i < 40) (do putStr "\n" ; loop $! i+1) + loop 0 + return p + +eval ":?" p = do + putStrLn$"\":?\"\n" ++ + "\":quit\"\n" ++ + "\":clear\"\n" ++ + "\"foo\"" + return p + +eval s (m,v) = putStrLn ((function v) s) >> return (m,v) + +-- +-- strip trailing whitespace +-- +chomp :: String -> String +chomp [] = [] +chomp s | isSpace (last s) = chomp $! init s + | otherwise = s diff --git a/examples/shell/shell/Makefile b/examples/shell/shell/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/shell/shell/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/shell/shell/Plugin.hs b/examples/shell/shell/Plugin.hs new file mode 100644 index 0000000..e904f35 --- /dev/null +++ b/examples/shell/shell/Plugin.hs @@ -0,0 +1,5 @@ + +resource = plugin { + function = map toUpper +} + diff --git a/examples/shell/shell/Plugin.stub b/examples/shell/shell/Plugin.stub new file mode 100644 index 0000000..a701306 --- /dev/null +++ b/examples/shell/shell/Plugin.stub @@ -0,0 +1,19 @@ +-- +-- this is a "stub" file, containing default syntax we don't +-- want the user to have to write +-- +-- for example, it constrains the module name and force the API to be +-- imported + +module Plugin ( resource ) where + +import API +import Data.Char +import Data.List + +-- this is a default definition of 'resource'. it will be overridden +-- by anything the user writes. useful for default values + +resource :: Interface +resource = plugin + diff --git a/examples/shell/shell/README b/examples/shell/shell/README new file mode 100644 index 0000000..5edd023 --- /dev/null +++ b/examples/shell/shell/README @@ -0,0 +1,23 @@ +$ make +$ ./a.out +Compiling plugin ... done +Loading package base ... linking ... done +Loading objects API Plugin ... done +> ? +"?" +"quit" +"clear" +"filter foo" +> filter adf adsf +fsda fda +> filter asd faSDFADSF +FSDAFDSaf dsa + +-- at this point I edit the plugin and save the source + +> filter asfdaSDFASD +Compiling plugin ... done +Reloading Plugin ... done +DSAFDSADFSA + +-- it compiled and reloaded it for me. nice. diff --git a/examples/shell/shell/dont_test b/examples/shell/shell/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/shell/simple/Main.hs b/examples/shell/simple/Main.hs new file mode 100644 index 0000000..b3f26b1 --- /dev/null +++ b/examples/shell/simple/Main.hs @@ -0,0 +1,41 @@ +import Plugins +import StringProcessorAPI +import System.Console.Readline +import System.Exit + +source = "Plugin.hs" +stub = "Plugin.stub" +symbol = "resource" + +main = do s <- makeWith source stub [] + o <- case s of + MakeSuccess _ obj -> do + ls <- load obj ["."] [] symbol + case ls of LoadSuccess m v -> return (m,v) + LoadFailure err -> error "load failed" + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + shell o + +shell o@(m,plugin) = do + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + + s <- makeWith source stub [] -- maybe recompile the source + o' <- case s of + MakeSuccess ReComp o -> do + ls <- reload m symbol + case ls of LoadSuccess m' v' -> return (m',v') + LoadFailure err -> error "reload failed" + MakeSuccess NotReq _ -> return o + MakeFailure e -> mapM_ putStrLn e >> shell o + eval cmd o' + shell o' + +eval ":?" _ = putStrLn ":?\n:q\n" + +eval s (_,plugin) = let fn = (stringProcessor plugin) in putStrLn (fn s) + + diff --git a/examples/shell/simple/Makefile b/examples/shell/simple/Makefile new file mode 100644 index 0000000..cbe6c6d --- /dev/null +++ b/examples/shell/simple/Makefile @@ -0,0 +1,6 @@ +OBJS=StringProcessorAPI.o +TOP=../../.. +include ../../eval.mk + +#all: +# @echo test disabled diff --git a/examples/shell/simple/Plugin.hs b/examples/shell/simple/Plugin.hs new file mode 100644 index 0000000..eff5e28 --- /dev/null +++ b/examples/shell/simple/Plugin.hs @@ -0,0 +1,5 @@ +import Char + +resource = plugin { + stringProcessor = map toUpper +} diff --git a/examples/shell/simple/Plugin.stub b/examples/shell/simple/Plugin.stub new file mode 100644 index 0000000..d53ed15 --- /dev/null +++ b/examples/shell/simple/Plugin.stub @@ -0,0 +1,19 @@ +-- +-- this is a "stub" file, containing default syntax we don't +-- want the user to have to write +-- +-- for example, it constrains the module name and force the API to be +-- imported + +module Plugin ( resource ) where + +import StringProcessorAPI +import Data.Char +import Data.List + +-- this is a default definition of 'resource'. it will be overridden +-- by anything the user writes. useful for default values + +resource :: Interface +resource = plugin + diff --git a/examples/shell/simple/README b/examples/shell/simple/README new file mode 100644 index 0000000..5edd023 --- /dev/null +++ b/examples/shell/simple/README @@ -0,0 +1,23 @@ +$ make +$ ./a.out +Compiling plugin ... done +Loading package base ... linking ... done +Loading objects API Plugin ... done +> ? +"?" +"quit" +"clear" +"filter foo" +> filter adf adsf +fsda fda +> filter asd faSDFADSF +FSDAFDSaf dsa + +-- at this point I edit the plugin and save the source + +> filter asfdaSDFASD +Compiling plugin ... done +Reloading Plugin ... done +DSAFDSADFSA + +-- it compiled and reloaded it for me. nice. diff --git a/examples/shell/simple/StringProcessorAPI.hs b/examples/shell/simple/StringProcessorAPI.hs new file mode 100644 index 0000000..a3ac21d --- /dev/null +++ b/examples/shell/simple/StringProcessorAPI.hs @@ -0,0 +1,8 @@ +module StringProcessorAPI where + +data Interface = Interface { + stringProcessor :: String -> String +} + +plugin :: Interface +plugin = Interface { stringProcessor = id } diff --git a/examples/shell/simple/dont_test b/examples/shell/simple/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/typecase/000/Main.hs b/examples/typecase/000/Main.hs new file mode 100644 index 0000000..f1a6b87 --- /dev/null +++ b/examples/typecase/000/Main.hs @@ -0,0 +1,14 @@ +import AltData +import Data.Char + +main = putStrLn f + +f = let v = toDyn (7 :: Int) + in typecase (v) [ + _Bool --> \(b::Bool) -> show (not b)++" :: Bool", + _Char --> \(c::Char) -> show (toUpper c)++" :: Char", + _Int --> \(i::Int) -> show (-i)++" :: Int", + _String --> \(s::String) -> show (reverse s)++" :: [Char]", + _IntToInt --> \(f::Int->Int) -> show (f 7) ++":: Int -> Int" + ] ("couldn't find a typing") + diff --git a/examples/typecase/000/Makefile b/examples/typecase/000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/typecase/000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/typecase/000/expected b/examples/typecase/000/expected new file mode 100644 index 0000000..8e91335 --- /dev/null +++ b/examples/typecase/000/expected @@ -0,0 +1 @@ +-7 :: Int diff --git a/examples/unload/null/Makefile b/examples/unload/null/Makefile new file mode 100644 index 0000000..b53007a --- /dev/null +++ b/examples/unload/null/Makefile @@ -0,0 +1,4 @@ +TEST= unload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/unload/null/Null.hs b/examples/unload/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/unload/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/unload/null/api/API.hs b/examples/unload/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/unload/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/unload/null/prog/Main.hs b/examples/unload/null/prog/Main.hs new file mode 100644 index 0000000..fb52951 --- /dev/null +++ b/examples/unload/null/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess m v -> do putStrLn ( show (a v) ) ; unload m diff --git a/examples/unload/null/prog/expected b/examples/unload/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/unload/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/unload/sjwtrap/Makefile b/examples/unload/sjwtrap/Makefile new file mode 100644 index 0000000..ab35d4b --- /dev/null +++ b/examples/unload/sjwtrap/Makefile @@ -0,0 +1,4 @@ +TEST= unload/sjwtrap +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/unload/sjwtrap/Null.hs b/examples/unload/sjwtrap/Null.hs new file mode 100644 index 0000000..81964eb --- /dev/null +++ b/examples/unload/sjwtrap/Null.hs @@ -0,0 +1,6 @@ +module Null where + +import qualified Prelude +import API + +resource = null diff --git a/examples/unload/sjwtrap/api/API.hs b/examples/unload/sjwtrap/api/API.hs new file mode 100644 index 0000000..bf1796d --- /dev/null +++ b/examples/unload/sjwtrap/api/API.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +data Null = Null { a, b :: Int } + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/unload/sjwtrap/prog/Main.hs b/examples/unload/sjwtrap/prog/Main.hs new file mode 100644 index 0000000..00bdc21 --- /dev/null +++ b/examples/unload/sjwtrap/prog/Main.hs @@ -0,0 +1,15 @@ + +import Plugins +import API + +-- +-- what happens if we try to use code that has been unloaded? +-- + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + (m,v) <- case m_v of + LoadSuccess m v -> return (m,v) + _ -> error "load failed" + putStrLn ( show (a v) ) + unload m diff --git a/examples/unload/sjwtrap/prog/expected b/examples/unload/sjwtrap/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/unload/sjwtrap/prog/expected @@ -0,0 +1 @@ +42 diff --git a/install-sh b/install-sh new file mode 100644 index 0000000..e9de238 --- /dev/null +++ b/install-sh @@ -0,0 +1,251 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + chmodcmd="" + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/scripts/openbsd-port/Makefile b/scripts/openbsd-port/Makefile new file mode 100644 index 0000000..909dacf --- /dev/null +++ b/scripts/openbsd-port/Makefile @@ -0,0 +1,21 @@ +# $OpenBSD$ + +COMMENT= "dynamic link library for Haskell" + +V= 0.9.8 +DISTNAME= hs-plugins-${V} +CATEGORIES= devel +MAINTAINER= Don Stewart +HOMEPAGE= http://www.cse.unsw.edu.au/~dons/hs-plugins-0.9.8/ +MASTER_SITES= ${HOMEPAGE} + +MODULES= ghc +CONFIGURE_STYLE= gnu dest + +# LGPL +PERMIT_PACKAGE_CDROM= Yes +PERMIT_PACKAGE_FTP= Yes +PERMIT_DISTFILES_CDROM= Yes +PERMIT_DISTFILES_FTP= Yes + +.include diff --git a/scripts/openbsd-port/distinfo b/scripts/openbsd-port/distinfo new file mode 100644 index 0000000..1623c2c --- /dev/null +++ b/scripts/openbsd-port/distinfo @@ -0,0 +1,3 @@ +MD5 (hs-plugins-0.9.4.tar.gz) = 120f38ca532b187ee52798f5c36cc920 +RMD160 (hs-plugins-0.9.4.tar.gz) = 219eaf70e4bc0f1abc8a782d1bbd64ad2c5f8e86 +SHA1 (hs-plugins-0.9.4.tar.gz) = ad38b9f4e5b90c1361c6c96bd94e2a9270ad3d78 diff --git a/scripts/openbsd-port/pkg/DESCR b/scripts/openbsd-port/pkg/DESCR new file mode 100644 index 0000000..dbbdd57 --- /dev/null +++ b/scripts/openbsd-port/pkg/DESCR @@ -0,0 +1,6 @@ +hs-plugins is a library for dynamic loading and compilation of Haskell +code. It provides typesafe "plugins" for Haskell. The interface is +general enough that it can be used to create conventional plugins, +hmake-like Haskell interpreters embedded in applications, or to script +an application with Haskell (or a Haskell EDSL) as the extension +language. diff --git a/scripts/openbsd-port/pkg/PLIST b/scripts/openbsd-port/pkg/PLIST new file mode 100644 index 0000000..7618ba4 --- /dev/null +++ b/scripts/openbsd-port/pkg/PLIST @@ -0,0 +1,28 @@ +@comment $OpenBSD$ +lib/hs-plugins/imports/Plugins.hi +lib/hs-plugins/imports/Plugins/BinIface.hi +lib/hs-plugins/imports/Plugins/Binary.hi +lib/hs-plugins/imports/Plugins/Consts.hi +lib/hs-plugins/imports/Plugins/Env.hi +lib/hs-plugins/imports/Plugins/FastMutInt.hi +lib/hs-plugins/imports/Plugins/FastString.hi +lib/hs-plugins/imports/Plugins/Iface.hi +lib/hs-plugins/imports/Plugins/Load.hi +lib/hs-plugins/imports/Plugins/Make.hi +lib/hs-plugins/imports/Plugins/Package.hi +lib/hs-plugins/imports/Plugins/ParsePkgConfLite.hi +lib/hs-plugins/imports/Plugins/Parser.hi +lib/hs-plugins/imports/Plugins/PrimPacked.hi +lib/hs-plugins/imports/Plugins/Utils.hi +lib/hs-plugins/include/hschooks.h +lib/hs-plugins/libHSplugins.a +lib/hs-plugins/libHSplugins_cbits.a +lib/hs-plugins/plugins.conf.in +@dirrm lib/hs-plugins/include +@dirrm lib/hs-plugins/imports/Plugins +@dirrm lib/hs-plugins/imports +@dirrm lib/hs-plugins +@exec /bin/cat %D/lib/hs-plugins/plugins.conf.in | /usr/bin/env PREFIX=%D %D/bin/ghc-pkg -u +@exec /bin/rm -f %D/lib/ghc-6.2.1/package.conf.old +@unexec %D/bin/ghc-pkg -r plugins +@unexec /bin/rm -f %D/lib/ghc-6.2.1/package.conf.old diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..56df945 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,38 @@ + +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +.PHONY: all build altdata hi plugins eval printf +.PHONY: install i_altdata i_hi i_plugins i_eval i_printf + +build: altdata hi plugins eval printf + +altdata: + @cd altdata && $(MAKE) +hi: + @cd hi && $(MAKE) +plugins: + @cd plugins && $(MAKE) +eval: + @cd eval && $(MAKE) +printf: + @cd printf && $(MAKE) + +install: i_altdata i_hi i_plugins i_eval i_printf + @true + +i_altdata: + @cd altdata && $(MAKE) install +i_hi: + @cd hi && $(MAKE) install +i_plugins: + @cd plugins && $(MAKE) install +i_eval: + @cd eval && $(MAKE) install +i_printf: + @cd printf && $(MAKE) install + +all: build + +TOP=.. +include build.mk diff --git a/src/README b/src/README new file mode 100644 index 0000000..8de08d0 --- /dev/null +++ b/src/README @@ -0,0 +1,23 @@ +Don's Haskell Libraries +----------------------- + +* altdata +An alternative implementation of Typeable and Dynamic that +works in the presence of (completely) separate compilation + +* hi +A parser for .hi files + +* plugins +A dynamic loader for GHC-produce object files. Also provides type +checking of object interfaces via dynamic typing. + +* eval +A system for reflecting strings of Haskell source into native code at +runtime, via runtime compilation and dynamic linking. +Also implements a staged computation doo-hickey. + +* printf +An implementation of printf(3) that uses eval to generate new Haskell +functions from format strings, at runtime, and dynamic typing to +retain type safety. diff --git a/src/altdata/AltData.hs b/src/altdata/AltData.hs new file mode 100644 index 0000000..fcefa19 --- /dev/null +++ b/src/altdata/AltData.hs @@ -0,0 +1,24 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module AltData ( module AltData.Dynamic, + module AltData.Typeable + ) where +import AltData.Dynamic {-all-} +import AltData.Typeable {-all-} diff --git a/src/altdata/AltData/Dynamic.hs b/src/altdata/AltData/Dynamic.hs new file mode 100644 index 0000000..3ed9a6d --- /dev/null +++ b/src/altdata/AltData/Dynamic.hs @@ -0,0 +1,174 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- reimplement the Data.Dynamic library to use equality over the +-- canonical name of a type, rather than on integer keys. The later is +-- how the Haskell library works, and is broken for our situation: +-- static versus dynamic instances of the same type seem to generate +-- different keys, meaning equal types are not detected as such. +-- + +module AltData.Dynamic ( + + Dynamic, -- must be abstract + toDyn, -- :: Typeable a => a -> Dynamic + fromDyn, -- :: Typeable a => Dynamic -> Maybe a + fromDynamic, + dynApp, + dynApply, + dynAppHList, + + typecase, + (-->), + + _Int, + _Char, + _Bool, + _String, + _IntToInt, + + ) where + +import AltData.Typeable +import Data.Maybe +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.Base ( unsafeCoerce# ) +import Data.List + +data Dynamic = Dynamic TypeRep Obj + +type Obj = forall a . a + +instance Show Dynamic where + -- the instance just prints the type representation. + showsPrec _ (Dynamic t _) = + showString "<" . + showsPrec 0 t . + showString ">" + +instance Typeable Dynamic where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") [] +#else + typeOf _ = mkAppTy (mkTyCon "AltData.Dyanmic") [] +#endif + +-- +-- must be monomophic, see Data.Dynamic +-- +toDyn :: Typeable a => a -> Dynamic +toDyn v = Dynamic (typeOf v) (unsafeCoerce# v) + +-- +-- Converts a 'Dynamic' object back into an ordinary Haskell value of +-- the correct type. (this is the same as fromDynamic) +-- +-- Uses string comparison of the name of the type, rather than the +-- hashed key of the type, which doesn't work for plugins, which mix +-- static and dynamic loaded code. +-- +-- TypeRep is abstract, unfortunately. +-- +fromDyn :: Typeable a => Dynamic -> Maybe a + +fromDyn (Dynamic t v) = + case unsafeCoerce# v of + r | t == typeOf r -> Just r + | otherwise -> unsafePerformIO (putStrLn $ + "Couldn't match `" ++show(typeOf r) ++ + "' against `" ++show t ++"'"++ + "\n\tExpected type: " ++show(typeOf r) ++ + "\n\tInferred type: " ++show t + ) `seq` Nothing + +fromDynamic d = case fromDyn d of + Just v -> v + Nothing -> error ("\nType error in dynamic unwrapping.\n" ++ + "In value `" ++ show d ++ "'") + +dynApp :: Dynamic -> Dynamic -> Dynamic +dynApp f x = case dynApply f x of + Just r -> r + Nothing -> error ("Type error in dynamic application.\n" ++ + "Can't apply function " ++ show f ++ + " to argument " ++ show x) + +-- +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +-- +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = +#if __GLASGOW_HASKELL__ >= 603 + case funResultTy t1 t2 of +#else + case applyTy t1 t2 of +#endif + Just t3 -> Just (Dynamic t3 ((unsafeCoerce# f) x)) + Nothing -> Nothing + + +-- +-- hmm +-- +dynAppHList :: Dynamic -> [Dynamic] -> Dynamic +dynAppHList fn [] = fn -- partial applicaiton +dynAppHList fn (x:xs) = (fn `dynApp` x) `dynAppHList` xs + +-- --------------------------------------------------------------------- +-- +-- Implementation of typecase, without patterns, based on "Dynamic +-- typing in a statically typed language". Mart\'in Abadi, Luca +-- Cardelli, Benjamin Pierce and Gordon Plotkin. ACM Trans. Prog. Lang. +-- and Syst. 13(2):237-268, 1991. +-- +-- Doesn't provide the behaviour that if the value is not a Dynamic, +-- then typecase returns a error. Need low-level ops for that. +-- + +-- typecase :: Typeable u => Dynamic -> [(TypeRep, Dynamic)] -> u -> u + +typecase :: Typeable u + => Dynamic -- selector + -> [(Dynamic, Dynamic)] -- branches + -> u -- else arm + -> u -- return type + +typecase dv@(Dynamic ty _) alts dflt = + case find (hasType ty) alts of + Nothing -> dflt + Just v -> fromDynamic $ snd v `dynApp` dv + + where hasType t ((Dynamic u _),_) = t == u + +infixl 6 --> +(-->) :: Typeable b => a -> b -> (a,Dynamic) +a --> b = (a,toDyn b) + +-- +-- need a way to generate a Dynamic prelude +-- +_Int = toDyn ( undefined :: Int ) +_Char = toDyn ( undefined :: Char ) +_Bool = toDyn ( undefined :: Bool ) +_String = toDyn ( undefined :: [Char] ) +_IntToInt = toDyn ( undefined :: Int -> Int ) + +------------------------------------------------------------------------ diff --git a/src/altdata/AltData/Typeable.hs b/src/altdata/AltData/Typeable.hs new file mode 100644 index 0000000..ef3957d --- /dev/null +++ b/src/altdata/AltData/Typeable.hs @@ -0,0 +1,958 @@ +{-# OPTIONS -cpp -fglasgow-exts -fno-implicit-prelude #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- Based on: +-- +-- | +-- Module : Data.Typeable +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Typeable class reifies types to some extent by associating type +-- representations to types. These type representations can be compared, +-- and one can in turn define a type-safe cast operation. To this end, +-- an unsafe cast is guarded by a test for type (representation) +-- equivalence. The module Data.Dynamic uses Typeable for an +-- implementation of dynamics. The module Data.Generics uses Typeable +-- and type-safe cast (but not dynamics) to support the \"Scrap your +-- boilerplate\" style of generic programming. +-- + +module AltData.Typeable + +#if __GLASGOW_HASKELL__ >= 603 + ( + + -- * The Typeable class + Typeable( typeOf ), -- :: a -> TypeRep + + -- * Type-safe cast + cast, -- :: (Typeable a, Typeable b) => a -> Maybe b + gcast, -- a generalisation of cast + + -- * Type representations + TypeRep, -- abstract, instance of: Eq, Show, Typeable + TyCon, -- abstract, instance of: Eq, Show, Typeable + + -- * Construction of type representations + mkTyCon, -- :: String -> TyCon + mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep + mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep + mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep + + -- * Observation of type representations + splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) + funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep + typeRepTyCon, -- :: TypeRep -> TyCon + typeRepArgs, -- :: TypeRep -> [TypeRep] + tyConString, -- :: TyCon -> String + + -- * The other Typeable classes + -- | /Note:/ The general instances are provided for GHC only. + Typeable1( typeOf1 ), -- :: t a -> TypeRep + Typeable2( typeOf2 ), -- :: t a b -> TypeRep + Typeable3( typeOf3 ), -- :: t a b c -> TypeRep + Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep + Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep + Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep + Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep + gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) + gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) + + -- * Default instances + -- | /Note:/ These are not needed by GHC, for which these instances + -- are generated by general instance declarations. + typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep + typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep + typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep + typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep + typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep + typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep + typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep + + ) where + +import qualified Data.HashTable as HT +import Data.Maybe +import Data.Either +import Data.Int +import Data.Word +import Data.List( foldl ) + +import GHC.Base +import GHC.Show +import GHC.Err +import GHC.Num +import GHC.Float +import GHC.Real( rem, Ratio ) +import GHC.IOBase +import GHC.Ptr -- So we can give Typeable instance for Ptr +import GHC.Stable -- So we can give Typeable instance for StablePtr + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# + +#include "Typeable.h" + +------------------------------------------------------------- +-- +-- Type representations +-- +------------------------------------------------------------- + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +-- +-- equality of keys doesn't work for dynamically loaded code, so we +-- revert back to canonical type names. +-- +data TypeRep = TypeRep !Key TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon !Key String + +instance Eq TyCon where + (TyCon _ s1) == (TyCon _ s2) = s1 == s2 + + -- + -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") + -- [fTy,fTy,fTy]) + -- + -- returns "(Foo,Foo,Foo)" + -- + -- The TypeRep Show instance promises to print tuple types + -- correctly. Tuple type constructors are specified by a + -- sequence of commas, e.g., (mkTyCon ",,,,") returns + -- the 5-tuple tycon. + +----------------- Construction -------------------- + +-- | Applies a type constructor to a sequence of types +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc@(TyCon tc_k _) args + = TypeRep (appKeys tc_k arg_ks) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkTyConApp funTc [f,a] + +-- | Splits a type constructor application +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc trs) = (tc,trs) + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + _ -> Nothing + +-- | Adds a TypeRep argument to a TypeRep. +mkAppTy :: TypeRep -> TypeRep -> TypeRep +mkAppTy (TypeRep tr_k tc trs) arg_tr + = let (TypeRep arg_k _ _) = arg_tr + in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) + +-- If we enforce the restriction that there is only one +-- @TyCon@ for a type & it is shared among all its uses, +-- we can map them onto Ints very simply. The benefit is, +-- of course, that @TyCon@s can then be compared efficiently. + +-- Provided the implementor of other @Typeable@ instances +-- takes care of making all the @TyCon@s CAFs (toplevel constants), +-- this will work. + +-- If this constraint does turn out to be a sore thumb, changing +-- the Eq instance for TyCons is trivial. + +-- | Builds a 'TyCon' object representing a type constructor. An +-- implementation of "Data.Typeable" should ensure that the following holds: +-- +-- > mkTyCon "a" == mkTyCon "a" +-- + +mkTyCon :: String -- ^ the name of the type constructor (should be unique + -- in the program, so it might be wise to use the + -- fully qualified name). + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon str = TyCon (mkTyConKey str) str + +----------------- Observation --------------------- + +-- | Observe the type constructor of a type representation +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon (TypeRep _ tc _) = tc + +-- | Observe the argument types of a type representation +typeRepArgs :: TypeRep -> [TypeRep] +typeRepArgs (TypeRep _ _ args) = args + +-- | Observe string encoding of a type representation +tyConString :: TyCon -> String +tyConString (TyCon _ str) = str + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . + showString " -> " . + showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: TyCon -> [TypeRep] -> ShowS +showTuple (TyCon _ str) args = showChar '(' . go str args + where + go [] [a] = showsPrec 10 a . showChar ')' + go _ [] = showChar ')' -- a failure condition, really. + go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as + go _ _ = showChar ')' + +------------------------------------------------------------- +-- +-- The Typeable class and friends +-- +------------------------------------------------------------- + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeOf :: a -> TypeRep + -- ^ Takes a value of type @a@ and returns a concrete representation + -- of that type. The /value/ of the argument should be ignored by + -- any instance of 'Typeable', so that it is safe to pass 'undefined' as + -- the argument. + +-- | Variant for unary type constructors +class Typeable1 t where + typeOf1 :: t a -> TypeRep + +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) + where + argType :: t a -> a + argType = undefined + +-- | Variant for binary type constructors +class Typeable2 t where + typeOf2 :: t a b -> TypeRep + +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) + where + argType :: t a b -> a + argType = undefined + +-- | Variant for 3-ary type constructors +class Typeable3 t where + typeOf3 :: t a b c -> TypeRep + +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c -> a + argType = undefined + +-- | Variant for 4-ary type constructors +class Typeable4 t where + typeOf4 :: t a b c d -> TypeRep + +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d -> a + argType = undefined + +-- | Variant for 5-ary type constructors +class Typeable5 t where + typeOf5 :: t a b c d e -> TypeRep + +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e -> a + argType = undefined + +-- | Variant for 6-ary type constructors +class Typeable6 t where + typeOf6 :: t a b c d e f -> TypeRep + +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f -> a + argType = undefined + +-- | Variant for 7-ary type constructors +class Typeable7 t where + typeOf7 :: t a b c d e f g -> TypeRep + +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f g -> a + argType = undefined + +-- Given a @Typeable@/n/ instance for an /n/-ary type constructor, +-- define the instances for partial applications. +-- Programmers using non-GHC implementations must do this manually +-- for each type constructor. +-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.) + +-- | One Typeable instance for all Typeable1 instances +instance (Typeable1 s, Typeable a) + => Typeable (s a) where + typeOf = typeOfDefault + +-- | One Typeable1 instance for all Typeable2 instances +instance (Typeable2 s, Typeable a) + => Typeable1 (s a) where + typeOf1 = typeOf1Default + +-- | One Typeable2 instance for all Typeable3 instances +instance (Typeable3 s, Typeable a) + => Typeable2 (s a) where + typeOf2 = typeOf2Default + +-- | One Typeable3 instance for all Typeable4 instances +instance (Typeable4 s, Typeable a) + => Typeable3 (s a) where + typeOf3 = typeOf3Default + +-- | One Typeable4 instance for all Typeable5 instances +instance (Typeable5 s, Typeable a) + => Typeable4 (s a) where + typeOf4 = typeOf4Default + +-- | One Typeable5 instance for all Typeable6 instances +instance (Typeable6 s, Typeable a) + => Typeable5 (s a) where + typeOf5 = typeOf5Default + +-- | One Typeable6 instance for all Typeable7 instances +instance (Typeable7 s, Typeable a) + => Typeable6 (s a) where + typeOf6 = typeOf6Default + +------------------------------------------------------------- +-- +-- Type-safe cast +-- +------------------------------------------------------------- + +-- | The type-safe cast operation +cast :: (Typeable a, Typeable b) => a -> Maybe b +cast x = r + where + r = if typeOf x == typeOf (fromJust r) + then Just $ unsafeCoerce x + else Nothing + +-- | A flexible variation parameterised in a type constructor +gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = r + where + r = if typeOf (getArg x) == typeOf (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +-- | Cast for * -> * +gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) +gcast1 x = r + where + r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +-- | Cast for * -> * -> * +gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) +gcast2 x = r + where + r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +------------------------------------------------------------- +-- +-- Instances of the Typeable classes for Prelude types +-- +------------------------------------------------------------- + +INSTANCE_TYPEABLE1([],listTc,"[]") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +INSTANCE_TYPEABLE2(Either,eitherTc,"Either") +INSTANCE_TYPEABLE2((->),funTc,"->") +INSTANCE_TYPEABLE1(IO,ioTc,"IO") +INSTANCE_TYPEABLE0((),unitTc,"()") + +INSTANCE_TYPEABLE2((,),pairTc,",") +INSTANCE_TYPEABLE3((,,),tup3Tc,",,") + +tup4Tc :: TyCon +tup4Tc = mkTyCon ",,," + +instance Typeable4 (,,,) where + typeOf4 _ = mkTyConApp tup4Tc [] + +tup5Tc :: TyCon +tup5Tc = mkTyCon ",,,," + +instance Typeable5 (,,,,) where + typeOf5 _ = mkTyConApp tup5Tc [] + +tup6Tc :: TyCon +tup6Tc = mkTyCon ",,,,," + +instance Typeable6 (,,,,,) where + typeOf6 _ = mkTyConApp tup6Tc [] + +tup7Tc :: TyCon +tup7Tc = mkTyCon ",,,,," + +instance Typeable7 (,,,,,,) where + typeOf7 _ = mkTyConApp tup7Tc [] + +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr") +INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr") +INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef") + +------------------------------------------------------- +-- +-- Generate Typeable instances for standard datatypes +-- +------------------------------------------------------- + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") + +INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") + +INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") + +INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) + +#else /* GHC < 6.3 */ + + ( + -- * The Typeable class + Typeable( typeOf ), -- :: a -> TypeRep + + -- * Type-safe cast + cast, -- :: (Typeable a, Typeable b) => a -> Maybe b + castss, -- a cast for kind "* -> *" + castarr, -- another convenient variation + + -- * Type representations + TypeRep, -- abstract, instance of: Eq, Show, Typeable + TyCon, -- abstract, instance of: Eq, Show, Typeable + + -- * Construction of type representations + mkTyCon, -- :: String -> TyCon + mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep + mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep + applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep + + -- * Observation of type representations + typerepTyCon, -- :: TypeRep -> TyCon + typerepArgs, -- :: TypeRep -> [TypeRep] + tyconString -- :: TyCon -> String + + + ) where + +import qualified Data.HashTable as HT +import Data.Maybe +import Data.Either +import Data.Int +import Data.Word +import Data.List( foldl ) + +import GHC.Base +import GHC.Show +import GHC.Err +import GHC.Num +import GHC.Float +import GHC.Real( rem, Ratio ) +import GHC.IOBase +import GHC.Ptr -- So we can give Typeable instance for Ptr +import GHC.Stable -- So we can give Typeable instance for StablePtr + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# + +#include "Typeable.h" + + +------------------------------------------------------------- +-- +-- Type representations +-- +------------------------------------------------------------- + + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +data TypeRep = TypeRep !Key TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon !Key String + +instance Eq TyCon where + (TyCon _ s1) == (TyCon _ s2) = s1 == s2 + + -- + -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,") + -- [fTy,fTy,fTy]) + -- + -- returns "(Foo,Foo,Foo)" + -- + -- The TypeRep Show instance promises to print tuple types + -- correctly. Tuple type constructors are specified by a + -- sequence of commas, e.g., (mkTyCon ",,,,") returns + -- the 5-tuple tycon. + +----------------- Construction -------------------- + +-- | Applies a type constructor to a sequence of types +mkAppTy :: TyCon -> [TypeRep] -> TypeRep +mkAppTy tc@(TyCon tc_k _) args + = TypeRep (appKeys tc_k arg_ks) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +funTc :: TyCon +funTc = mkTyCon "->" + +-- | A special case of 'mkAppTy', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkAppTy funTc [f,a] + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +applyTy :: TypeRep -> TypeRep -> Maybe TypeRep +applyTy (TypeRep _ tc [t1,t2]) t3 + | tc == funTc && t1 == t3 = Just t2 +applyTy _ _ = Nothing + +-- If we enforce the restriction that there is only one +-- @TyCon@ for a type & it is shared among all its uses, +-- we can map them onto Ints very simply. The benefit is, +-- of course, that @TyCon@s can then be compared efficiently. + +-- Provided the implementor of other @Typeable@ instances +-- takes care of making all the @TyCon@s CAFs (toplevel constants), +-- this will work. + +-- If this constraint does turn out to be a sore thumb, changing +-- the Eq instance for TyCons is trivial. + +-- | Builds a 'TyCon' object representing a type constructor. An +-- implementation of "Data.Typeable" should ensure that the following holds: +-- +-- > mkTyCon "a" == mkTyCon "a" +-- + +mkTyCon :: String -- ^ the name of the type constructor (should be unique + -- in the program, so it might be wise to use the + -- fully qualified name). + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon str = TyCon (mkTyConKey str) str + + + +----------------- Observation --------------------- + + +-- | Observe the type constructor of a type representation +typerepTyCon :: TypeRep -> TyCon +typerepTyCon (TypeRep _ tc _) = tc + + +-- | Observe the argument types of a type representation +typerepArgs :: TypeRep -> [TypeRep] +typerepArgs (TypeRep _ _ args) = args + + +-- | Observe string encoding of a type representation +tyconString :: TyCon -> String +tyconString (TyCon _ str) = str + + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . showString " -> " . showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: TyCon -> [TypeRep] -> ShowS +showTuple (TyCon _ str) args = showChar '(' . go str args + where + go [] [a] = showsPrec 10 a . showChar ')' + go _ [] = showChar ')' -- a failure condition, really. + go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as + go _ _ = showChar ')' + + +------------------------------------------------------------- +-- +-- The Typeable class +-- +------------------------------------------------------------- + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeOf :: a -> TypeRep + -- ^ Takes a value of type @a@ and returns a concrete representation + -- of that type. The /value/ of the argument should be ignored by + -- any instance of 'Typeable', so that it is safe to pass 'undefined' as + -- the argument. + + +------------------------------------------------------------- +-- +-- Type-safe cast +-- +------------------------------------------------------------- + +-- | The type-safe cast operation +cast :: (Typeable a, Typeable b) => a -> Maybe b +cast x = r + where + r = if typeOf x == typeOf (fromJust r) + then Just $ unsafeCoerce x + else Nothing + + +-- | A convenient variation for kind "* -> *" +castss :: (Typeable a, Typeable b) => t a -> Maybe (t b) +castss x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: t c -> c + get = undefined + + +-- | Another variation +castarr :: (Typeable a, Typeable b, Typeable c, Typeable d) + => (a -> t b) -> Maybe (c -> t d) +castarr x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: (e -> t f) -> (e, f) + get = undefined + +{- + +The variations castss and castarr are arguably not really needed. +Let's discuss castss in some detail. To get rid of castss, we can +require "Typeable (t a)" and "Typeable (t b)" rather than just +"Typeable a" and "Typeable b". In that case, the ordinary cast would +work. Eventually, all kinds of library instances should become +Typeable. (There is another potential use of variations as those given +above. It allows quantification on type constructors. + +-} + + +------------------------------------------------------------- +-- +-- Instances of the Typeable class for Prelude types +-- +------------------------------------------------------------- + +listTc :: TyCon +listTc = mkTyCon "[]" + +instance Typeable a => Typeable [a] where + typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)] + -- In GHC we can say + -- typeOf (undefined :: a) + -- using scoped type variables, but we use the + -- more verbose form here, for compatibility with Hugs + +unitTc :: TyCon +unitTc = mkTyCon "()" + +instance Typeable () where + typeOf _ = mkAppTy unitTc [] + +tup2Tc :: TyCon +tup2Tc = mkTyCon "," + +instance (Typeable a, Typeable b) => Typeable (a,b) where + typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu), + typeOf ((undefined :: (a,b) -> b) tu)] + +tup3Tc :: TyCon +tup3Tc = mkTyCon ",," + +instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where + typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu), + typeOf ((undefined :: (a,b,c) -> b) tu), + typeOf ((undefined :: (a,b,c) -> c) tu)] + +tup4Tc :: TyCon +tup4Tc = mkTyCon ",,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d) => Typeable (a,b,c,d) where + typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu), + typeOf ((undefined :: (a,b,c,d) -> b) tu), + typeOf ((undefined :: (a,b,c,d) -> c) tu), + typeOf ((undefined :: (a,b,c,d) -> d) tu)] +tup5Tc :: TyCon +tup5Tc = mkTyCon ",,,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d + , Typeable e) => Typeable (a,b,c,d,e) where + typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu), + typeOf ((undefined :: (a,b,c,d,e) -> b) tu), + typeOf ((undefined :: (a,b,c,d,e) -> c) tu), + typeOf ((undefined :: (a,b,c,d,e) -> d) tu), + typeOf ((undefined :: (a,b,c,d,e) -> e) tu)] + +instance (Typeable a, Typeable b) => Typeable (a -> b) where + typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f)) + (typeOf ((undefined :: (a -> b) -> b) f)) + + + +------------------------------------------------------- +-- +-- Generate Typeable instances for standard datatypes +-- +------------------------------------------------------- + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +INSTANCE_TYPEABLE2(Either,eitherTc,"Either") +INSTANCE_TYPEABLE1(IO,ioTc,"IO") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") +INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr") + +INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") + +INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") + +INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef") + +#endif /* GHC < 6.3 */ + + +--------------------------------------------- +-- +-- Internals +-- +--------------------------------------------- + +newtype Key = Key Int deriving( Eq ) + +data KeyPr = KeyPr !Key !Key deriving( Eq ) + +hashKP :: KeyPr -> Int32 +hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime + +data Cache = Cache { next_key :: !(IORef Key), + tc_tbl :: !(HT.HashTable String Key), + ap_tbl :: !(HT.HashTable KeyPr Key) } + +{-# NOINLINE cache #-} +cache :: Cache +cache = unsafePerformIO $ do + empty_tc_tbl <- HT.new (==) HT.hashString + empty_ap_tbl <- HT.new (==) hashKP + key_loc <- newIORef (Key 1) + return (Cache { next_key = key_loc, + tc_tbl = empty_tc_tbl, + ap_tbl = empty_ap_tbl }) + +newKey :: IORef Key -> IO Key +newKey _ = do i <- genSym; return (Key i) + + +-- In GHC we use the RTS's genSym function to get a new unique, +-- because in GHCi we might have two copies of the Data.Typeable +-- library running (one in the compiler and one in the running +-- program), and we need to make sure they don't share any keys. +-- +-- This is really a hack. A better solution would be to centralise the +-- whole mutable state used by this module, i.e. both hashtables. But +-- the current solution solves the immediate problem, which is that +-- dynamics generated in one world with one type were erroneously +-- being recognised by the other world as having a different type. +-- +-- dons: SimonM says we need to unify the hashes by storing them in a +-- variable in the rts. +-- +foreign import ccall unsafe "genSymZh" + genSym :: IO Int + +mkTyConKey :: String -> Key +mkTyConKey str + = unsafePerformIO $ do + let Cache {next_key = kloc, tc_tbl = tbl} = cache + mb_k <- HT.lookup tbl str + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl str k ; + return k } + +appKey :: Key -> Key -> Key +appKey k1 k2 + = unsafePerformIO $ do + let Cache {next_key = kloc, ap_tbl = tbl} = cache + mb_k <- HT.lookup tbl kpr + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl kpr k ; + return k } + where + kpr = KeyPr k1 k2 + +appKeys :: Key -> [Key] -> Key +appKeys k ks = foldl appKey k ks diff --git a/src/altdata/Makefile b/src/altdata/Makefile new file mode 100644 index 0000000..e2a79dd --- /dev/null +++ b/src/altdata/Makefile @@ -0,0 +1,7 @@ +PKG = altdata +UPKG = AltData + +TOP=../.. +include ../build.mk + +install: install-me diff --git a/src/altdata/altdata.conf.in.cpp b/src/altdata/altdata.conf.in.cpp new file mode 100644 index 0000000..252ec8f --- /dev/null +++ b/src/altdata/altdata.conf.in.cpp @@ -0,0 +1,53 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "altdata", + auto = False, + hs_libraries = [ "HSaltdata" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}" ], +#else + import_dirs = [ "${TOP}/src/altdata" ], + library_dirs = [ "${TOP}/src/altdata" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "base" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: altdata +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + AltData.Dynamic, + AltData.Typeable, + AltData + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/altdata +library-dirs: TOP/src/altdata +#endif +hs-libraries: HSaltdata +extra-libraries: +include-dirs: +includes: +depends: base +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif diff --git a/src/build.mk b/src/build.mk new file mode 100644 index 0000000..310e688 --- /dev/null +++ b/src/build.mk @@ -0,0 +1,91 @@ +# +# Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +include $(TOP)/config.mk + +MAIN = $(UPKG).hs +LIBRARY = libHS$(PKG).a +GHCI_LIBRARY = HS$(PKG).o +OBJS = $(UPKG).o $(UPKG)/*.o + +HC_OPTS = -package-name $(PKG) +HC_OPTS += -O -Wall -Werror -fno-warn-missing-signatures $(GHC_EXTRA_OPTS) + +CLEANS += $(LIBRARY) $(GHCI_LIBRARY) +CLEAN_FILES += *.conf.inplace* *.conf.*.old *.conf.in *.h *.in + +.PHONY: clean all alt_objs inplace-pkg-conf happy banner + +all : $(LIBRARY) inplace-pkg-conf $(PKG).conf.in + +# libraries +$(LIBRARY): banner $(COBJ) $(XOBJ) $(YOBJ) objs + @$(RM) -f $@ + @$(AR) cq $@ $(OBJS) + @$(RANLIB) $@ + +banner: + @echo "=========== building $(PKG) =============" + +# happy files +$(YOBJ): $(YSRC) + $(HAPPY) $(HAPPY_OPTS) -o $@ $(YSRC) + +# alex files +$(XOBJ): $(XSRC) + $(ALEX) $(ALEX_OPTS) -o $@ $(XSRC) + +# objects +objs:: + $(GHC) $(HC_OPTS) --make -no-hs-main -no-link $(MAIN) + +$(COBJ): $(CSRC) + $(GHC) -c $(CSRC) -o $@ + +# package.confs and friends +# ghc-6.2.2 needs TOP as env var. +inplace-pkg-conf: $(LIBRARY) + @rm -f $(GHCI_LIBRARY) + @cpp -DTOP=$(TOP) -DGLASGOW_HASKELL=$(GLASGOW_HASKELL) -DCABAL=$(CABAL) -undef < $(PKG).conf.in.cpp | sed -e 's/""//g' -e 's/\[ *,/[ /g' -e '/^#/d' > $(PKG).conf.inplace.in + @(cd $(TOP) ;\ + if [ ! -f plugins.conf.inplace ]; then echo [] > plugins.conf.inplace; fi;\ + env TOP=$(TOP) $(GHC_PKG) -g -f plugins.conf.inplace -u < src/$(PKG)/$(PKG).conf.inplace.in) + +# installation pkg.confs +$(PKG).conf.in : $(PKG).conf.in.cpp + @cpp -DLIBDIR=$(LIBDIR) -DGLASGOW_HASKELL=$(GLASGOW_HASKELL) -DCABAL=$(CABAL) -DINSTALLING -Uunix < $(PKG).conf.in.cpp | sed -e 's/""//g' -e 's/\[ *,/[ /g' -e '/^#/d' > $@ + +# +# todo. need to re-ranlib the library +# +.PHONY: install install-me +install-me: + $(INSTALL_DATA_DIR) $(LIBDIR)/imports/$(UPKG) + @for i in $(TOP)/src/$(PKG)/*.hi ; do \ + echo $(INSTALL_DATA) $$i $(LIBDIR)/imports/ ; \ + $(INSTALL_DATA) $$i $(LIBDIR)/imports/ ; \ + done + @for i in $(TOP)/src/$(PKG)/$(UPKG)/*.hi ; do \ + echo $(INSTALL_DATA) $$i $(LIBDIR)/imports/$(UPKG)/ ; \ + $(INSTALL_DATA) $$i $(LIBDIR)/imports/$(UPKG)/ ; \ + done + $(INSTALL_DATA) $(TOP)/src/$(PKG)/libHS$(PKG).a $(LIBDIR) + $(RANLIB) $(LIBDIR)/libHS$(PKG).a + $(INSTALL_DATA) $(TOP)/src/$(PKG)/HS$(PKG).o $(LIBDIR) + $(INSTALL_DATA) $(TOP)/src/$(PKG)/$(PKG).conf.in $(LIBDIR) + +clean: + rm -f $(CLEAN_FILES) + find . -name '*.a' -exec rm {} \; + find . -name '*.in' -exec rm {} \; + find . -name '*~' -exec rm {} \; + find . -name 'a.out' -exec rm {} \; + find . -name '*.hi' -exec rm {} \; + find . -name '*.o' -exec rm {} \; + find . -name '*.old' -exec rm {} \; + find . -name '*.core' -exec rm {} \; + find . -name '*_stub.c' -exec rm {} \; + find . -name '*_stub.h' -exec rm {} \; + diff --git a/src/eval/Eval.hs b/src/eval/Eval.hs new file mode 100644 index 0000000..9a6e9e7 --- /dev/null +++ b/src/eval/Eval.hs @@ -0,0 +1,27 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Eval ( + module Eval.Haskell, + module Eval.Meta, + ) where + +import Eval.Haskell {-all-} +import Eval.Meta {-all-} + diff --git a/src/eval/Eval/Haskell.hs b/src/eval/Eval/Haskell.hs new file mode 100644 index 0000000..f147543 --- /dev/null +++ b/src/eval/Eval/Haskell.hs @@ -0,0 +1,250 @@ +{-# OPTIONS -fglasgow-exts -fffi #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- + +module Eval.Haskell ( + eval, + eval_, + unsafeEval, + unsafeEval_, + typeOf, + + hs_eval_b, -- return a Bool + hs_eval_c, -- return a CChar + hs_eval_i, -- return a CInt + hs_eval_s, -- return a CString + + module Eval.Utils, + + ) where + +import Eval.Utils + +import Plugins.Make +import Plugins.Load + +import AltData.Dynamic +import AltData.Typeable ( Typeable ) + +import Data.Either + +import System.IO +import System.Directory + +import Foreign.C +import Foreign + +-- +-- ok. the idea is: the have either installed the library, in which case +-- is is registered, and the path to altdata is known to ghc, so just +-- saying "-package altdata" will work. if not, we search in the build +-- dir just in case. this should work for inplace work. +-- +-- TODO could have a few extra package.conf search paths in here, +-- including PREFIX. +-- + +-- --------------------------------------------------------------------- +-- return a compiled value, and type check it first +-- +-- TODO make this faster. +-- +eval :: Typeable a => String -> [Import] -> IO (Maybe a) +eval src mods = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf cmdline + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- dynload obj [pwd] loadpath symbol + case m_v of LoadFailure _ -> return Nothing + LoadSuccess _ rsrc -> return $ Just rsrc + MakeFailure err -> mapM_ putStrLn err >> return Nothing + makeCleaner tmpf + return m_rsrc + +-- --------------------------------------------------------------------- +-- Version of eval with all the buttons available. +eval_ :: Typeable a => + String -- ^ code to compile + -> [Import] -- ^ any imports + -> [String] -- ^ extra make flags + -> [FilePath] -- ^ (package.confs) for load + -> [FilePath] -- ^ include paths load is to search in + -> IO (Either [String] (Maybe a)) -- ^ either errors, or maybe a well typed value + +eval_ src mods args ldflags incs = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths -- find path to altdata + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf $ ["-Onot"] ++ cmdline ++ args + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol + return $ case m_v of LoadFailure e -> Left e + LoadSuccess _ rsrc -> Right (Just rsrc) + MakeFailure err -> return $ Left err + makeCleaner tmpf + return m_rsrc + +-- --------------------------------------------------------------------- +-- unsafe because it doesn't use Dynamic types +-- useful for not having to provide type constraints to values, or when +-- you want to easily deal with polymorphic values. +-- +unsafeEval :: String -> [Import] -> IO (Maybe a) +unsafeEval src mods = do + pwd <- getCurrentDirectory + tmpf <- mkUniqueWith wrap src mods + status <- make tmpf ["-Onot"] + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- load obj [pwd] [] symbol + case m_v of LoadFailure _ -> return Nothing + LoadSuccess _ rsrc -> return $ Just rsrc + MakeFailure err -> mapM_ putStrLn err >> return Nothing +-- makeCleaner tmpf + return m_rsrc + +-- +-- like unsafeEval, except you can supply extra args to make and load, +-- and the error messages are returned too. +-- +-- Need to be able to specify a search path to look in. +-- +unsafeEval_ :: String -- ^ code to compile + -> [Import] -- ^ any imports + -> [String] -- ^ make flags + -> [FilePath] -- ^ (package.confs) for load + -> [FilePath] -- ^ include paths load is to search in + -> IO (Either [String] a) + +unsafeEval_ src mods args ldflags incs = do + pwd <- getCurrentDirectory + tmpf <- mkUniqueWith wrap src mods + status <- make tmpf $ ["-Onot"] ++ args + e_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- load obj (pwd:incs) ldflags symbol + case m_v of LoadFailure e -> return $ Left e + LoadSuccess _ rsrc -> return $ Right rsrc + MakeFailure err -> return $ Left err + makeCleaner tmpf + return e_rsrc + +------------------------------------------------------------------------ +-- +-- return a compiled value's type, by using Dynamic to get a +-- representation of the inferred type. +-- +typeOf :: String -> [Import] -> IO String +typeOf src mods = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf cmdline + ty <- case status of + MakeSuccess _ obj -> do + m_v <- load obj [pwd] loadpath symbol + case m_v of + LoadFailure _ -> return "" + LoadSuccess _ (v::Dynamic) -> return $ (init . tail) $ show v + + MakeFailure err -> mapM_ putStrLn err >> return [] + makeCleaner tmpf + return ty + +-- +-- note that the wrapper uses our altdata library for dynamic typing. +-- hence it needs to see the path to the altdata package. grr. is it +-- installed or not? what path does it have? +-- +dynwrap :: String -> String -> [Import] -> String +dynwrap expr nm mods = + "module "++nm++ "( resource ) where\n" ++ + concatMap (\m-> "import "++m++"\n") mods ++ + "import AltData.Dynamic\n" ++ + "resource = let { v = \n" ++ + "{-# LINE 1 \"\" #-}\n" ++ expr ++ ";} in toDyn v" + +-- --------------------------------------------------------------------- +-- unsafe wrapper +-- +wrap :: String -> String -> [Import] -> String +wrap expr nm mods = + "module "++nm++ "( resource ) where\n" ++ + concatMap (\m-> "import "++m++"\n") mods ++ + "resource = let { v = \n" ++ + "{-# LINE 1 \"\" #-}\n" ++ expr ++ ";} in v" + +------------------------------------------------------------------------ +-- +-- And for our friends in foreign parts +-- +-- TODO needs to accept char** to import list +-- + +-- +-- return NULL pointer if an error occured. +-- + +foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt) +foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar) +foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt) +foreign export ccall hs_eval_s :: CString -> IO CString + +------------------------------------------------------------------------ +-- +-- TODO implement a marshalling for Dynamics, so that we can pass that +-- over to the C side for checking. +-- + +hs_eval_b :: CString -> IO (Ptr CInt) +hs_eval_b s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> new (fromBool v) + +hs_eval_c :: CString -> IO (Ptr CChar) +hs_eval_c s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> new (castCharToCChar v) + +-- should be Integral +hs_eval_i :: CString -> IO (Ptr CInt) +hs_eval_i s = do m_v <- eval_cstring s :: IO (Maybe Int) + case m_v of Nothing -> return nullPtr + Just v -> new (fromIntegral v :: CInt) + +hs_eval_s :: CString -> IO CString +hs_eval_s s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> newCString v + +-- +-- convenience +-- +eval_cstring :: Typeable a => CString -> IO (Maybe a) +eval_cstring cs = do s <- peekCString cs + eval s [] -- TODO use eval() + diff --git a/src/eval/Eval/Meta.hs b/src/eval/Eval/Meta.hs new file mode 100644 index 0000000..8f24510 --- /dev/null +++ b/src/eval/Eval/Meta.hs @@ -0,0 +1,96 @@ +{-# OPTIONS -cpp -fth #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- an implementation of the staged compilation primitives from +-- "Dynamic Typing as Staged Type Inference" +-- Shields, Sheard and Jones, 1998 +-- http://doi.acm.org/10.1145/268946.268970 +-- + +module Eval.Meta ( + + run, + defer, + splice, + + ) where + +import Eval.Haskell ( eval ) +import AltData.Typeable ( Typeable ) + +#if __GLASGOW_HASKELL__ > 602 +import Language.Haskell.TH ( ExpQ, pprint, runQ ) +#else +import Language.Haskell.THSyntax ( ExpQ, pprExp, runQ ) +import Text.PrettyPrint ( render ) +#endif + +import System.IO.Unsafe ( unsafePerformIO ) + +type ExpR = String -- hack for splicing + +-- +-- defer the evaluation of an expression by one stage. +-- uses [| |] just for the nice syntax. +-- +-- defer [| 1 + 1 |] --> (1 + 1) +-- +defer :: ExpQ -> ExpR +#if __GLASGOW_HASKELL__ > 602 +defer e = pprint (unsafePerformIO (runQ e)) +#else +defer e = render $ pprExp (unsafePerformIO (runQ e)) +#endif + +-- +-- evaluate 'e' to a deferred expression, and evaluate the result. +-- +-- run( defer [|1+1|] ) --> 2 +-- +run :: (Show t, Typeable t) => ExpR -> t +run e = case unsafePerformIO (eval e imports) of + Nothing -> error "source failed to compile" + Just a -> a + +-- +-- evaluate 'e' to a deferred expression. then splice the result back in +-- to the surrounding deferred expression. splice() is only legal within +-- deferred expressions. +-- +-- let code = defer [| 1 + 1 |] in defer [| splice(code) + 2 |] +-- --> +-- defer [| 1 + 1 + 2 |] +-- +-- defer( "\x -> " ++ splice (v) ) +-- +splice :: Show t => t -> ExpR +splice e = show e + +-- +-- libraries needed +-- +imports = + [ + "GHC.Base", + "GHC.Num", + "GHC.List" + ] + diff --git a/src/eval/Eval/Utils.hs b/src/eval/Eval/Utils.hs new file mode 100644 index 0000000..828e4c8 --- /dev/null +++ b/src/eval/Eval/Utils.hs @@ -0,0 +1,121 @@ +{-# OPTIONS -fglasgow-exts -fffi -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- + +module Eval.Utils ( + + Import, + symbol, + escape, + getPaths, + find_altdata_pkgconf, + + mkUniqueWith, + cleanup, + + module Data.Maybe, + module Control.Monad, + + ) where + +import Plugins.Load ( Symbol ) +import Plugins.Utils +import Plugins.Consts ( top {- :{ -} ) + +import System.IO +import System.Directory + +import Data.Char + +-- +-- we export these so that eval() users have a nice time +-- +import Data.Maybe +import Control.Monad + +-- +-- imports Foo's +-- +type Import = String + +-- +-- distinguished symbol name +-- +symbol :: Symbol +symbol = "resource" + +-- +-- turn a Haskell string into a printable version of the same string +-- +escape s = concatMap (\c -> showLitChar c $ "") s + +-- +-- For Dynamic eval's, work out the compile and load command lines +-- +getPaths :: IO ([String],[String]) +getPaths = do + m_pkg <- find_altdata_pkgconf + let load_path = if isJust m_pkg then fromJust m_pkg else [] + let make_line = + let compulsory = ["-Onot","-fglasgow-exts","-package","altdata"] + in if not $ null load_path + then "-package-conf":load_path:compulsory + else compulsory + let load_path' = if null load_path then [] else [load_path] + return (make_line,load_path') + +-- --------------------------------------------------------------------- +-- if we are in-tree eval() needs to use the inplace package.conf to +-- find altdata, otherwise we need it to be in the ghc package system. +-- +-- fixing Typeable/Dynamic in ghc obsoletes this code. as would adding +-- an extra param to eval, which I don't want to do. +-- +find_altdata_pkgconf :: IO (Maybe String) +find_altdata_pkgconf = do + let f = top "plugins.conf.inplace" + b <- doesFileExist f + return $ if b + then Just f + else Nothing + +-- --------------------------------------------------------------------- +-- create the tmp file, and write source into it, using wrapper to +-- create extra .hs src. +-- +mkUniqueWith :: (String -> String -> [Import] -> String) + -> String + -> [Import] -> IO FilePath + +mkUniqueWith wrapper src mods = do + (tmpf,hdl) <- hMkUnique + let nm = mkModid (basename tmpf) -- used as a module name + src' = wrapper src nm mods + hPutStr hdl src' >> hFlush hdl >> hClose hdl >> return tmpf + +-- +-- remove all the tmp files +-- +cleanup :: String -> String -> IO () +cleanup a b = mapM_ removeFile [a, b, replaceSuffix b ".hi"] + diff --git a/src/eval/Makefile b/src/eval/Makefile new file mode 100644 index 0000000..875aa09 --- /dev/null +++ b/src/eval/Makefile @@ -0,0 +1,12 @@ +PKG = eval +UPKG = Eval + +TOP=../.. +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package plugins + +GHC6_3_HC_OPTS += -package template-haskell + +install: install-me diff --git a/src/eval/eval.conf.in.cpp b/src/eval/eval.conf.in.cpp new file mode 100644 index 0000000..eeb639e --- /dev/null +++ b/src/eval/eval.conf.in.cpp @@ -0,0 +1,60 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "eval", + auto = False, + hs_libraries = [ "HSeval" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/eval" ], + library_dirs = [ "${TOP}/src/eval" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "plugins" +#if GLASGOW_HASKELL >= 603 + , "template-haskell" +#endif + ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else + +name: eval +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + Eval.Haskell, + Eval.Meta, + Eval.Utils, + Eval + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/eval +library-dirs: TOP/src/eval +#endif +hs-libraries: HSeval +extra-libraries: +include-dirs: +includes: +depends: plugins, template-haskell +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: + +#endif diff --git a/src/hi/Hi.hs b/src/hi/Hi.hs new file mode 100644 index 0000000..9fe3069 --- /dev/null +++ b/src/hi/Hi.hs @@ -0,0 +1,25 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Hi ( + module Hi.Parser + ) where + +import Hi.Parser {-all-} + diff --git a/src/hi/Hi/Binary.hs b/src/hi/Hi/Binary.hs new file mode 100644 index 0000000..a265d7b --- /dev/null +++ b/src/hi/Hi/Binary.hs @@ -0,0 +1,566 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-unused-imports -fno-warn-name-shadowing #-} +{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- Based on $fptools/ghc/compiler/utils/Binary.hs: +-- (c) The University of Glasgow 2002 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ +-- +-- We never have to write stuff, so I've scrubbed all the put* code. +-- + +module Hi.Binary ( + {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + + openBinIO, openBinIO_, + openBinMem, +-- closeBin, + + seekBin, + tellBin, + castBin, + + readBinMem, + + isEOFBin, + + -- for writing instances: + getByte, + + -- lazy Bin I/O + lazyGet, + + -- GHC only: + ByteArray(..), + getByteArray, + + getBinFileWithDict, -- :: Binary a => FilePath -> IO a + + ) where + +-- The *host* architecture version: +#include "MachDeps.h" + +-- import Hi.Utils -- ? + +import Hi.FastMutInt +import Hi.FastString + +#if __GLASGOW_HASKELL__ < 604 +import Data.FiniteMap +#else +import qualified Data.Map as M +#endif + +import Data.Unique + +import Data.Array.IO +import Data.Array +import Data.Bits +import Data.Int +import Data.Word +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Array.Base ( unsafeRead, unsafeWrite ) +import Control.Monad ( when ) +import System.IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import GHC.Exts +import GHC.IOBase ( IO(..) ) +import GHC.Word ( Word8(..) ) +#if __GLASGOW_HASKELL__ < 601 +import GHC.Handle ( openFileEx, IOModeEx(..) ) +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile f mode = openFileEx f (BinaryMode mode) +#endif + +type BinArray = IOUArray Int Word8 + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + off_r :: !FastMutInt, -- the current offset + sz_r :: !FastMutInt, -- size of the array (cached) + arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + + | BinIO { -- binary data stored in a file + bh_usr :: UserData, + off_r :: !FastMutInt, -- the current offset (cached) + hdl :: !Handle -- the file handle (must be seekable) + } + -- cache the file ptr in BinIO; using hTell is too expensive + -- to call repeatedly. If anyone else is modifying this Handle + -- at the same time, we'll be screwed. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +class Binary a where + get :: BinHandle -> IO a + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinIO_ :: Handle -> IO BinHandle +openBinIO_ h = openBinIO h + +openBinIO :: Handle -> IO BinHandle +openBinIO h = do + r <- newFastMutInt + writeFastMutInt r 0 + return (BinIO noUserData r h) + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Hi.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- newArray_ (0,size-1) + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin (BinIO _ ix_r h) (BinPtr p) = do + writeFastMutInt ix_r p + hSeek h AbsoluteSeek (fromIntegral p) +seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem _ ix_r sz_r a) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) +isEOFBin (BinIO _ ix_r h) = hIsEOF h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- newArray_ (0,filesize-1) + count <- hGetArray h arr filesize + when (count /= filesize) + (error ("Hi.Binary.readBinMem: only read " ++ show count ++ " bytes")) + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ ix_r sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newArray_ (0,sz'-1) + sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i + | i <- [ 0 .. sz-1 ] ] + writeFastMutInt sz_r sz' + writeIORef arr_r arr' +#ifdef DEBUG + hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') +#endif + return () +expandBin (BinIO _ _ _) _ = return () + -- no need to expand a file, we'll assume they expand by themselves. + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +getWord8 :: BinHandle -> IO Word8 +getWord8 (BinMem _ ix_r sz_r arr_r) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ +#if __GLASGOW_HASKELL__ <= 408 + throw (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) +#else + ioError (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) +#endif + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w +getWord8 (BinIO _ ix_r h) = do + ix <- readFastMutInt ix_r + c <- hGetChar h + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + +getByte :: BinHandle -> IO Word8 +getByte = getWord8 + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + get = getWord8 + +instance Binary Word16 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + +instance Binary Word32 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + +instance Binary Word64 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + w5 <- getWord8 h + w6 <- getWord8 h + w7 <- getWord8 h + w8 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +instance Binary Int64 where + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + get _ = return () + +instance Binary Bool where + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif + +instance Binary a => Binary [a] where + get bh = do h <- getWord8 bh + case h of + 0 -> return [] + _ -> do x <- get bh + xs <- get bh + return (x:xs) + +instance (Binary a, Binary b) => Binary (a,b) where + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance Binary a => Binary (Maybe a) where + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +#ifdef __GLASGOW_HASKELL__ +instance Binary Integer where + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + + +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +#if __GLASGOW_HASKELL__ < 503 +writeByteArray arr i w8 = IO $ \s -> + case word8ToWord w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> + (# s , () #) }} +#else +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } +#endif + +#if __GLASGOW_HASKELL__ < 503 +indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) +#else +indexByteArray a# n# = W8# (indexWord8Array# a# n#) +#endif + +instance (Integral a, Binary a) => Binary (Ratio a) where + get bh = do a <- get bh; b <- get bh; return (a :% b) +#endif + +instance Binary (Bin a) where + get bh = do i <- get bh; return (BinPtr i) + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO (getAt bh p_a) + seekBin bh p -- skip over the object for now + return a + +-- -------------------------------------------------------------- +-- Main wrappers: getBinFileWithDict, putBinFileWithDict +-- +-- This layer is built on top of the stuff above, +-- and should not know anything about BinHandles +-- -------------------------------------------------------------- + +initBinMemSize = (1024*1024) :: Int +binaryInterfaceMagic = 0x1face :: Word32 + +getBinFileWithDict :: Binary a => FilePath -> IO a +getBinFileWithDict file_path = do + bh <- Hi.Binary.readBinMem file_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + + when (magic /= binaryInterfaceMagic) $ + error "magic number mismatch: old/corrupt interface file?" + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Hi.Binary.get bh -- Get the dictionary ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + + seekBin bh data_p -- Back to where we were before + + -- Initialise the user-data field of bh + let bh' = setUserData bh (initReadState dict) + + -- At last, get the thing + get bh' + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +data UserData = + UserData { -- This field is used only when reading + ud_dict :: Dictionary, + + -- The next two fields are only used when writing + ud_next :: IORef Int, -- The next index to use +#if __GLASGOW_HASKELL__ < 604 + ud_map :: IORef (FiniteMap Unique (Int,FastString)) +#else + ud_map :: IORef (M.Map Unique (Int,FastString)) +#endif + } + +noUserData = error "Hi.Binary.UserData: no user data" + +initReadState :: Dictionary -> UserData +initReadState dict = UserData{ ud_dict = dict, + ud_next = undef "next", + ud_map = undef "map" } + +newWriteState :: IO UserData +newWriteState = do + j_r <- newIORef 0 +#if __GLASGOW_HASKELL__ < 604 + out_r <- newIORef emptyFM +#else + out_r <- newIORef M.empty +#endif + return (UserData { ud_dict = error "dict", + ud_next = j_r, + ud_map = out_r }) + + +undef s = error ("Hi.Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +#if __GLASGOW_HASKELL__ < 604 +constructDictionary :: Int -> FiniteMap Unique (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (eltsFM fm) +#else +constructDictionary :: Int -> M.Map Unique (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (M.elems fm) +#endif + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +getFS bh = do + (I# l) <- get bh + (BA ba) <- getByteArray bh (I# l) + return $! (mkFastSubStringBA# ba 0# l) + +instance Binary FastString where + get bh = do j <- get bh -- Int + return $! (ud_dict (getUserData bh) ! j) + diff --git a/src/hi/Hi/FastMutInt.hs b/src/hi/Hi/FastMutInt.hs new file mode 100644 index 0000000..4c3292e --- /dev/null +++ b/src/hi/Hi/FastMutInt.hs @@ -0,0 +1,81 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on code from $fptools/ghc/compiler/utils/FastMutInt.lhs +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. + +-- +-- Unboxed mutable Ints +-- + +module Hi.FastMutInt ( + FastMutInt, + newFastMutInt, + readFastMutInt, + writeFastMutInt, + incFastMutInt, + incFastMutIntBy + ) where + +#include "MachDeps.h" + +#if __GLASGOW_HASKELL__ < 503 +import GlaExts +import PrelIOBase +#else +import GHC.Base +import GHC.IOBase +#endif + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# 1#) s of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# n) s of { s -> + (# s, I# i #) } } + diff --git a/src/hi/Hi/FastString.hs b/src/hi/Hi/FastString.hs new file mode 100644 index 0000000..2eff02e --- /dev/null +++ b/src/hi/Hi/FastString.hs @@ -0,0 +1,508 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +{-# OPTIONS -#include "hschooks.h" #-} + +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on $fptools/ghc/compiler/utils/FastString.lhs +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +-- +-- Fast strings +-- +-- Compact representations of character strings with +-- unique identifiers (hash-cons'ish). +-- + +module Hi.FastString + ( + FastString(..), -- not abstract, for now. + + mkFastString, -- :: String -> FastString + mkFastStringNarrow, -- :: String -> FastString + mkFastSubString, -- :: Addr -> Int -> Int -> FastString + + mkFastString#, -- :: Addr# -> FastString + mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString + + mkFastStringInt, -- :: [Int] -> FastString + + uniqueOfFS, -- :: FastString -> Int# + lengthFS, -- :: FastString -> Int + nullFastString, -- :: FastString -> Bool + + unpackFS, -- :: FastString -> String + unpackIntFS, -- :: FastString -> [Int] + appendFS, -- :: FastString -> FastString -> FastString + headFS, -- :: FastString -> Char + headIntFS, -- :: FastString -> Int + tailFS, -- :: FastString -> FastString + concatFS, -- :: [FastString] -> FastString + consFS, -- :: Char -> FastString -> FastString + indexFS, -- :: FastString -> Int -> Char + nilFS, -- :: FastString + + hPutFS, -- :: Handle -> FastString -> IO () + + LitString, + mkLitString# -- :: Addr# -> LitString + ) where + +import Hi.PrimPacked + +import IO +import Char ( chr, ord ) + +import GHC.Exts +import GHC.IOBase +import GHC.Arr ( STArray(..), newSTArray ) +import GHC.Handle + +import Foreign.C + +-- import System.IO.Unsafe ( unsafePerformIO ) +-- import Control.Monad.ST ( stToIO ) +-- import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) + + +#define hASH_TBL_SIZE 993 + +{- +@FastString@s are packed representations of strings +with a unique id for fast comparisons. The unique id +is assigned when creating the @FastString@, using +a hash table to map from the character string representation +to the unique ID. +-} + +data FastString + = FastString -- packed repr. on the heap. + Int# -- unique id + -- 0 => string literal, comparison + -- will + Int# -- length + ByteArray# -- stuff + + | UnicodeStr -- if contains characters outside '\1'..'\xFF' + Int# -- unique id + [Int] -- character numbers + +instance Eq FastString where + -- shortcut for real FastStrings + (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2 + a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False } + + (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2 + a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +lengthFS :: FastString -> Int +lengthFS (FastString _ l# _) = I# l# +lengthFS (UnicodeStr _ s) = length s + +nullFastString :: FastString -> Bool +nullFastString (FastString _ l# _) = l# ==# 0# +nullFastString (UnicodeStr _ []) = True +nullFastString (UnicodeStr _ (_:_)) = False + +unpackFS :: FastString -> String +unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#) +unpackFS (UnicodeStr _ s) = map chr s + +unpackIntFS :: FastString -> [Int] +unpackIntFS (UnicodeStr _ s) = s +unpackIntFS fs = map ord (unpackFS fs) + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2) + +concatFS :: [FastString] -> FastString +concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better + +headFS :: FastString -> Char +headFS (FastString _ l# ba#) = + if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS") +headFS (UnicodeStr _ (c:_)) = chr c +headFS (UnicodeStr _ []) = error ("headFS: empty FS") + +headIntFS :: FastString -> Int +headIntFS (UnicodeStr _ (c:_)) = c +headIntFS fs = ord (headFS fs) + +indexFS :: FastString -> Int -> Char +indexFS f i@(I# i#) = + case f of + FastString _ l# ba# + | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#) + | otherwise -> error (msg (I# l#)) + UnicodeStr _ s -> chr (s!!i) + where + msg l = "indexFS: out of range: " ++ show (l,i) + +tailFS :: FastString -> FastString +tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) +tailFS fs = mkFastStringInt (tail (unpackIntFS fs)) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastStringInt (ord c : unpackIntFS fs) + +uniqueOfFS :: FastString -> Int# +uniqueOfFS (FastString u# _ _) = u# +uniqueOfFS (UnicodeStr u# _) = u# + +nilFS = mkFastString "" + +{- +GHC-related stuff: + +Internally, the compiler will maintain a fast string symbol +table, providing sharing and fast comparison. Creation of +new @FastString@s then covertly does a lookup, re-using the +@FastString@ if there was a hit. + +Caution: mkFastStringUnicode assumes that if the string is in the +table, it sits under the UnicodeStr constructor. Other mkFastString +variants analogously assume the FastString constructor. +-} + +data FastStringTable = + FastStringTable + Int# + (MutableArray# RealWorld [FastString]) + +type FastStringTableVar = IORef FastStringTable + +string_table :: FastStringTableVar +string_table = + unsafePerformIO ( + stToIO (newSTArray (0::Int,hASH_TBL_SIZE) []) + >>= \ (STArray _ _ arr#) -> + newIORef (FastStringTable 0# arr#)) + +lookupTbl :: FastStringTable -> Int# -> IO [FastString] +lookupTbl (FastStringTable _ arr#) i# = + IO ( \ s# -> + readArray# arr# i# s#) + +updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO () +updTbl fs_table_var (FastStringTable uid# arr#) i# ls = + IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> + (# s2#, () #) }) >> + writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#) + +mkFastString# :: Addr# -> FastString +mkFastString# a# = + case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# } + +mkFastStringLen# :: Addr# -> Int# -> FastString +mkFastStringLen# a# len# = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashStr a# len# + in +-- _trace ("hashed: "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray + -- _trace "empty bucket" $ + case copyPrefixStr a# (I# len#) of + BA barr# -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h [f_str] >> + ({- _trace ("new: " ++ show f_str) $ -} return f_str) + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket"++show ls) $ + case bucket_match ls len# a# of + Nothing -> + case copyPrefixStr a# (I# len#) of + BA barr# -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h (f_str:ls) >> + ( {- _trace ("new: " ++ show f_str) $ -} return f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} return v) + where + bucket_match [] _ _ = Nothing + bucket_match (v@(FastString _ l# ba#):ls) len# a# = + if len# ==# l# && eqStrPrefix a# ba# l# then + Just v + else + bucket_match ls len# a# + bucket_match (UnicodeStr _ _ : ls) len# a# = + bucket_match ls len# a# + +mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString +mkFastSubStringBA# barr# start# len# = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashSubStrBA barr# start# len# + in +-- _trace ("hashed(b): "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray + -- _trace "empty bucket(b)" $ + case copySubStrBA (BA barr#) (I# start#) (I# len#) of + BA ba# -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h [f_str] >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket(b)"++show ls) $ + case bucket_match ls start# len# barr# of + Nothing -> + case copySubStrBA (BA barr#) (I# start#) (I# len#) of + BA ba# -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h (f_str:ls) >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + Just v -> + -- _trace ("re-use(b): "++show v) $ + return v + ) + where + bucket_match [] _ _ _ = Nothing + bucket_match (v:ls) start# len# ba# = + case v of + FastString _ l# barr# -> + if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then + Just v + else + bucket_match ls start# len# ba# + UnicodeStr _ _ -> bucket_match ls start# len# ba# + +mkFastStringUnicode :: [Int] -> FastString +mkFastStringUnicode s = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashUnicode s + in +-- _trace ("hashed(b): "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a [Int] + let f_str = UnicodeStr uid# s in + updTbl string_table ft h [f_str] >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket(b)"++show ls) $ + case bucket_match ls of + Nothing -> + let f_str = UnicodeStr uid# s in + updTbl string_table ft h (f_str:ls) >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + Just v -> + -- _trace ("re-use(b): "++show v) $ + return v + ) + where + bucket_match [] = Nothing + bucket_match (v@(UnicodeStr _ s'):ls) = + if s' == s then Just v else bucket_match ls + bucket_match (FastString _ _ _ : ls) = bucket_match ls + +mkFastStringNarrow :: String -> FastString +mkFastStringNarrow str = + case packString str of { (I# len#, BA frozen#) -> + mkFastSubStringBA# frozen# 0# len# + } + {- 0-indexed array, len# == index to one beyond end of string, + i.e., (0,1) => empty string. -} + +mkFastString :: String -> FastString +mkFastString str = if all good str + then mkFastStringNarrow str + else mkFastStringUnicode (map ord str) + where + good c = c >= '\1' && c <= '\xFF' + +mkFastStringInt :: [Int] -> FastString +mkFastStringInt str = if all good str + then mkFastStringNarrow (map chr str) + else mkFastStringUnicode str + where + good c = c >= 1 && c <= 0xFF + +mkFastSubString :: Addr# -> Int -> Int -> FastString +mkFastSubString a# (I# start#) (I# len#) = + mkFastStringLen# (a# `plusAddr#` start#) len# + +hashStr :: Addr# -> Int# -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr a# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + c0 = indexCharOffAddr# a# 0# + c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#) + c2 = indexCharOffAddr# a# (len# -# 1#) +{- + c1 = indexCharOffAddr# a# 1# + c2 = indexCharOffAddr# a# 2# +-} + +hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int# + -- use the byte array to produce a hash value between 0 & m (inclusive) +hashSubStrBA ba# start# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + c0 = indexCharArray# ba# (start# +# 0#) + c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#)) + c2 = indexCharArray# ba# (start# +# (len# -# 1#)) + +-- c1 = indexCharArray# ba# 1# +-- c2 = indexCharArray# ba# 2# + +hashUnicode :: [Int] -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashUnicode [] = 0# +hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE# +hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE# +hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + I# len# = length s + I# c0 = s !! 0 + I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#)) + I# c2 = s !! (I# (len# -# 1#)) + +cmpFS :: FastString -> FastString -> Ordering +cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ + else compare s1 s2 +cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2) +cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2 +cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) = + if u1# ==# u2# then EQ else + let l# = if l1# <=# l2# then l1# else l2# in + unsafePerformIO ( + memcmp b1# b2# l# >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then + if l1# ==# l2# then EQ + else if l1# <# l2# then LT else GT + else GT + )) + +foreign import ccall unsafe "memcmp" + memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +#if __GLASGOW_HASKELL__ >= 504 + +-- this is our own version of hPutBuf for FastStrings, because in +-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA. +-- The closest is hPutArray in Data.Array.IO, but that does some extra +-- range checks that we want to avoid here. + +foreign import ccall unsafe "__hscore_memcpy_dst_off" + memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) + +hPutFS handle (FastString _ l# ba#) + | l# ==# 0# = return () + | otherwise + = do wantWritableHandle "hPutFS" handle $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do + + old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } + <- readIORef ref + + let count = I# l# + raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld + + -- enough room in handle buffer? + if (size - w > count) + -- There's enough room in the buffer: + -- just copy the data in and update bufWPtr. + then do memcpy_baoff_ba old_raw w raw (fromIntegral count) + writeIORef ref old_buf{ bufWPtr = w + count } + return () + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer fd stream old_buf + writeIORef ref flushed_buf + let this_buf = + Buffer{ bufBuf=raw, bufState=WriteBuffer, + bufRPtr=0, bufWPtr=count, bufSize=count } + flushWriteBuffer fd stream this_buf + return () + +#else + +hPutFS :: Handle -> FastString -> IO () +hPutFS handle (FastString _ l# ba#) + | l# ==# 0# = return () + | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#) + hPutBufBAFull handle mba (I# l#) + where + bot = error "hPutFS.ba" + +#endif + +-- ONLY here for debugging the NCG (so -ddump-stix works for string +-- literals); no idea if this is really necessary. JRS, 010131 +hPutFS handle (UnicodeStr _ is) + = hPutStr handle ("(UnicodeStr " ++ show is ++ ")") + +-- ----------------------------------------------------------------------------- +-- LitStrings, here for convenience only. + +type LitString = Ptr () +-- ToDo: make it a Ptr when we don't have to support 4.08 any more + +mkLitString# :: Addr# -> LitString +mkLitString# a# = Ptr a# diff --git a/src/hi/Hi/Parser.hs b/src/hi/Hi/Parser.hs new file mode 100644 index 0000000..6b1bb55 --- /dev/null +++ b/src/hi/Hi/Parser.hs @@ -0,0 +1,722 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-name-shadowing #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Based on $fptools/ghc/compiler/iface/BinIface.hs +-- +-- (c) The University of Glasgow 2002 +-- +-- Binary interface file support. +-- + +-- +-- This provides the "Binary" instances for the Iface type such that we +-- can parse binary representations of that type. i.e. from .hi files +-- +-- The main problem we have is that all the stuff we don't care about, +-- we just want to read in to a string. So this has to be hand-hacked +-- somewhat. +-- +-- The "Binary" class for hs-plugins only includes a get method. We +-- don't do any writing. Saves us having to properly reconstruct the +-- abstract syntax, which would pull in *way* too much of GHC. +-- + + + +module Hi.Parser ( readIface, module Hi.Syntax ) where + +import Hi.Syntax +import Hi.Binary +import Hi.FastString + +import GHC.Word + +#include "../../../config.h" + +-- --------------------------------------------------------------------------- +-- how to get there from here + +readIface :: FilePath -> IO Iface +readIface hi_path = getBinFileWithDict hi_path + +-- --------------------------------------------------------------------- +-- All the Binary instances +-- +-- Reading a binary interface into ParsedIface +-- +-- We pull the trick of only reading up to the point we need +-- + +instance Binary Iface where + get bh = do + version <- get bh :: IO String + build_tag <- get bh :: IO Word8 -- 'way' flag + +#if __GLASGOW_HASKELL__ >= 604 + mod_name <- get bh :: IO FastString + _is_boot <- get bh :: IO Bool + let pkg_name = mkFastString "unknown" -- >=604 has no package field +#elif CABAL == 1 && __GLASGOW_HASKELL__ == 603 + mod_name <- get bh :: IO FastString + let pkg_name = mkFastString "unknown" +#else /* <= 622 */ + mod_name <- get bh :: IO FastString + pkg_name <- get bh :: IO FastString +#endif + mod_vers <- get bh :: IO Version + orphan <- get bh :: IO Bool + deps <- get bh :: IO Dependencies + + get bh :: IO (Bin Int) -- fake a lazyGet for [Usage] + usages <- get bh :: IO [Usage] + + exports <- get bh :: IO [IfaceExport] + +-- (exp_vers :: Version) <- get bh +-- (fixities :: [(OccName,Fixity)]) <- get bh +-- (deprecs :: [IfaceDeprec]) <- get bh + +-- (decls :: [(Version,IfaceDecl)])<- get bh + +-- (insts :: [IfaceInst]) <- get bh +-- (rules :: [IfaceRule]) <- get bh +-- (rule_vers :: Version) <- get bh + + return $ Iface { + mi_package = unpackFS pkg_name, + mi_module = unpackFS mod_name, + mi_deps = deps , + mi_usages = usages, + mi_exports = exports {-,-} + +-- mi_mod_vers = mod_vers, +-- mi_boot = False, -- .hi files are never .hi-boot files! +-- mi_orphan = orphan, +-- mi_usages = usages, +-- mi_exports = exports, +-- mi_exp_vers = exp_vers, +-- mi_fixities = fixities, +-- mi_deprecs = deprecs, +-- mi_decls = decls, +-- mi_insts = insts, +-- mi_rules = rules, +-- mi_rule_vers = rule_vers + } + +------------------------------------------------------------------------ +-- +-- Types from: Iface.hs, HscTypes +-- + +-- fake a lazyGet +instance Binary Dependencies where + get bh = do get bh :: IO (Bin Int) -- really a BinPtr Int + ms <- get bh :: IO [(FastString,Bool)] + ps <- get bh :: IO [FastString] + _ <- get bh :: IO [FastString] -- !!orphans + return Deps { dep_mods = map unpackFS $! map fst ms, + dep_pkgs = map unpackFS ps {-,-} + } + +------------------------------------------------------------------------ +-- Usages +------------------------------------------------------------------------ + +instance Binary OccName where + get bh = do aa <- get bh :: IO NameSpace + ab <- get bh :: IO FastString + return $ OccName aa (unpackFS ab) + +instance Binary NameSpace where + get bh = do h <- getByte bh + case h of + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + _ -> return TcClsName + +instance Binary Usage where + get bh = do (nm :: FastString) <- get bh + (mod :: Version) <- get bh + (exps :: Maybe Version) <- get bh + (ents :: [(OccName,Version)]) <- get bh + (rules :: Version) <- get bh + return $ Usage {usg_name = (unpackFS nm), + usg_mod = mod, + usg_exports = exps, + usg_entities = ents, + usg_rules = rules } + +------------------------------------------------------------------------ +-- Exports + +instance (Binary name) => Binary (GenAvailInfo name) where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: name) <- get bh + return $ Avail aa + _ -> do (ab :: name) <- get bh + (ac :: [name]) <- get bh + return $ AvailTC ab ac + +{- +instance Binary a => Binary (Deprecs a) where + get bh = do + h <- getByte bh + case h of + 0 -> return Deprecs + 1 -> do (aa :: FastString) <- get bh + return Deprecs + _ -> do (ab :: a) <- get bh + return Deprecs +-} + +------------------------------------------------------------------------- +-- Types from: BasicTypes +------------------------------------------------------------------------- + +{- +instance Binary Activation where + get bh = do + h <- getByte bh + case h of + 0 -> return Activation + 1 -> return Activation + 2 -> do (aa :: Int) <- get bh ; return Activation + _ -> do (ab :: Int) <- get bh ; return Activation + +instance Binary StrictnessMark where + get bh = do + h <- getByte bh + case h of + 0 -> return StrictnessMark + 1 -> return StrictnessMark + _ -> return StrictnessMark + +instance Binary Boxity where + get bh = do + h <- getByte bh + case h of + 0 -> return Boxity + _ -> return Boxity + +instance Binary TupCon where + get bh = do + (ab :: Boxity) <- get bh + (ac :: Arity) <- get bh + return TupCon + +instance Binary RecFlag where + get bh = do + h <- getByte bh + case h of + 0 -> return RecFlag + _ -> return RecFlag + +instance Binary DefMeth where + get bh = do + h <- getByte bh + case h of + 0 -> return DefMeth + 1 -> return DefMeth + _ -> return DefMeth + +instance Binary FixityDirection where + get bh = do + h <- getByte bh + case h of + 0 -> return FixityDirection + 1 -> return FixityDirection + _ -> return FixityDirection + +instance Binary Fixity where + get bh = do + (aa :: Int) <- get bh + (ab :: FixityDirection) <- get bh + return Fixity + +instance (Binary name) => Binary (IPName name) where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: name) <- get bh ; return IPName + _ -> do (ab :: name) <- get bh ; return IPName + +------------------------------------------------------------------------- +-- Types from: basicTypes/NewDemand +------------------------------------------------------------------------- + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + get bh = do (ds :: [Demand]) <- get bh + (dr :: DmdResult) <- get bh + return DmdType + +instance Binary Demand where + get bh = do + h <- getByte bh + case h of + 0 -> return Demand + 1 -> return Demand + 2 -> do (aa :: Demand) <- get bh ; return Demand + 3 -> do (ab :: Demands) <- get bh ; return Demand + 4 -> do (ac :: Demands) <- get bh ; return Demand + 5 -> do (ad :: Demand) <- get bh ; return Demand + _ -> return Demand + +instance Binary Demands where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Demand) <- get bh + return Demands + _ -> do (ab :: [Demand]) <- get bh + return Demands + +instance Binary DmdResult where + get bh = do + h <- getByte bh + case h of + 0 -> return DmdResult + 1 -> return DmdResult + _ -> return DmdResult + +instance Binary StrictSig where + get bh = do (aa :: DmdType) <- get bh ; return StrictSig +-} + +------------------------------------------------------------------------- +-- Types from: CostCentre, from profiling/CostCentre.lhs +------------------------------------------------------------------------- + +{- +instance Binary IsCafCC where + get bh = do + h <- getByte bh + case h of + 0 -> return IsCafCC + _ -> return IsCafCC + +instance Binary IsDupdCC where + get bh = do + h <- getByte bh + case h of + 0 -> return IsDupdCC + _ -> return IsDupdCC + +instance Binary CostCentre where + get bh = do + h <- getByte bh + case h of + 0 -> do return CostCentre + 1 -> do (aa :: CcName) <- get bh + (ab :: ModuleName) <- get bh + (ac :: IsDupdCC) <- get bh + (ad :: IsCafCC) <- get bh + return CostCentre + _ -> do (ae :: ModuleName) <- get bh + return CostCentre +-} + +------------------------------------------------------------------------- +-- IfaceTypes and friends, from IfaceType.lhs +------------------------------------------------------------------------- + +{- +instance Binary IfaceExtName where + get bh = do + h <- getByte bh + case h of + 0 -> do (mod :: ModuleName) <- get bh + (occ :: OccName) <- get bh + return IfaceExtName + 1 -> do (mod :: ModuleName) <- get bh + (occ :: OccName) <- get bh + (vers :: Version) <- get bh + return IfaceExtName + _ -> do (occ :: OccName) <- get bh + return IfaceExtName + +instance Binary IfaceBndr where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceIdBndr) <- get bh ; return IfaceBndr + _ -> do (ab :: IfaceTvBndr) <- get bh ; return IfaceBndr + +instance Binary Kind where + get bh = do + h <- getByte bh + case h of + 0 -> return Kind + 1 -> return Kind + 2 -> return Kind + 3 -> return Kind + 4 -> return Kind + _ -> do (k1 :: Kind) <- get bh + (k2 :: Kind) <- get bh + return Kind + +instance Binary IfaceType where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceTvBndr) <- get bh + (ab :: IfaceType) <- get bh + return IfaceType + 1 -> do (ad :: OccName) <- get bh + return IfaceType + 2 -> do (ae :: IfaceType) <- get bh + (af :: IfaceType) <- get bh + return IfaceType + 3 -> do (ag :: IfaceType) <- get bh + (ah :: IfaceType) <- get bh + return IfaceType + 5 -> do (ap :: IfacePredType) <- get bh + return IfaceType + + -- Now the special cases for TyConApp + 6 -> return IfaceType + 7 -> return IfaceType + 8 -> return IfaceType + 9 -> do (ty :: IfaceType) <- get bh + return IfaceType + 10 -> return IfaceType + 11 -> do (t1 :: IfaceType) <- get bh + (t2 :: IfaceType) <- get bh + return IfaceType + 12 -> do (tc :: IfaceExtName) <- get bh + (tys :: [IfaceType]) <- get bh + return IfaceType + _ -> do (tc :: IfaceTyCon) <- get bh + (tys :: [IfaceType]) <- get bh + return IfaceType + +instance Binary IfaceTyCon where + get bh = do + h <- getByte bh + case h of + 1 -> return IfaceTyCon + 2 -> return IfaceTyCon + _ -> do (bx :: Boxity) <- get bh + (ar :: Arity) <- get bh + return IfaceTyCon + +instance Binary IfacePredType where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceExtName) <- get bh + (ab :: [IfaceType]) <- get bh + return IfacePredType + _ -> do (ac :: (IPName OccName)) <- get bh + (ad :: IfaceType) <- get bh + return IfacePredType + +instance Binary IfaceExpr where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: OccName) <- get bh + return IfaceExpr + 1 -> do (ab :: IfaceType) <- get bh + return IfaceExpr + 2 -> do (ac :: Boxity) <- get bh + (ad :: [IfaceExpr]) <- get bh + return IfaceExpr + 3 -> do (ae :: IfaceBndr) <- get bh + (af :: IfaceExpr) <- get bh + return IfaceExpr + 4 -> do (ag :: IfaceExpr) <- get bh + (ah :: IfaceExpr) <- get bh + return IfaceExpr + 5 -> do (ai :: IfaceExpr) <- get bh + (aj :: OccName) <- get bh + (ak :: [IfaceAlt]) <- get bh + return IfaceExpr + 6 -> do (al :: IfaceBinding) <- get bh + (am :: IfaceExpr) <- get bh + return IfaceExpr + 7 -> do (an :: IfaceNote) <- get bh + (ao :: IfaceExpr) <- get bh + return IfaceExpr + 8 -> do (ap :: Literal) <- get bh + return IfaceExpr + 9 -> do (as :: ForeignCall) <- get bh + (at :: IfaceType) <- get bh + return IfaceExpr + _ -> do (aa :: IfaceExtName) <- get bh + return IfaceExpr + +instance Binary IfaceConAlt where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceConAlt + 1 -> do (aa :: OccName) <- get bh + return IfaceConAlt + 2 -> do (ab :: Boxity) <- get bh + return IfaceConAlt + _ -> do (ac :: Literal) <- get bh + return IfaceConAlt + +instance Binary IfaceBinding where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceIdBndr) <- get bh + (ab :: IfaceExpr) <- get bh + return IfaceBinding + _ -> do (ac :: [(IfaceIdBndr,IfaceExpr)]) <- get bh + return IfaceBinding + +instance Binary IfaceIdInfo where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceIdInfo + _ -> do (info :: [IfaceInfoItem]) <- lazyGet bh + return IfaceIdInfo + +instance Binary IfaceInfoItem where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Arity) <- get bh + return IfaceInfoItem + 1 -> do (ab :: StrictSig) <- get bh + return IfaceInfoItem + 2 -> do (ac :: Activation) <- get bh + (ad :: IfaceExpr) <- get bh + return IfaceInfoItem + 3 -> return IfaceInfoItem + _ -> do (ae :: IfaceExtName) <- get bh + (af :: Arity) <- get bh + return IfaceInfoItem + +instance Binary IfaceNote where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CostCentre) <- get bh + return IfaceNote + 1 -> do (ab :: IfaceType ) <- get bh + return IfaceNote + 2 -> return IfaceNote + 3 -> return IfaceNote + _ -> do (ac :: String) <- get bh + return IfaceNote + +instance Binary IfaceDecl where + get bh = do + h <- getByte bh + case h of + 0 -> do + (name :: OccName) <- get bh + (ty :: IfaceType) <- get bh + (idinfo :: IfaceIdInfo) <- get bh + return IfaceDecl + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do + (a1 :: IfaceContext) <- get bh + (a2 :: OccName) <- get bh + (a3 :: [IfaceTvBndr]) <- get bh + (a4 :: IfaceConDecls) <- get bh + (a5 :: RecFlag) <- get bh + (a6 :: ArgVrcs) <- get bh + (a7 :: Bool) <- get bh + return IfaceDecl + 3 -> do + (aq :: OccName) <- get bh + (ar :: [IfaceTvBndr]) <- get bh + (as :: ArgVrcs) <- get bh + (at :: IfaceType) <- get bh + return IfaceDecl + _ -> do + (a1 :: IfaceContext) <- get bh + (a2 :: OccName) <- get bh + (a3 :: [IfaceTvBndr]) <- get bh + (a4 :: [FunDep OccName])<- get bh + (a5 :: [IfaceClassOp]) <- get bh + (a6 :: RecFlag) <- get bh + (a7 :: ArgVrcs) <- get bh + return IfaceDecl + +instance Binary IfaceInst where + get bh = do + (ty :: IfaceType) <- get bh + (dfun :: OccName) <- get bh + return IfaceInst + +instance Binary IfaceConDecls where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceConDecls + 1 -> do (aa :: [IfaceConDecl]) <- get bh + return IfaceConDecls + _ -> do (aa :: IfaceConDecl) <- get bh + return IfaceConDecls + +instance Binary IfaceConDecl where + get bh = do + (a1 :: OccName) <- get bh + (a2 :: [IfaceTvBndr]) <- get bh + (a3 :: IfaceContext) <- get bh + (a4 :: [IfaceType]) <- get bh + (a5 :: [StrictnessMark])<- get bh + (a6 :: [OccName]) <- get bh + return IfaceConDecl + +instance Binary IfaceClassOp where + get bh = do + (n :: OccName) <- get bh + (def :: DefMeth) <- get bh + (ty :: IfaceType) <- get bh + return IfaceClassOp + +instance Binary IfaceRule where + get bh = do + (a1 :: RuleName) <- get bh + (a2 :: Activation) <- get bh + (a3 :: [IfaceBndr]) <- get bh + (a4 :: IfaceExtName) <- get bh + (a5 :: [IfaceExpr]) <- get bh + (a6 :: IfaceExpr) <- get bh + return IfaceRule + +-} + +------------------------------------------------------------------------ +-- from Literal +------------------------------------------------------------------------ + +{- +instance Binary Literal where + get bh = do + h <- getByte bh + case h of + 0 -> do + (aa :: Char) <- get bh + return Literal + 1 -> do + (ab :: FastString) <- get bh + return Literal + 2 -> do return Literal + 3 -> do + (ad :: Integer) <- get bh + return Literal + 4 -> do + (ae :: Integer) <- get bh + return Literal + 5 -> do + (af :: Integer) <- get bh + return Literal + 6 -> do + (ag :: Integer) <- get bh + return Literal + 7 -> do + (ah :: Rational) <- get bh + return Literal + 8 -> do + (ai :: Rational) <- get bh + return Literal + 9 -> do + (aj :: FastString) <- get bh + (mb :: Maybe Int) <- get bh + return Literal + _ -> return Literal -- ? + +-} + +------------------------------------------------------------------------ +-- prelude/ForeignCall.lhs +------------------------------------------------------------------------ + +{- +instance Binary ForeignCall where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CCallSpec) <- get bh + return ForeignCall + _ -> do (ab :: DNCallSpec) <- get bh + return ForeignCall + +instance Binary Safety where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Bool) <- get bh + return Safety + _ -> return Safety + +instance Binary CExportSpec where + get bh = do + (aa :: CLabelString) <- get bh + (ab :: CCallConv) <- get bh + return CExportSpec + +instance Binary CCallSpec where + get bh = do + (aa :: CCallTarget) <- get bh + (ab :: CCallConv) <- get bh + (ac :: Safety) <- get bh + return CCallSpec + +instance Binary CCallTarget where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CLabelString) <- get bh + return CCallTarget + _ -> return CCallTarget + +instance Binary CCallConv where + get bh = do + h <- getByte bh + case h of + 0 -> return CCallConv + _ -> return CCallConv + +instance Binary DNCallSpec where + get bh = do + (isStatic :: Bool) <- get bh + (kind :: DNKind) <- get bh + (ass :: String) <- get bh + (nm :: String) <- get bh + return DNCallSpec + +instance Binary DNKind where + get bh = do + h <- getByte bh + case h of + _ -> return DNKind + +instance Binary DNType where + get bh = do + h <- getByte bh + case h of + _ -> return DNType + +-} diff --git a/src/hi/Hi/PrimPacked.hs b/src/hi/Hi/PrimPacked.hs new file mode 100644 index 0000000..ad8b87d --- /dev/null +++ b/src/hi/Hi/PrimPacked.hs @@ -0,0 +1,194 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +{-# OPTIONS -#include "hschooks.h" #-} + +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on $fptools/ghc/compiler/utils/PrimPacked.lhs +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +-- +-- +-- Basic ops on packed representations +-- +-- Some basic operations for working on packed representations of series +-- of bytes (character strings). Used by the interface lexer input +-- subsystem, mostly. + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + +module Hi.PrimPacked ( + Ptr(..), nullPtr, plusAddr#, + BA(..), + packString, -- :: String -> (Int, BA) + unpackNBytesBA, -- :: BA -> Int -> [Char] + strLength, -- :: Ptr CChar -> Int + copyPrefixStr, -- :: Addr# -> Int -> BA + copySubStrBA, -- :: BA -> Int -> Int -> BA + eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool + eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool + ) where + +import Foreign +import GHC.Exts +import GHC.ST + +-- Wrapper types for bytearrays + +data BA = BA ByteArray# +data MBA s = MBA (MutableByteArray# s) + +packString :: String -> (Int, BA) +packString str = (l, arr) + where + l@(I# length#) = length str + + arr = runST (do + ch_array <- new_ps_array length# + -- fill in packed string from "str" + fill_in ch_array 0# str + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> [Char] -> ST s () + fill_in arr_in# idx [] = + return () + fill_in arr_in# idx (C# c : cs) = + write_ps_array arr_in# idx c >> + fill_in arr_in# (idx +# 1#) cs + +-- Unpacking a string + +unpackNBytesBA :: BA -> Int -> [Char] +unpackNBytesBA (BA bytes) (I# len) + = unpack 0# + where + unpack nh + | nh >=# len = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharArray# bytes nh + +-- Copying a char string prefix into a byte array. + +copyPrefixStr :: Addr# -> Int -> BA +copyPrefixStr a# len@(I# length#) = copy' length# + where + copy' length# = runST (do + {- allocate an array that will hold the string + -} + ch_array <- new_ps_array length# + {- Revert back to Haskell-only solution for the moment. + _ccall_ memcpy ch_array (A# a) len >>= \ () -> + write_ps_array ch_array length# (chr# 0#) >> + -} + -- fill in packed string from "addr" + fill_in ch_array 0# + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> ST s () + fill_in arr_in# idx + | idx ==# length# + = return () + | otherwise + = case (indexCharOffAddr# a# idx) of { ch -> + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) } + +-- Copying out a substring, assume a 0-indexed string: +-- (and positive lengths, thank you). + +copySubStrBA :: BA -> Int -> Int -> BA +copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba + where + ba = runST (do + -- allocate an array that will hold the string + ch_array <- new_ps_array length# + -- fill in packed string from "addr" + fill_in ch_array 0# + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> ST s () + fill_in arr_in# idx + | idx ==# length# + = return () + | otherwise + = case (indexCharArray# barr# (start# +# idx)) of { ch -> + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) } + +-- (Very :-) ``Specialised'' versions of some CharArray things... +-- [Copied from PackBase; no real reason -- UGH] + +new_ps_array :: Int# -> ST s (MBA s) +write_ps_array :: MBA s -> Int# -> Char# -> ST s () +freeze_ps_array :: MBA s -> Int# -> ST s BA + +#if __GLASGOW_HASKELL__ < 411 +#define NEW_BYTE_ARRAY newCharArray# +#else +#define NEW_BYTE_ARRAY newByteArray# +#endif + +new_ps_array size = ST $ \ s -> + case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) -> + (# s2#, MBA barr# #) } + +write_ps_array (MBA barr#) n ch = ST $ \ s# -> + case writeCharArray# barr# n ch s# of { s2# -> + (# s2#, () #) } + +-- same as unsafeFreezeByteArray +freeze_ps_array (MBA arr#) len# = ST $ \ s# -> + case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> + (# s2#, BA frozen# #) } + +-- Compare two equal-length strings for equality: + +eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool +eqStrPrefix a# barr# len# = + unsafePerformIO $ do + x <- memcmp_ba a# barr# (I# len#) + return (x == 0) + +eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool +eqStrPrefixBA b1# b2# start# len# = + unsafePerformIO $ do + x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#) + return (x == 0) + +------------------------------------------------------------------------ +-- in hschooks +-- + +foreign import ccall unsafe "plugin_strlen" + strLength :: Ptr () -> Int + +foreign import ccall unsafe "plugin_memcmp" + memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int + +foreign import ccall unsafe "plugin_memcmp_off" + memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int + diff --git a/src/hi/Hi/Syntax.hs b/src/hi/Hi/Syntax.hs new file mode 100644 index 0000000..e37f644 --- /dev/null +++ b/src/hi/Hi/Syntax.hs @@ -0,0 +1,360 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on code from $fptools/ghc/compiler/main/HscTypes.lhs +-- (c) The University of Glasgow 2002 +-- + +module Hi.Syntax where + +import Hi.FastString + +import Data.List ( intersperse ) + +-- --------------------------------------------------------------------- +-- An Iface, the representation of an .hi file. +-- +-- The abstract syntax that we don't need is blanked with a default +-- type, however we must be careful in BinIface to still parse the +-- correct number of bytes for each data type. This involves leaving the +-- code alone, other than to add the types of the sub-constructors of +-- the types we have blanked out (because they can't be inferred +-- anymore). +-- + +data Iface = Iface { + mi_package :: String, -- what package is this? + mi_module :: String, -- what module is this? + mi_deps :: Dependencies, + mi_usages :: [Usage], + mi_exports :: [IfaceExport] {-,-} + +-- mi_decls :: [(Version,IfaceDecl)] {-,-} + +-- mi_mod_vers :: !Version, +-- mi_orphan :: !Bool, +-- mi_boot :: !Bool, +-- mi_exp_vers :: !Version, +-- mi_fixities :: [(OccName,Fixity)], +-- mi_deprecs :: [IfaceDeprec], +-- mi_insts :: [IfaceInst], +-- mi_rules :: [IfaceRule], +-- mi_rule_vers :: !Version, + } + +emptyIface = Iface { + mi_package = undefined, + mi_module = undefined, + mi_deps = noDependencies, + mi_usages = undefined, + mi_exports = undefined + } + +-- --------------------------------------------------------------------- +-- pretty-print an interface +-- +showIface :: Iface -> String +showIface (Iface { mi_package = p, mi_module = m, + mi_deps = deps, mi_usages = us }) = + "interface \"" ++ p ++ "\" " ++ m ++ + "\n" ++ pprDeps deps ++ + "\n" ++ (concat $ intersperse "\n" (map pprUsage us)) + -- "\n" ++ (concat $ intersperse "\n" (map pprExport es)) + +pprDeps :: Dependencies -> String +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs }) + = "module dependencies: " ++ (concat $ intersperse ", " mods) ++ + "\npackage dependencies: " ++ (concat $ intersperse ", " pkgs) + +pprUsage :: Usage -> String +pprUsage usage = hsep ["import", usg_name usage] + +pprExport :: IfaceExport -> String +pprExport (fsmod, items) + = hsep [ "export", unpackFS fsmod, hsep (map pp_avail items) ] + where + pp_avail :: GenAvailInfo OccName -> String + pp_avail (Avail nm) = ppr_occ nm + pp_avail (AvailTC _ []) = empty + pp_avail (AvailTC n (n':ns)) + | n==n' = (ppr_occ n) ++ pp_export ns + | otherwise = (ppr_occ n) ++ "|" ++ pp_export (n':ns) + + pp_export [] = empty + pp_export names = "{" ++ (hsep (map ppr_occ names)) ++ "}" + + ppr_occ (OccName _ s) = s + +-- +-- TODO bring in the Pretty library +-- +hsep = \ss -> concat (intersperse " " ss) +empty = "" + +-- --------------------------------------------------------------------- +-- +-- Dependency info about modules and packages below this one +-- in the import hierarchy. See TcRnTypes.ImportAvails for details. +-- +-- Invariant: the dependencies of a module M never includes M +-- Invariant: the lists are unordered, with no duplicates +-- +-- The fields are: +-- Home-package module dependencies +-- External package dependencies +-- Orphan modules (whether home or external pkg) + +data Dependencies = Deps { + dep_mods :: [ModuleName], + dep_pkgs :: [PackageName] {-,-} + } deriving (Show) + +noDependencies :: Dependencies +noDependencies = Deps [] [] + +-- +-- Type aliases need to have a real type so the parser can work out how +-- to parse them. You have to find what these are by reading GHC. +-- +type ModuleName = String {- was FastString -} -- Module +type PackageName = String {- was FastString -} -- Packages +type Version = Int -- BasicTypes +type EncodedFS = FastString -- FastString +type IfaceExport = (EncodedFS, [GenAvailInfo OccName]) -- HscTypes + +data GenAvailInfo name + = Avail name -- An ordinary identifier + | AvailTC name -- The name of the type or class + [name] -- The available pieces of type/class. + -- NB: If the type or class is itself + -- to be in scope, it must be in this list. + -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving Show + +data OccName = OccName NameSpace String {- was EncodedFS -} + deriving Show + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +data NameSpace = VarName -- variables, and "source" data constructors + | DataName -- "real" data constructors + | TvName -- tyvars + | TcClsName -- type constructors and classes + deriving (Eq, Show) + +data Usage + = Usage { usg_name :: ModuleName, -- Name of the module + usg_mod :: Version, -- Module version + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_entities :: [(OccName,Version)],-- Sorted by occurrence name + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) + } deriving Show + +------------------------------------------------------------------------ +-- TODO parsing type and decl information out of the .hi file +-- complex data structure... +-- + +{- +data IfaceExtName + = ExtPkg ModuleName OccName -- From an external package; no version # + -- Also used for wired-in things regardless + -- of whether they are home-pkg or not + + | HomePkg ModuleName OccName Version -- From another module in home package; + -- has version # + + | LocalTop OccName -- Top-level from the same module as + -- the enclosing IfaceDecl + + | LocalTopSub -- Same as LocalTop, but for a class method or constr + OccName -- Class-meth/constr name + OccName -- Parent class/datatype name + -- LocalTopSub is written into iface files as LocalTop; the parent + -- info is only used when computing version information in MkIface + +data IfaceTyCon -- Abbreviations for common tycons with known names + = IfaceTc IfaceExtName -- The common case + | IfaceIntTc | IfaceBoolTc | IfaceCharTc + | IfaceListTc | IfacePArrTc + | IfaceTupTc Boxity Arity + +type Arity = Int -- BasicTypes + +data Boxity + = Boxed + | Unboxed + +type IfaceContext = [IfacePredType] + +data IfacePredType -- NewTypes are handled as ordinary TyConApps + = IfaceClassP IfaceExtName [IfaceType] + | IfaceIParam (IPName OccName) IfaceType + +data IPName name + = Dupable name -- ?x: you can freely duplicate this implicit parameter + | Linear name -- %x: you must use the splitting function to duplicate it + deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map + -- (used in HscTypes.OrigIParamCache) + +data IfaceType + = IfaceTyVar OccName -- Type variable only, not tycon + | IfaceAppTy IfaceType IfaceType + | IfaceForAllTy IfaceTvBndr IfaceType + | IfacePredTy IfacePredType + | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceFunTy IfaceType IfaceType + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr IfaceIdBndr + | IfaceTvBndr IfaceTvBndr + +type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local +type IfaceTvBndr = (OccName, IfaceKind) +type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsUnfold Activation IfaceExpr + | HsNoCafRefs + | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. + -- NB: we need IfaceExtName (not just OccName) because the worker + -- can simplify to a function in another module. +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +newtype StrictSig = StrictSig DmdType + +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifCtxt :: IfaceContext, -- Context + ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifVrcs :: ArgVrcs, + ifGeneric :: Bool -- True <=> generic converter functions available + } -- We need this for imported data decls, since the + -- imported modules may have been compiled with + -- different flags to the current compilation unit + + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifVrcs :: ArgVrcs, + ifSynRhs :: IfaceType -- synonym expansion + } + + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + } + + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + ifExtName :: Maybe FastString } +-} + +------------------------------------------------------------------------ +-- +-- all this stuff may be enabled if we ever want other information out +-- + +{- +type ArgVrcs = [(Bool,Bool)] -- TyCon +type CLabelString = FastString -- CStrings +type CcName = EncodedFS -- CostCentre +type DeprecTxt = FastString -- BasicTypes +type FunDep a = ([a],[a]) -- Class +type IfaceAlt = (IfaceConAlt,[OccName],IfaceExpr) -- IfaceSyn +type IfaceContext = [IfacePredType] -- IfaceType +type IfaceDeprec = Deprecs [(OccName,DeprecTxt)] -- HscTypes +type IfaceIdBndr = (OccName, IfaceType) -- IfaceType +type IfaceKind = Kind -- IfaceType +type IfaceTvBndr = (OccName, IfaceKind) -- IfaceType +type RuleName = FastString -- CoreSyn + +-- +-- Empty definitions for the various types we need, but whose results we +-- don't care about. +-- +-- 'data' types that have a parsing method associated with them +-- This list corresponds to each instance in BinIface +-- +-- Try to keep this list ordered by the order they appear in BinIface +-- +data Deprecs a = Deprecs +data Activation = Activation +data StrictnessMark = StrictnessMark +data Boxity = Boxity +data TupCon = TupCon +data RecFlag = RecFlag +data DefMeth = DefMeth +data FixityDirection = FixityDirection +data Fixity = Fixity +data DmdType = DmdType +data Demand = Demand +data Demands = Demands +data DmdResult = DmdResult +data StrictSig = StrictSig +data IsCafCC = IsCafCC +data IsDupdCC = IsDupdCC +data CostCentre = CostCentre +data IfaceExtName = IfaceExtName +data IfaceBndr = IfaceBndr +data Kind = Kind +data IfaceTyCon = IfaceTyCon +data IfacePredType = IfacePredType +data IfaceExpr = IfaceExpr +data IfaceConAlt = IfaceConAlt +data IfaceBinding = IfaceBinding +data IfaceIdInfo = IfaceIdInfo +data IfaceNoteItem = IfaceNoteItem +data IfaceInfoItem = IfaceInfoItem +data IfaceNote = IfaceNote +data IfaceInst = IfaceInst +data IfaceConDecls = IfaceConDecls +data IfaceConDecl = IfaceConDecl +data IfaceClassOp = IfaceClassOp +data IfaceRule = IfaceRule +data Literal = Literal +data ForeignCall = ForeignCall +data Safety = Safety +data CExportSpec = CExportSpec +data CCallSpec = CCallSpec +data CCallTarget = CCallTarget +data CCallConv = CCallConv +data DNCallSpec = DNCallSpec +data DNKind = DNKind +data DNType = DNType + +-} diff --git a/src/hi/Hi/hschooks.c b/src/hi/Hi/hschooks.c new file mode 100644 index 0000000..d2e4823 --- /dev/null +++ b/src/hi/Hi/hschooks.c @@ -0,0 +1,38 @@ +/* +These routines customise the error messages +for various bits of the RTS. They are linked +in instead of the defaults. +*/ + +#include + +/* For GHC 4.08, we are relying on the fact that RtsFlags has + * compatibile layout with the current version, because we're + * #including the current version of RtsFlags.h below. 4.08 didn't + * ship with its own RtsFlags.h, unfortunately. For later GHC + * versions, we #include the correct RtsFlags.h. + */ + +#include "Rts.h" +#include "RtsFlags.h" + +#include "HsFFI.h" + +HsInt +plugin_strlen( HsAddr a ) +{ + return (strlen((char *)a)); +} + +HsInt +plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1, a2, len)); +} + +HsInt +plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1 + i, a2, len)); +} + diff --git a/src/hi/Hi/hschooks.h b/src/hi/Hi/hschooks.h new file mode 100644 index 0000000..a1b47bb --- /dev/null +++ b/src/hi/Hi/hschooks.h @@ -0,0 +1,13 @@ +/* ----------------------------------------------------------------------------- + * $ Id: hschooks.h,v 1.1.1.1 2004/05/24 09:35:39 dons Exp $ + * + * Hooks into the RTS from the compiler. + * + * -------------------------------------------------------------------------- */ + +#include "HsFFI.h" + +// Out-of-line string functions, see PrimPacked.lhs +HsInt plugin_strlen( HsAddr a ); +HsInt plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ); +HsInt plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ); diff --git a/src/hi/Makefile b/src/hi/Makefile new file mode 100644 index 0000000..5d3b87d --- /dev/null +++ b/src/hi/Makefile @@ -0,0 +1,12 @@ +PKG = hi +UPKG = Hi + +CSRC = $(UPKG)/hschooks.c +COBJ = $(UPKG)/hschooks.o + +TOP=../.. +include ../build.mk + +HC_OPTS += -I$(UPKG) + +install: install-me diff --git a/src/hi/hi.conf.in.cpp b/src/hi/hi.conf.in.cpp new file mode 100644 index 0000000..bdea4b8 --- /dev/null +++ b/src/hi/hi.conf.in.cpp @@ -0,0 +1,57 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "hi", + auto = False, + hs_libraries = [ "HShi" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/hi" ], + library_dirs = [ "${TOP}/src/hi" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "base", "haskell98" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: hi +version: 1.0 +license: BSD3 +maintainer: libraries@haskell.org +exposed: True +exposed-modules: + Hi.Binary, + Hi.FastMutInt, + Hi.FastString, + Hi.Parser, + Hi.PrimPacked, + Hi.Syntax, + Hi + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/hi +library-dirs: TOP/src/hi +#endif +hs-libraries: HShi +extra-libraries: +include-dirs: +includes: +depends: base, haskell98 +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif diff --git a/src/plugins/Makefile b/src/plugins/Makefile new file mode 100644 index 0000000..c9f8061 --- /dev/null +++ b/src/plugins/Makefile @@ -0,0 +1,22 @@ +PKG = plugins +UPKG = Plugins + +TOP=../.. +include $(TOP)/config.mk + +ifeq ($(CABAL),1) +YOBJ = $(UPKG)/ParsePkgConfCabal.hs +YSRC = $(UPKG)/ParsePkgConfCabal.y +else +YOBJ = $(UPKG)/ParsePkgConfLite.hs +YSRC = $(UPKG)/ParsePkgConfLite.y +endif + +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package altdata -package hi -package posix +HC_OPTS += -O -funbox-strict-fields +HC_OPTS += -Wall -fno-warn-missing-signatures + +install: install-me diff --git a/src/plugins/Plugins.hs b/src/plugins/Plugins.hs new file mode 100644 index 0000000..08d0617 --- /dev/null +++ b/src/plugins/Plugins.hs @@ -0,0 +1,37 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins ( + + -- $Description + + module Plugins.Make, + module Plugins.Load, + + ) where + +import Plugins.Make {-all-} +import Plugins.Load {-all-} + +-- +-- $Description +-- +-- [@NAME@] hs-plugins library : compile and load Haskell code at runtime +-- + diff --git a/src/plugins/Plugins/Consts.hs b/src/plugins/Plugins/Consts.hs new file mode 100644 index 0000000..cd3a292 --- /dev/null +++ b/src/plugins/Plugins/Consts.hs @@ -0,0 +1,62 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Consts where + +#include "../../../config.h" + +-- | path to *build* dir, used by eval() for testing the examples +top = TOP + +-- | what is ghc called? +ghc = GHC + +-- | path to standard ghc libraries +ghcLibraryPath = GHC_LIB_PATH + +-- | name of the system package.conf file +sysPkgConf = "package.conf" + +-- | This code is from runtime_loader: +-- The extension used by system modules. +sysPkgSuffix = ".o" +objSuf = sysPkgSuffix +hiSuf = ".hi" +hsSuf = ".hs" + +-- | The prefix used by system modules. This, in conjunction with +-- 'systemModuleExtension', will result in a module filename that looks +-- like \"HSconcurrent.o\" +sysPkgPrefix = "HS" + +-- | '_' on a.out, and Darwin +#if LEADING_UNDERSCORE == 1 +prefixUnderscore = "_" +#else +prefixUnderscore = "" +#endif + +-- | Define tmpDir to where tmp files should be created on your platform +#if !defined(__MINGW32__) +tmpDir = "/tmp" +#else +tmpDir = error "tmpDir not defined for this platform. Try setting the TMPDIR env var" +#endif + diff --git a/src/plugins/Plugins/Env.hs b/src/plugins/Plugins/Env.hs new file mode 100644 index 0000000..5d1fd0c --- /dev/null +++ b/src/plugins/Plugins/Env.hs @@ -0,0 +1,358 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Env ( + withModEnv, + withPkgEnvs, + withMerged, + modifyModEnv, + modifyPkgEnv, + modifyMerged, + addModule, + rmModule, + addModules, + isLoaded, + loaded, + isMerged, + lookupMerged, + addMerge, + addPkgConf, + union, + grabDefaultPkgConf, + readPackageConf, + lookupPkg + + ) where + +#include "../../../config.h" + +import Plugins.PackageAPI {- everything -} +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import Plugins.ParsePkgConfCabal( parsePkgConf ) +#else +import Plugins.ParsePkgConfLite ( parsePkgConf ) +#endif +import Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix ) + +import Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) +import Data.Maybe ( isJust ) +import Data.List ( isPrefixOf, nub ) + +import System.IO.Unsafe ( unsafePerformIO ) +import System.Directory ( doesFileExist ) + +import Control.Concurrent.MVar ( MVar(), newMVar, withMVar ) + +#if __GLASGOW_HASKELL__ < 604 +import Data.FiniteMap + +#else +import qualified Data.Map as M + +-- +-- and map Data.Map terms to FiniteMap terms +-- +type FiniteMap k e = M.Map k e + +emptyFM :: FiniteMap key elt +emptyFM = M.empty + +addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt +addToFM = \m k e -> M.insert k e m + +delFromFM :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt +delFromFM = flip M.delete + +lookupFM :: (Ord key) => FiniteMap key elt -> key -> Maybe elt +lookupFM = flip M.lookup + +#endif + +-- +-- We need to record what modules and packages we have loaded, so if we +-- read a .hi file that wants to load something already loaded, we can +-- safely ignore that request. We're in the IO monad anyway, so we can +-- add some extra state of our own. +-- +-- The state is a FiniteMap String Bool (a hash of package/object names +-- to whether they have been loaded or not). +-- +-- It also contains the package.conf information, so that if there is a +-- package dependency we can find it correctly, even if it has a +-- non-standard path or name, and if it isn't an official package (but +-- rather one provided via -package-conf). This is stored as a +-- FiniteMap PackageName PackageConfig. The problem then is whether a +-- user's package.conf, that uses the same package name as an existing +-- GHC package, should be allowed, or should shadow a library package? +-- I don't know, but I'm inclined to have the GHC package shadow the +-- user's package. +-- +-- This idea is based on *Hampus Ram's dynamic loader* dependency +-- tracking system. He uses state to record dependency trees to allow +-- clean unloading and other fun. This is quite cool. We're just using +-- state to make sure we don't load the same package twice. Implementing +-- the full dependency tree idea would be nice, though not fully +-- necessary as we have the dependency information store in .hi files, +-- unlike in hram's loader. +-- + +type ModEnv = FiniteMap String Bool + +-- represents a package.conf file +type PkgEnv = FiniteMap PackageName PackageConfig + +-- record dependencies between (src,stub) -> merged modid +type MergeEnv = FiniteMap (FilePath,FilePath) FilePath + +-- multiple package.conf's kept in separate namespaces +type PkgEnvs = [PkgEnv] + +type Env = (MVar (), + IORef ModEnv, + IORef PkgEnvs, + IORef MergeEnv) + +-- +-- our environment, contains a set of loaded objects, and a map of known +-- packages and their informations. Initially all we know is the default +-- package.conf information. +-- +env = unsafePerformIO $ do + mvar <- newMVar () + ref1 <- newIORef emptyFM -- loaded objects + p <- grabDefaultPkgConf + ref2 <- newIORef p -- package.conf info + ref3 <- newIORef emptyFM -- merged files + return (mvar, ref1, ref2, ref3) +{-# NOINLINE env #-} + +-- ----------------------------------------------------------- +-- +-- apply 'f' to the loaded objects Env +-- apply 'f' to the package.conf FM +-- *locks up the MVar* so you can't recursively call a function inside a +-- with*Env function. Nice and threadsafe +-- +withModEnv :: Env -> (ModEnv -> IO a) -> IO a +withPkgEnvs :: Env -> (PkgEnvs -> IO a) -> IO a +withMerged :: Env -> (MergeEnv -> IO a) -> IO a + +withModEnv (mvar,ref,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f) +withPkgEnvs (mvar,_,ref,_) f = withMVar mvar (\_ -> readIORef ref >>= f) +withMerged (mvar,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f) + +-- ----------------------------------------------------------- +-- +-- write an object name +-- write a new PackageConfig +-- +modifyModEnv :: Env -> (ModEnv -> IO ModEnv) -> IO () +modifyPkgEnv :: Env -> (PkgEnvs -> IO PkgEnvs) -> IO () +modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO () + +modifyModEnv (mvar,ref,_,_) f = lockAndWrite mvar ref f +modifyPkgEnv (mvar,_,ref,_) f = lockAndWrite mvar ref f +modifyMerged (mvar,_,_,ref) f = lockAndWrite mvar ref f + +-- private +lockAndWrite mvar ref f = withMVar mvar (\_->readIORef ref>>=f>>=writeIORef ref) + +-- ----------------------------------------------------------- +-- +-- insert a loaded module name into the environment +-- +addModule :: String -> IO () +addModule s = modifyModEnv env $ \fm -> return $ addToFM fm s True + +-- +-- remove a module name from the environment +-- +rmModule :: String -> IO () +rmModule s = modifyModEnv env $ \fm -> return $ delFromFM fm s + +-- +-- insert a list of module names all in one go +-- +addModules :: [String] -> IO () +addModules ns = modifyModEnv env $ \fm -> return $ unionL fm ns + where + unionL :: ModEnv -> [String] -> ModEnv + unionL fm ss = foldr (\s fm' -> addToFM fm' s True) fm ss + +-- +-- is a module/package already loaded? +-- +isLoaded :: String -> IO Bool +isLoaded s = withModEnv env $ \fm -> return $ isJust (lookupFM fm s) + +-- +-- confusing! only for filter. +-- +loaded :: String -> IO Bool +loaded m = do t <- isLoaded m ; return (not t) + +-- ----------------------------------------------------------- +-- Package management stuff +-- +-- insert a single package.conf (containing multiple configs) +-- means: create a new FM. insert packages into FM. add FM to end of +-- list of FM stored in the environment. +-- +addPkgConf :: FilePath -> IO () +addPkgConf f = do + ps <- readPackageConf f + modifyPkgEnv env $ \ls -> return $ union ls ps + +-- +-- add a new FM for the package.conf to the list of existing ones +-- +union :: PkgEnvs -> [PackageConfig] -> PkgEnvs +union ls ps' = + let fm = emptyFM -- new FM for this package.conf + in ls ++ [foldr (\p fm' -> addToFM fm' (packageName p) p) fm ps'] + +-- +-- generate a PkgEnv from the system package.conf +-- * the path to the default package.conf was determined by ./configure * +-- This imposes a constraint that you must build your plugins with the +-- same ghc you use to build hs-plugins. This is reasonable, we feel. +-- + +grabDefaultPkgConf :: IO PkgEnvs +grabDefaultPkgConf = do + pkgs <- readPackageConf $ ghcLibraryPath sysPkgConf + return $ union [] pkgs + +-- +-- parse a source file, expanding any $libdir we see. +-- +readPackageConf :: FilePath -> IO [PackageConfig] +readPackageConf f = do + s <- readFile f + let p = parsePkgConf s + return $! map expand_libdir p + + where + expand_libdir :: PackageConfig -> PackageConfig + expand_libdir pk = + let pk' = updImportDirs (\idirs -> map expand idirs) pk + pk'' = updLibraryDirs (\ldirs -> map expand ldirs) pk' + in pk'' + + expand :: FilePath -> FilePath + expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s + expand s = s + + +-- +-- Package path, given a package name, look it up in the environment and +-- return the path to all the libraries needed to load this package. +-- +-- What do we need to load? With the library_dirs as prefix paths: +-- * anything in the hs_libraries fields, $libdir expanded +-- * anything in the extra_libraries fields (i.e. cbits), expanded, +-- which includes system .so files. Ignore these for now +-- * also load any dependencies now, because of that weird mtl +-- library that lang depends upon, but which doesn't show up in the +-- interfaces for some reason. +-- +-- ToDo At present this does not handle extra_libraries correctly. It +-- only find those extra libraries that live in the directory specfied +-- by the library_dirs field of the package.conf entry. But +-- extra_libraries can contain any libraries supported by the system's +-- linker. For this library they must be, of course, be dynamic. The +-- extensions for such libraries are different on various platforms. +-- This would need to be checked for by configure.ac. (Scary - dons) +-- +-- We return all the package paths that possibly exist, and the leave it +-- up to loadObject not to load the same ones twice... +-- +lookupPkg :: PackageName -> IO [FilePath] +lookupPkg p = do + t <- lookupPkg' p + case t of ([],f) -> return f + (ps,f) -> do gss <- mapM lookupPkg ps + return $ nub $ (concat gss) ++ f + +-- +-- return any stuff to load for this package, plus the list of packages +-- this package depends on. which includes stuff we have to then load +-- too. +-- +lookupPkg' :: PackageName -> IO ([PackageName],[FilePath]) +lookupPkg' p = withPkgEnvs env $ \fms -> go fms p + where + go [] _ = return ([],[]) + go (fm:fms) q = case lookupFM fm q of + Nothing -> go fms q -- look in other pkgs + + Just package -> do + let libdirs = libraryDirs package + hslibs = hsLibraries package + extras = extraLibraries package + deppkgs = packageDeps package + libs <- mapM (findHSlib libdirs) (hslibs ++ extras) + + -- don't care if there are 'Nothings', that usually + -- means that they refer to system libraries. Can't do + -- anything about that. + return (deppkgs, filterJust libs ) + + -- a list elimination form for the Maybe type + filterJust :: [Maybe a] -> [a] + filterJust [] = [] + filterJust (Just x:xs) = x:filterJust xs + filterJust (Nothing:xs) = filterJust xs + + -- + -- Check that a path to a library actually reaches a library + -- Problem: sysPkgSuffix is ".o", but extra libraries could be + -- ".so" -- what to do? + -- + findHSlib :: [FilePath] -> String -> IO (Maybe FilePath) + findHSlib [] _ = return Nothing + findHSlib (dir:dirs) lib = do + let l = dir lib ++ sysPkgSuffix + b <- doesFileExist l + if b then return $ Just l -- found it! + else findHSlib dirs lib + +------------------------------------------------------------------------ +-- do we have a Module name for this merge? +-- +isMerged :: FilePath -> FilePath -> IO Bool +isMerged a b = withMerged env $ \fm -> return $ isJust (lookupFM fm (a,b)) + +lookupMerged :: FilePath -> FilePath -> IO (Maybe FilePath) +lookupMerged a b = withMerged env $ \fm -> return $ lookupFM fm (a,b) + +-- +-- insert a new merge pair into env +-- +addMerge :: FilePath -> FilePath -> FilePath -> IO () +addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z + +------------------------------------------------------------------------ +-- break a module cycle +-- private: +-- +() :: FilePath -> FilePath -> FilePath +[] b = b +a b = a ++ "/" ++ b diff --git a/src/plugins/Plugins/Load.hs b/src/plugins/Plugins/Load.hs new file mode 100644 index 0000000..03ffcde --- /dev/null +++ b/src/plugins/Plugins/Load.hs @@ -0,0 +1,632 @@ +{-# OPTIONS -#include "Linker.h" #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Load ( + +-- high level interface + load , load_ + , dynload + , pdynload , pdynload_ + , unload + , reload + , Module(..) + + , LoadStatus(..) + +-- low level interface + , initLinker -- start it up + , loadModule -- load a vanilla .o + , loadFunction -- retrieve a function from an object + , loadPackage -- load a ghc library and its cbits + , unloadPackage -- unload a ghc library and its cbits + , loadPackageWith -- load a pkg using the package.conf provided + , loadShared -- load a .so object file + , resolveObjs -- and resolve symbols + + , loadRawObject -- load a bare .o. no dep chasing, no .hi file reading + + , Symbol + + ) where + +import Plugins.Make ( build ) +import Plugins.Env +import Plugins.Utils +import Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore ) + +import Hi.Parser + +import AltData.Dynamic ( fromDyn, Dynamic ) +import AltData.Typeable ( Typeable ) + +import Data.List ( isSuffixOf, nub, nubBy ) +import Control.Monad ( when, filterM, liftM ) +import System.Directory ( doesFileExist, removeFile ) +import Foreign.C.String ( CString, withCString, peekCString ) + +import GHC.Ptr ( Ptr(..), nullPtr ) +import GHC.Exts ( addrToHValue# ) +import GHC.Prim ( unsafeCoerce# ) + +#if DEBUG +import System.IO ( hFlush, stdout ) +#endif + +-- TODO need a loadPackage p package.conf :: IO () primitive + +-- --------------------------------------------------------------------- + +type Symbol = String +type Type = String +type Errors = [String] +type PackageConf = FilePath + +data Module = Module { path :: !FilePath + , mname :: !String + , kind :: !ObjType + , iface :: Iface -- cache the iface + , key :: Key + } + +data ObjType = Vanilla | Shared deriving Eq + +-- --------------------------------------------------------------------- +-- return status of all *load functions: +-- +data LoadStatus a + = LoadSuccess Module a + | LoadFailure Errors + +-- --------------------------------------------------------------------- +-- | load an object file into the address space, returning the closure +-- associated with the symbol requested, after removing its dynamism. +-- +-- Recursively loads the specified modules, and all the modules they +-- depend on. +-- +load :: FilePath -- ^ object file + -> [FilePath] -- ^ any include paths + -> [PackageConf] -- ^ list of package.conf paths + -> Symbol -- ^ symbol to find + -> IO (LoadStatus a) + +load obj incpaths pkgconfs sym = do + initLinker + + -- load extra package information + mapM_ addPkgConf pkgconfs + hif <- loadDepends obj incpaths + + -- why is this the package name? +#if DEBUG + putStr (' ':(decode $ mi_module hif)) >> hFlush stdout +#endif + + m' <- loadObject obj (Object (mi_module hif)) + let m = m' { iface = hif } + resolveObjs + +#if DEBUG + putStrLn " ... done" >> hFlush stdout +#endif + + v <- loadFunction m sym + return $ case v of + Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] + Just a -> LoadSuccess m a + +-- +-- | Like load, but doesn't want a package.conf arg (they are rarely used) +-- +load_ :: FilePath -> [FilePath] -> Symbol -> IO (LoadStatus a) +load_ o i s = load o i [] s + +-- +-- A work-around for Dynamics. The keys used to compare two TypeReps are +-- somehow not equal for the same type in hs-plugin's loaded objects. +-- Solution: implement our own dynamics... +-- +-- The problem with dynload is that it requires the plugin to export +-- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this +-- is not the case, we core dump. Use pdynload if you don't trust the +-- user to supply you with a Dynamic +-- +dynload :: Typeable a + => FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) + +dynload obj incpaths pkgconfs sym = do + s <- load obj incpaths pkgconfs sym + case s of e@(LoadFailure _) -> return e + LoadSuccess m dyn_v -> return $ + case fromDyn (unsafeCoerce# dyn_v :: Dynamic) of + Just v' -> LoadSuccess m v' + Nothing -> LoadFailure ["Mismatched types in interface"] + +------------------------------------------------------------------------ +-- +-- The super-replacement for dynload +-- +-- Use GHC at runtime so we get staged type inference, providing full +-- power dynamics, *on module interfaces only*. This is quite suitable +-- for plugins, of coures :) +-- +-- TODO where does the .hc file go in the call to build() ? +-- + +pdynload :: FilePath -- ^ object to load + -> [FilePath] -- ^ include paths + -> [PackageConf] -- ^ package confs + -> Type -- ^ API type + -> Symbol -- ^ symbol + -> IO (LoadStatus a) + +pdynload object incpaths pkgconfs ty sym = do +#if DEBUG + putStr "Checking types ... " >> hFlush stdout +#endif + errors <- unify object incpaths [] ty sym +#if DEBUG + putStrLn "done" +#endif + if null errors + then load object incpaths pkgconfs sym + else return $ LoadFailure errors + +-- +-- | Like pdynload, but you can specify extra arguments to the +-- typechecker. +-- +pdynload_ :: FilePath -- ^ object to load + -> [FilePath] -- ^ include paths for loading + -> [PackageConf] -- ^ any extra package.conf files + -> [Arg] -- ^ extra arguments to ghc, when typechecking + -> Type -- ^ expected type + -> Symbol -- ^ symbol to load + -> IO (LoadStatus a) + +pdynload_ object incpaths pkgconfs args ty sym = do +#if DEBUG + putStr "Checking types ... " >> hFlush stdout +#endif + errors <- unify object incpaths args ty sym +#if DEBUG + putStrLn "done" +#endif + if null errors + then load object incpaths pkgconfs sym + else return $ LoadFailure errors + +------------------------------------------------------------------------ +-- run the typechecker over the constraint file +-- +-- .hc into /dev/null, .hi into /dev/null +-- +-- NON_PORTABLE == /dev/null +-- +-- Problem: if the user depends on a non-auto package to build the +-- module, then that package will not be in scope when we try to build +-- the module, when performing `unify'. Normally make() will handle this +-- (as it takes extra ghc args). pdynload ignores these, atm -- but it +-- shouldn't. Consider a pdynload() that accepts extra -package flags? +-- +-- Also, pdynload() should accept extra in-scope modules. +-- Maybe other stuff we want to hack in here. +-- +unify obj incs args ty sym = do + (tmpf,hdl) <- mkTemp + + let nm = mkModid (basename tmpf) + src = mkTest nm (mkModid obj) (fst $ break (=='.') ty) ty sym + is = map (\s -> "-i"++s) incs -- api + i = "-i" ++ dirname obj -- plugin + + hWrite hdl src + e <- build tmpf "/dev/null" (i:is++args++["-fno-code","-ohi/dev/null"]) + removeFile tmpf + return e + +mkTest modnm plugin api ty sym = + "module "++ modnm ++" where" ++ + "\nimport qualified " ++ plugin ++ + "\nimport qualified " ++ api ++ + "{-# LINE 1 \"\" #-}" ++ + "\n_ = "++ plugin ++"."++ sym ++" :: "++ty + +------------------------------------------------------------------------ +{- +-- +-- old version that tried to rip stuff from .hi files +-- +pdynload obj incpaths pkgconfs sym ty = do + (m, v) <- load obj incpaths pkgconfs sym + ty' <- mungeIface sym obj + if ty == ty' + then return $ Just (m, v) + else return Nothing -- mismatched types + + where + -- grab the iface output from GHC. find the line relevant to our + -- symbol. grab the string rep of the type. + mungeIface sym o = do + let hi = replaceSuffix o hiSuf + (out,_) <- exec ghc ["--show-iface", hi] + case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of + Nothing -> return undefined + Just v -> do let v' = drop 3 $ dropWhile (/= ':') v + return v' + +-} + +{- +-- +-- a version of load the also unwraps and types a Dynamic object +-- +dynload2 :: Typeable a => + FilePath -> + FilePath -> + Maybe [PackageConf] -> + Symbol -> + IO (Module, a) + +dynload2 obj incpath pkgconfs sym = do + (m, v) <- load obj incpath pkgconfs sym + case fromDynamic v of + Nothing -> panic $ "load: couldn't type "++(show v) + Just a -> return (m,a) +-} + +------------------------------------------------------------------------ +-- +-- | unload a module (not it's dependencies) +-- we have the dependencies, so cascaded unloading is possible +-- +-- once you unload it, you can't 'load' it again, you have to 'reload' +-- it. Cause we don't unload all the dependencies +-- +unload :: Module -> IO () +unload = unloadObj + +-- +-- | this will be nice for panTHeon, needs thinking about the interface +-- reload a single object file. don't care about depends, assume they +-- are loaded. (should use state to store all this) +-- +-- assumes you've already done a 'load' +-- +-- should factor the code +-- +reload :: Module -> Symbol -> IO (LoadStatus a) +reload m@(Module{path = p, iface = hi}) sym = do + unloadObj m -- unload module (and delete) +#if DEBUG + putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout +#endif + m_ <- loadObject p (Object $ mi_module hi) -- load object at path p + let m' = m_ { iface = hi } + + resolveObjs +#if DEBUG + putStrLn "done" >> hFlush stdout +#endif + v <- loadFunction m' sym + return $ case v of + Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] + Just a -> LoadSuccess m' a + +-- --------------------------------------------------------------------- +-- This is a stripped-down version of André Pang's runtime_loader, +-- which in turn is based on GHC's ghci/ObjLinker.lhs binding +-- +-- Load and unload\/Haskell modules at runtime. This is not really +-- \'dynamic loading\', as such -- that implies that you\'re working +-- with proper shared libraries, whereas this is far more simple and +-- only loads object files. But it achieves the same goal: you can +-- load a Haskell module at runtime, load a function from it, and run +-- the function. I have no idea if this works for types, but that +-- doesn\'t mean that you can\'t try it :). +-- +-- read $fptools/ghc/compiler/ghci/ObjLinker.lhs for how to use this stuff +-- +------------------------------------------------------------------------ + +-- | Call the initLinker function first, before calling any of the other +-- functions in this module - otherwise you\'ll get unresolved symbols. + +-- initLinker :: IO () +-- our initLinker transparently calls the one in GHC + +-- +-- | Load a function from a module (which must be loaded and resolved first). +-- +loadFunction :: Module -- ^ The module the value is in + -> String -- ^ Symbol name of value + -> IO (Maybe a) -- ^ The value you want + +loadFunction (Module { iface = i }) valsym + = do let m = mi_module i + symbol = symbolise m +#if DEBUG + putStrLn $ "Looking for <<"++symbol++">>" +#endif + ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol + if (ptr == nullPtr) + then return Nothing + else case addrToHValue# addr of + (# hval #) -> return ( Just hval ) + where + symbolise m = prefixUnderscore++m++"_"++(encode valsym)++"_closure" + + + +-- +-- | Load a GHC-compiled Haskell vanilla object file. +-- The first arg is the path to the object file +-- +-- We make it idempotent to stop the nasty problem of loading the same +-- .o twice. Also the rts is a very special package that is already +-- loaded, even if we ask it to be loaded. N.B. we should insert it in +-- the list of known packages. +-- +-- NB the environment stores the *full path* to an object. So if you +-- want to know if a module is already loaded, you need to supply the +-- *path* to that object, not the name. +-- +-- NB -- let's try just the module name. +-- +-- loadObject loads normal .o objs, and packages too. .o objs come with +-- a nice canonical Z-encoded modid. packages just have a simple name. +-- Do we want to ensure they won't clash? Probably. +-- + +-- +-- the second argument to loadObject is a string to use as the unique +-- identifier for this object. For normal .o objects, it should be the +-- Z-encoded modid from the .hi file. For archives/packages, we can +-- probably get away with the package name +-- +data Key = Object String | Package String + +loadObject :: FilePath -> Key -> IO Module +loadObject p ky@(Object k) = loadObject' p ky k +loadObject p ky@(Package k) = loadObject' p ky k + +loadObject' :: FilePath -> Key -> String -> IO Module +loadObject' p ky k + | ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p) + + | otherwise + = do alreadyLoaded <- isLoaded k + when (not alreadyLoaded) $ do + r <- withCString p c_loadObj + when (not r) (panic $ "Could not load module `"++p++"'") + addModule k -- needs to Z-encode module name + return (emptyMod p) + + where emptyMod q = Module q (mkModid q) Vanilla emptyIface ky + +-- +-- load a single object. no dependencies. You should know what you're +-- doing. +-- +loadModule :: FilePath -> IO Module +loadModule obj = do + let hifile = replaceSuffix obj hiSuf + exists <- doesFileExist hifile + if (not exists) + then error $ "No .hi file found for "++show obj + else do hiface <- readIface hifile + loadObject obj (Object (mi_module hiface)) + +-- +-- | Load a generic .o file, good for loading C objects. +-- You should know what you're doing.. +-- Returns a fairly meaningless iface value. +-- +loadRawObject :: FilePath -> IO Module +loadRawObject obj = loadObject obj (Object k) + where + k = encode (mkModid obj) -- Z-encoded module name + +-- +-- | Resolve (link) the modules loaded by the 'loadObject' function. +-- +resolveObjs :: IO () +resolveObjs = do + r <- c_resolveObjs + when (not r) $ + panic $ "resolveObjs failed with <<" ++ show r ++ ">>" + + +-- | Unload a module +unloadObj :: Module -> IO () +unloadObj (Module { path = p, kind = k, key = ky }) = case k of + Vanilla -> withCString p $ \c_p -> do + r <- c_unloadObj c_p + when (not r) (panic "unloadObj: failed") + rmModule $ case ky of Object s -> s ; Package pk -> pk + + Shared -> return () -- can't unload .so? + +-- +-- | from ghci/ObjLinker.c +-- +-- Load a .so type object file. +-- +loadShared :: FilePath -> IO Module +loadShared str = do + maybe_errmsg <- withCString str $ \dll -> c_addDLL dll + if maybe_errmsg == nullPtr + then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str))) + else do e <- peekCString maybe_errmsg + panic $ "loadShared: couldn't load `"++str++"\' because "++e + +-- +-- Load a -package that we might need, implicitly loading the cbits too +-- The argument is the name of package (e.g. \"concurrent\") +-- +-- How to find a package is determined by the package.conf info we store +-- in the environment. It is just a matter of looking it up. +-- +-- Not printing names of dependent pkgs +-- +loadPackage :: String -> IO () +loadPackage p = do +#if DEBUG + putStr (' ':p) >> hFlush stdout +#endif + libs <- lookupPkg p + mapM_ (\l -> loadObject l (Package (mkModid l))) libs + +-- +-- Unload a -package, that has already been loaded. Unload the cbits +-- too. The argument is the name of the package. +-- +-- May need to check if it exists. +-- +-- Note that we currently need to unload everything. grumble grumble. +-- +-- We need to add the version number to the package name with 6.4 and +-- over. "yi-0.1" for example. This is a bug really. +-- +unloadPackage :: String -> IO () +unloadPackage pkg = do + let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 + libs <- liftM (filter (isSublistOf pkg')) (lookupPkg pkg) + flip mapM_ libs $ \p -> withCString p $ \c_p -> do + r <- c_unloadObj c_p + when (not r) (panic "unloadObj: failed") + rmModule (mkModid p) -- unrecord this module + +-- +-- load a package using the given package.conf to help +-- TODO should report if it doesn't actually load the package, instead +-- of mapM_ doing nothing like above. +-- +loadPackageWith :: String -> [PackageConf] -> IO () +loadPackageWith p pkgconfs = do +#if DEBUG + putStr "Loading package" >> hFlush stdout +#endif + mapM_ addPkgConf pkgconfs + loadPackage p +#if DEBUG + putStrLn " done" +#endif + + +-- --------------------------------------------------------------------- +-- module dependency loading +-- +-- given an Foo.o vanilla object file, supposed to be a plugin compiled +-- by our library, find the associated .hi file. If this is found, load +-- the dependencies, packages first, then the modules. If it doesn't +-- exist, assume the user knows what they are doing and continue. The +-- linker will crash on them anyway. Second argument is any include +-- paths to search in +-- +-- ToDo problem with absolute and relative paths, and different forms of +-- relative paths. A user may cause a dependency to be loaded, which +-- will search the incpaths, and perhaps find "./Foo.o". The user may +-- then explicitly load "Foo.o". These are the same, and the loader +-- should ignore the second load request. However, isLoaded will say +-- that "Foo.o" is not loaded, as the full string is used as a key to +-- the modenv fm. We need a canonical form for the keys -- is basename +-- good enough? +-- +loadDepends :: FilePath -> [FilePath] -> IO Iface +loadDepends obj incpaths = do + let hifile = replaceSuffix obj hiSuf + exists <- doesFileExist hifile + if (not exists) + then do +#if DEBUG + putStrLn "No .hi file found." >> hFlush stdout +#endif + return emptyIface -- could be considered fatal + + else do hiface <- readIface hifile + let ds = mi_deps hiface + + -- remove ones that we've already loaded + ds' <- filterM loaded (dep_mods ds) + + -- now, try to generate a path to the actual .o file + -- fix up hierachical names + let mods_ = map (\s -> (s, map (\c -> + if c == '.' then '/' else c) $ decode s)) ds' + + -- construct a list of possible dependent modules to load + let mods = concatMap (\p -> + map (\(hi,m) -> (hi,p m++".o")) mods_) incpaths + + -- remove modules that don't exist + mods' <- filterM (\(_,y) -> doesFileExist y) $ + nubBy (\v u -> snd v == snd u) mods + + -- now remove duplicate valid paths to the same object + let mods'' = nubBy (\v u -> fst v == fst u) mods' + + -- and find some packages to load, as well. + let ps = dep_pkgs ds + ps' <- filterM loaded (nub ps) + +#if DEBUG + when (not (null ps')) $ + putStr "Loading package" >> hFlush stdout +#endif + mapM_ loadPackage ps' +#if DEBUG + when (not (null ps')) $ + putStr " ... linking ... " >> hFlush stdout +#endif + resolveObjs +#if DEBUG + when (not (null ps')) $ putStrLn "done" + putStr "Loading object" + mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods'' +#endif + mapM_ (\(hi,m) -> loadObject m (Object hi)) mods'' + return hiface + +-- --------------------------------------------------------------------- +-- C interface +-- +foreign import ccall unsafe "lookupSymbol" + c_lookupSymbol :: CString -> IO (Ptr a) + +foreign import ccall unsafe "loadObj" + c_loadObj :: CString -> IO Bool + +foreign import ccall unsafe "unloadObj" + c_unloadObj :: CString -> IO Bool + +foreign import ccall unsafe "resolveObjs" + c_resolveObjs :: IO Bool + +foreign import ccall unsafe "addDLL" + c_addDLL :: CString -> IO CString + +foreign import ccall unsafe "initLinker" + initLinker :: IO () diff --git a/src/plugins/Plugins/Make.hs b/src/plugins/Plugins/Make.hs new file mode 100644 index 0000000..981e8d5 --- /dev/null +++ b/src/plugins/Plugins/Make.hs @@ -0,0 +1,297 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Make ( + + make, + makeAll, + makeWith, + MakeStatus(..), + MakeCode(..), + + merge, + mergeTo, + mergeToDir, + MergeStatus(..), + MergeCode, + + makeClean, + makeCleaner, + + build, {- internal -} + + ) where + +import Plugins.Utils +import Plugins.Parser +import Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf ) +import Plugins.Env ( lookupMerged, addMerge ) + +import System.IO +import System.Directory ( doesFileExist, removeFile ) + +import Control.Exception ( handleJust ) +import GHC.IOBase ( Exception(IOException) ) + +#if __GLASGOW_HASKELL__ >= 604 +import System.IO.Error ( isDoesNotExistError ) +#endif + +------------------------------------------------------------------------ +-- +-- A better compiler status. +-- +data MakeStatus + = MakeSuccess MakeCode FilePath + | MakeFailure Errors + deriving (Eq,Show) + +data MakeCode = ReComp | NotReq + deriving (Eq,Show) + +------------------------------------------------------------------------ +-- +-- An equivalent status for the preprocessor (merge) +-- +data MergeStatus + = MergeSuccess MergeCode Args FilePath + | MergeFailure Errors + deriving (Eq,Show) + +type MergeCode = MakeCode + +type Args = [Arg] +type Errors = [String] + +-- --------------------------------------------------------------------- +-- | Standard make. Compile a single module, unconditionally. +-- Behaves like ghc -c +-- +make :: FilePath -> [Arg] -> IO MakeStatus +make src args = rawMake src ("-c":args) True + +-- | Recursive make. Compile a module, and its dependencies if we can +-- find them. Takes the top-level file as the first argument. +-- Behaves like ghc --make +-- +makeAll :: FilePath -> [Arg] -> IO MakeStatus +makeAll src args = + rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False + +-- | merge two files; then make them. will leave a .o and .hi file in tmpDir. +-- +makeWith :: FilePath -- ^ a src file + -> FilePath -- ^ a syntax stub file + -> [Arg] -- ^ any required args + -> IO MakeStatus -- ^ path to an object file + +makeWith src stub args = do + status <- merge src stub + case status of + MergeFailure errs -> return $ MakeFailure ("merge failed:\n":errs) + MergeSuccess _ args' tmpf -> do + status' <- rawMake tmpf ("-c": args' ++ args) True + return status' + +-- --------------------------------------------------------------------- +-- rawMake : really do the compilation +-- Conditional on file modification times, compile a .hs file +-- When using 'make', the name of the src file must be the name of the +-- .o file you are expecting back +-- +-- Problem: we use GHC producing stdout to indicate compilation failure. +-- We should instead check the error conditions. I.e. --make will +-- produce output, but of course compiles correctly. TODO +-- So, e.g. --make requires -v0 to stop spurious output confusing +-- rawMake +-- +-- Problem :: makeAll incorrectly refuses to recompile if the top level +-- src isn't new. +-- + +rawMake :: FilePath -- ^ src + -> [Arg] -- ^ any compiler args + -> Bool -- ^ do our own recompilation checking + -> IO MakeStatus + +rawMake src args docheck = do + src_exists <- doesFileExist src + if not src_exists + then return $ MakeFailure ["Source file does not exist: "++src] + else do { + ; let (obj,_) = outFilePath src args + ; src_changed <- if docheck then src `newer` obj else return True + ; if not src_changed + then return $ MakeSuccess NotReq obj + else do +#if DEBUG + putStr "Compiling object ... " >> hFlush stdout +#endif + err <- build src obj args +#if DEBUG + putStrLn "done" +#endif + return $ if null err + then MakeSuccess ReComp obj + else MakeFailure err + } + +-- +-- compile a .hs file to a .o file +-- +-- If the plugin needs to import an api (which should be almost +-- everyone) then the ghc flags to find the api need to be provided as +-- arguments +-- +build :: FilePath -- path to .hs source + -> FilePath -- path to object file + -> [String] -- any extra cmd line flags + -> IO [String] + +build src obj extra_opts = do + + let odir = dirname obj -- *always* put the .hi file next to the .o file + + let ghc_opts = [ "-Onot" ] + output = [ "-o", obj, "-odir", odir, + "-hidir", odir, "-i" ++ odir ] + + let flags = ghc_opts ++ output ++ extra_opts ++ [src] + +#if DEBUG + -- env. + putStr $ show $ ghc : flags +#endif + (_,err) <- exec ghc flags -- this is a fork() + + obj_exists <- doesFileExist obj -- sanity + return $ if not obj_exists && null err -- no errors, but no object? + then ["Compiled, but didn't create object file `"++obj++"'!"] + else err + +-- --------------------------------------------------------------------- +-- | Merge to source files into a temporary file. If we've tried to +-- merge these two stub files before, then reuse the module name (helps +-- recompilation checking) +-- +merge :: FilePath -> FilePath -> IO MergeStatus +merge src stb = do + m_mod <- lookupMerged src stb + (out,domerge) <- case m_mod of + Nothing -> do out <- mkUnique + addMerge src stb (dropSuffix out) + return (out, True) -- definitely out of date + Just nm -> return $ (nm <> hsSuf, False) + rawMerge src stb out domerge + +-- | Merge to source files and store them in the specified output file, +-- instead of a temp file as merge does. +-- +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus +mergeTo src stb out = rawMerge src stb out False + +mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus +mergeToDir src stb dir = do + out <- mkUniqueIn dir + rawMerge src stb out True + +-- --------------------------------------------------------------------- +-- Conditional on file modification times, merge a src file with a +-- syntax stub file into a result file. +-- +-- Merge should only occur if the srcs has changed since last time. +-- Parser errors result in MergeFailure, and are reported to the client +-- +-- Also returns a list of cmdline flags found in pragmas in the src of +-- the files. This last feature exists as OPTION pragmas aren't handled +-- (for obvious reasons, relating to the implementation of OPTIONS +-- parsing in GHC) by the library parser, and, also, we want a way for +-- the user to introduce *dynamic* cmd line flags in the .conf file. +-- This is achieved via the GLOBALOPTIONS pragma : an extension to ghc +-- pragma syntax +-- +rawMerge :: FilePath -> FilePath -> FilePath -> Bool -> IO MergeStatus +rawMerge src stb out always_merge = do + src_exists <- doesFileExist src + stb_exists <- doesFileExist stb + case () of {_ + | not src_exists -> return $ + MergeFailure ["Source file does not exist : "++src] + | not stb_exists -> return $ + MergeFailure ["Source file does not exist : "++stb] + | otherwise -> do { + + ;do_merge <- do src_changed <- src `newer` out + stb_changed <- stb `newer` out + return $ src_changed || stb_changed + + ;if not do_merge && not always_merge + then return $ MergeSuccess NotReq [] out + else do + src_str <- readFile src + stb_str <- readFile stb + + let (a,a') = parsePragmas src_str + (b,b') = parsePragmas stb_str + opts = a ++ a' ++ b ++ b' + + let e_src_syn = parse src src_str + e_stb_syn = parse stb stb_str + + -- check if there were parser errors + case (e_src_syn,e_stb_syn) of + (Left e, _) -> return $ MergeFailure [e] + (_ , Left e) -> return $ MergeFailure [e] + (Right src_syn, Right stb_syn) -> do { + + ;let mrg_syn = mergeModules src_syn stb_syn + mrg_syn'= replaceModName mrg_syn (mkModid $ basename out) + mrg_str = pretty mrg_syn' + + ;hdl <- openFile out WriteMode -- overwrite! + ;hPutStr hdl mrg_str ; hClose hdl + ;return $ MergeSuccess ReComp opts out -- must have recreated file + }}} + +-- --------------------------------------------------------------------- +-- | makeClean : assuming we some element of [f.hs,f.hi,f.o], remove the +-- .hi and .o components. Silently ignore any missing components. *Does +-- not remove .hs files*. To do that use makeCleaner. This would be +-- useful for merged files, for example. +-- +makeClean :: FilePath -> IO () +makeClean f = let f_hi = dropSuffix f <> hiSuf + f_o = dropSuffix f <> objSuf + in mapM_ rm_f [f_hi, f_o] + +makeCleaner :: FilePath -> IO () +makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf) + +-- internal: +-- try to remove a file, ignoring if it didn't exist in the first place +-- Doesn't seem to be able to remove all files in all circumstances, why? +-- +rm_f f = handleJust doesntExist (\_->return ()) (removeFile f) + where + doesntExist (IOException ioe) + | isDoesNotExistError ioe = Just () + | otherwise = Nothing + doesntExist _ = Nothing + diff --git a/src/plugins/Plugins/MkTemp.hs b/src/plugins/Plugins/MkTemp.hs new file mode 100644 index 0000000..a994774 --- /dev/null +++ b/src/plugins/Plugins/MkTemp.hs @@ -0,0 +1,281 @@ +{-# OPTIONS -cpp -fffi -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- A Haskell reimplementation of the C mktemp/mkstemp/mkstemps library +-- based on the algorithms in: +-- "$ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $" +-- which are available under the BSD license. +-- + +module Plugins.MkTemp ( + + mktemp, -- :: FilePath -> FilePath + mkstemp, -- :: FilePath -> (FilePath, Handle) + mkstemps, -- :: FilePath -> Int -> (FilePath,Handle) + mkdtemp, -- :: FilePath -> FilePath + + ) where + +import Data.List +import Data.Char + +import Control.Monad ( liftM ) +import Control.Exception ( handleJust ) + +#if __GLASGOW_HASKELL__ < 604 +import System.IO ( isAlreadyExistsError, Handle ) +#else +import System.IO ( Handle ) +import System.IO.Error ( isAlreadyExistsError ) +#endif + +import System.Directory ( doesDirectoryExist, doesFileExist ) + +import GHC.IOBase ( Exception(IOException) ) + +-- Fix this. +#ifndef __MINGW32__ +import System.Posix.IO +import System.Posix.Files +import qualified System.Posix.Directory ( createDirectory ) +import qualified System.Posix.Internals ( c_getpid ) +#endif + +#ifndef HAVE_ARC4RANDOM +import System.Random ( getStdRandom, Random(randomR) ) +#else +import GHC.Base +import GHC.Int +#endif + +-- --------------------------------------------------------------------- + +mkstemps :: FilePath -> Int -> IO (Maybe (FilePath,Handle)) +mkstemp :: FilePath -> IO (Maybe (FilePath,Handle)) +mktemp :: FilePath -> IO (Maybe FilePath) +mkdtemp :: FilePath -> IO (Maybe FilePath) + +mkstemps path slen = gettemp path True False slen + +mkstemp path = gettemp path True False 0 + +mktemp path = do v <- gettemp path False False 0 + return $ case v of Just (path',_) -> Just path'; _ -> Nothing + +mkdtemp path = do v <- gettemp path False True 0 + return $ case v of Just (path',_) -> Just path'; _ -> Nothing + +-- --------------------------------------------------------------------- + +gettemp :: FilePath -> Bool -> Bool -> Int -> IO (Maybe (FilePath, Handle)) + +gettemp [] _ _ _ = return Nothing +gettemp _ True True _ = return Nothing + +gettemp path doopen domkdir slen = do + -- + -- firstly, break up the path and extract the template + -- + let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path + (p,t) = break (== 'X') r + in (p,t,s) + -- + -- an error if there is only a suffix, it seems + -- + if null pref && null tmpl then return Nothing else do { + -- + -- replace end of template with process id, and rest with randomness + -- + ;pid <- liftM show $ getProcessID + ;let (rest, xs) = merge tmpl pid + ;as <- randomise rest + ;let tmpl' = as ++ xs + path' = pref ++ tmpl' ++ suff + -- + -- just check if we can get at the directory we might need + -- + ;dir_ok <- if doopen || domkdir + then let d = reverse $ dropWhile (/= '/') $ reverse path' + in doesDirectoryExist d + else return True + + ;if not dir_ok then return Nothing else do { + -- + -- We need a function for looking for appropriate temp files + -- + ;let fn p + | doopen = handleJust isInUse (\_ -> return Nothing) $ + do h <- open0600 p ; return $ Just h + | domkdir = handleJust alreadyExists (\_ -> return Nothing) $ + do mkdir0700 p ; return $ Just undefined + | otherwise = do b <- doesFileExist p + return $ if b then Nothing else Just undefined + + -- + -- now, try to create the tmp file, permute if we can't + -- once we've tried all permutations, give up + -- + ;let tryIt p t i = + do v <- fn p + case v of Just h -> return $ Just (p,h) -- it worked + Nothing -> let (i',t') = tweak i t + in if null t' + then return Nothing -- no more + else tryIt (pref++t'++suff) t' i' + ;tryIt path' tmpl' 0 + + }} + +-- +-- Replace X's with pid digits. Complete rewrite +-- +merge :: String -> String -> (String,String) +merge t [] = (t ,[]) +merge [] _ = ([] ,[]) +merge (_:ts) (p:ps) = (ts',p:ps') + where (ts',ps') = merge ts ps + +-- +-- And replace remaining X's with random chars +-- randomR is pretty slow, oh well. +-- +randomise :: String -> IO String +randomise [] = return [] +randomise ('X':xs) = do p <- getRandom () + let c = chr $! if p < 26 + then p + (ord 'A') + else (p - 26) + (ord 'a') + xs' <- randomise xs + return (c : xs') +randomise s = return s + +-- +-- "tricky little algorithm for backward compatibility" +-- could do with a Haskellish rewrite +-- +tweak :: Int -> String -> (Int,String) +tweak i s + | i > length s - 1 = (i,[]) -- no more + | s !! i == 'Z' = if i == length s - 1 + then (i,[]) -- no more + else let s' = splice (i+1) 'a' + in tweak (i+1) s' -- loop + | otherwise = let c = s !! i in case () of {_ + | isDigit c -> (i, splice i 'a' ) + | c == 'z' -> (i, splice i 'A' ) + | otherwise -> let c' = chr $ (ord c) + 1 in (i,splice i c') + } + where + splice j c = let (a,b) = splitAt j s in a ++ [c] ++ tail b + +-- --------------------------------------------------------------------- + +alreadyExists e@(IOException ioe) + | isAlreadyExistsError ioe = Just e + | otherwise = Nothing +alreadyExists _ = Nothing + +#ifndef __MINGW32__ +isInUse (IOException ioe) + | isAlreadyExistsError ioe = Just () + | otherwise = Nothing +isInUse _ = Nothing +#else +isInUse (IOException ioe) + | isAlreadyInUseError ioe = Just () + | isPermissionError ioe = Just () + | isAlreadyExistsError ioe = Just () -- we throw this + | otherwise = Nothing +isInUse _ = Nothing +#endif + +-- --------------------------------------------------------------------- +-- Create a file mode 0600 if possible +-- +open0600 :: FilePath -> IO Handle + +#ifndef __MINGW32__ + +-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600) + +open0600 f = do + openFd f ReadWrite (Just o600) excl >>= fdToHandle + where + o600 = ownerReadMode `unionFileModes` ownerWriteMode + excl = defaultFileFlags { exclusive = True } +#else + +-- N.B. race condition between testing existence and opening + +open0600 f = do + b <- doesFileExist f + if b then ioException err -- race + else openFile f ReadWriteMode + where + err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing +#endif + +-- +-- create a directory mode 0700 if possible +-- +mkdir0700 :: FilePath -> IO () +mkdir0700 dir = +#ifndef __MINGW32__ + System.Posix.Directory.createDirectory dir ownerModes +#else + createDirectory dir +#endif + +-- --------------------------------------------------------------------- +-- | getProcessId, stolen from GHC + +#ifdef __MINGW32__ +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#elif __GLASGOW_HASKELL__ > 504 +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#else +getProcessID :: IO Int +getProcessID = Posix.getProcessID +#endif + +-- --------------------------------------------------------------------- +-- | Use a variety of random functions, if you like. +-- +getRandom :: () -> IO Int + +#ifndef HAVE_ARC4RANDOM +getRandom _ = getStdRandom (randomR (0,51)) +#else +-- +-- +-- OpenBSD: "The arc4random() function provides a high quality 32-bit +-- pseudo-random number very quickly. arc4random() seeds itself on a +-- regular basis from the kernel strong random number subsystem +-- described in random(4)." Also, it is a bit faster than getStdRandom +-- +getRandom _ = do + (I32# i) <- c_arc4random + return (I# (word2Int# + ((int2Word# i `and#` int2Word# 0xffff#) `remWord#` int2Word# 52#))) + +foreign import ccall unsafe "arc4random" c_arc4random :: IO Int32 +#endif diff --git a/src/plugins/Plugins/Package.hs b/src/plugins/Plugins/Package.hs new file mode 100644 index 0000000..93647ac --- /dev/null +++ b/src/plugins/Plugins/Package.hs @@ -0,0 +1,67 @@ +-- +-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- +-- Read information from a package.conf +-- + +module Plugins.Package {-everything-} where + +type PackageName = String + +-- +-- Take directly from ghc/utils/ghc-pkg/Package.hs +-- + +data PackageConfig = Package { + name :: PackageName, + auto :: Bool, + import_dirs :: [FilePath], + source_dirs :: [FilePath], + library_dirs :: [FilePath], + hs_libraries :: [String], + extra_libraries :: [String], + include_dirs :: [FilePath], + c_includes :: [String], + package_deps :: [String], + extra_ghc_opts :: [String], + extra_cc_opts :: [String], + extra_ld_opts :: [String], + framework_dirs :: [FilePath], -- ignored everywhere but on Darwin/MacOS X + extra_frameworks:: [String] -- ignored everywhere but on Darwin/MacOS X + } deriving Show + + +defaultPackageConfig = Package { + name = error "defaultPackage", + auto = False, + import_dirs = [], + source_dirs = [], + library_dirs = [], + hs_libraries = [], + extra_libraries = [], + include_dirs = [], + c_includes = [], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [], + framework_dirs = [], + extra_frameworks= [] + } + diff --git a/src/plugins/Plugins/PackageAPI.hs b/src/plugins/Plugins/PackageAPI.hs new file mode 100644 index 0000000..aa821c7 --- /dev/null +++ b/src/plugins/Plugins/PackageAPI.hs @@ -0,0 +1,92 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- +-- We export an abstract interface to package conf`s because we have +-- to handle either traditional or Cabal style package conf`s. +-- + +module Plugins.PackageAPI ( + PackageName + , PackageConfig + , packageName + , packageName_ + , importDirs + , hsLibraries + , libraryDirs + , extraLibraries + , packageDeps + , updImportDirs + , updLibraryDirs + ) where + +#include "../../../config.h" + +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import Distribution.InstalledPackageInfo +import Distribution.Package +#else +import Plugins.Package +#endif + +packageName :: PackageConfig -> PackageName +packageDeps :: PackageConfig -> [PackageName] +updImportDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig +updLibraryDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig + +-- We use different package.conf parsers when running on 6.2.x or 6.4 +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 + +type PackageName = String + +type PackageConfig = InstalledPackageInfo + +packageName = showPackageId . package +packageName_ = pkgName . package +packageDeps = (map showPackageId) . depends + +updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) = + pk { importDirs = f idirs } +updLibraryDirs f pk@(InstalledPackageInfo { libraryDirs = ldirs }) = + pk { libraryDirs = f ldirs } +#else + +packageName = name +packageName_ = name +packageDeps = package_deps + +updImportDirs f pk@(Package {import_dirs = idirs}) + = pk {import_dirs = f idirs} + +updLibraryDirs f pk@(Package {library_dirs = ldirs}) + = pk {library_dirs = f ldirs} + +importDirs :: PackageConfig -> [FilePath] +importDirs = import_dirs + +hsLibraries :: PackageConfig -> [String] +hsLibraries = hs_libraries + +libraryDirs :: PackageConfig -> [FilePath] +libraryDirs = library_dirs + +extraLibraries :: PackageConfig -> [String] +extraLibraries = extra_libraries + +#endif diff --git a/src/plugins/Plugins/ParsePkgConfCabal.hs b/src/plugins/Plugins/ParsePkgConfCabal.hs new file mode 100644 index 0000000..f9a7329 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfCabal.hs @@ -0,0 +1,776 @@ +{-# OPTIONS -fglasgow-exts -cpp -w #-} +-- parser produced by Happy Version 1.14 + + + +module Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import List ( break ) +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn5 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (PackageConfig) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (PackageConfig) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (PackageIdentifier) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (PackageIdentifier) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Version) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Version) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ([PackageIdentifier]) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ([PackageIdentifier]) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([PackageIdentifier]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([PackageIdentifier]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([Int]) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([Int]) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: ([Int]) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> ([Int]) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([String]) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> ([String]) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([String]) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([String]) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x50\x00\x4a\x00\x4c\x00\x49\x00\x46\x00\x4b\x00\x45\x00\x0a\x00\x1e\x00\x00\x00\x00\x00\x44\x00\x16\x00\x00\x00\x43\x00\x00\x00\x42\x00\x00\x00\x03\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x01\x00\x00\x00\x40\x00\x00\x00\x3e\x00\x3d\x00\x1c\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3a\x00\x39\x00\x35\x00\x00\x00\x00\x00\x38\x00\x31\x00\x34\x00\x33\x00\x37\x00\x36\x00\x28\x00\x00\x00\x30\x00\x32\x00\x2f\x00\x09\x00\x2d\x00\x00\x00\x2e\x00\x26\x00\x2c\x00\x22\x00\x00\x00\x00\x00\x2b\x00\x29\x00\x0d\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x2a\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\xfe\xff\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x04\x00\x00\x00\xfb\xff\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\x00\x00\xfa\xff\x00\x00\xf9\xff\x00\x00\xf7\xff\xf6\xff\xf1\xff\xf2\xff\x00\x00\xf4\xff\xf5\xff\x00\x00\xf3\xff\xed\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xe5\xff\xe6\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xec\xff\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xea\xff\xe8\xff\x00\x00\x00\x00\x00\x00\xef\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x05\x00\x01\x00\x05\x00\x08\x00\x07\x00\x03\x00\x0c\x00\x0c\x00\x0b\x00\x09\x00\x08\x00\x09\x00\x04\x00\x04\x00\x0b\x00\x04\x00\x04\x00\x08\x00\x0a\x00\x08\x00\x09\x00\x09\x00\x05\x00\x02\x00\x0a\x00\x08\x00\x05\x00\x03\x00\x04\x00\x01\x00\x02\x00\x04\x00\x05\x00\x04\x00\x05\x00\x0a\x00\x04\x00\x06\x00\x02\x00\x09\x00\x02\x00\x00\x00\x02\x00\x0a\x00\x07\x00\x03\x00\x07\x00\xff\xff\x04\x00\x06\x00\x05\x00\x05\x00\x03\x00\x06\x00\x01\x00\x07\x00\x02\x00\x06\x00\x08\x00\xff\xff\x05\x00\x09\x00\x06\x00\x01\x00\x04\x00\x08\x00\x05\x00\x09\x00\xff\xff\xff\xff\x07\x00\x07\x00\x06\x00\x08\x00\x07\x00\x01\x00\x04\x00\xff\xff\x03\x00\x0b\x00\x0b\x00\x08\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x1e\x00\x1d\x00\x16\x00\x1f\x00\x17\x00\x1a\x00\x20\x00\x20\x00\x18\x00\x1e\x00\x1b\x00\x1c\x00\x3a\x00\x0b\x00\x41\x00\x22\x00\x22\x00\x06\x00\x3b\x00\x23\x00\x24\x00\x24\x00\x1e\x00\x14\x00\x3f\x00\x2a\x00\x15\x00\x0c\x00\x0d\x00\x08\x00\x09\x00\x25\x00\x26\x00\x10\x00\x11\x00\x38\x00\x15\x00\x30\x00\x11\x00\x36\x00\x04\x00\x06\x00\x44\x00\x3b\x00\x3d\x00\x43\x00\x35\x00\x00\x00\x3f\x00\x41\x00\x3e\x00\x3c\x00\x38\x00\x36\x00\x33\x00\x2f\x00\x34\x00\x30\x00\x32\x00\x00\x00\x2e\x00\x2d\x00\x2a\x00\x1d\x00\x27\x00\x23\x00\x28\x00\x2c\x00\x00\x00\x00\x00\x29\x00\x0f\x00\x13\x00\x06\x00\x0f\x00\x0c\x00\x0b\x00\x00\x00\x04\x00\xff\xff\xff\xff\x06\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 27) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27) + ] + +happy_n_terms = 12 :: Int +happy_n_nonterms = 13 :: Int + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_3 0# happyReduction_3 +happyReduction_3 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (reverse happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + ([ happy_var_1 ] + )} + +happyReduce_5 = happySpecReduce_3 1# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn7 + (happy_var_3 defaultPackageConfig + ) `HappyStk` happyRest} + +happyReduce_7 = happySpecReduce_1 3# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (\p -> happy_var_1 p + )} + +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_3 of { happy_var_3 -> + happyIn8 + (\p -> happy_var_1 (happy_var_3 p) + )}} + +happyReduce_9 = happySpecReduce_3 4# happyReduction_9 +happyReduction_9 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "package" -> p {package = happy_var_3} + _ -> error "unknown key in config file" + )}} + +happyReduce_10 = happySpecReduce_3 4# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn9 + (id + ) + +happyReduce_11 = happySpecReduce_3 4# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOutTok happy_x_3 of { (ITconid happy_var_3) -> + happyIn9 + (case happy_var_1 of { + "exposed" -> + case happy_var_3 of { + "True" -> (\p -> p {exposed=True}); + "False" -> (\p -> p {exposed=False}); + _ -> error "exposed must be either True or False" }; + "license" -> id; -- not interested + _ -> error "unknown constructor" } + )}} + +happyReduce_12 = happyReduce 4# 4# happyReduction_12 +happyReduction_12 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn9 + (id + ) `HappyStk` happyRest + +happyReduce_13 = happySpecReduce_3 4# happyReduction_13 +happyReduction_13 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "exposedModules" -> p{exposedModules = happy_var_3} + "hiddenModules" -> p{hiddenModules = happy_var_3} + "importDirs" -> p{importDirs = happy_var_3} + "libraryDirs" -> p{libraryDirs = happy_var_3} + "hsLibraries" -> p{hsLibraries = happy_var_3} + "extraLibraries" -> p{extraLibraries = happy_var_3} + "includeDirs" -> p{includeDirs = happy_var_3} + "includes" -> p{includes = happy_var_3} + "hugsOptions" -> p{hugsOptions = happy_var_3} + "ccOptions" -> p{ccOptions = happy_var_3} + "ldOptions" -> p{ldOptions = happy_var_3} + "frameworkDirs" -> p{frameworkDirs = happy_var_3} + "frameworks" -> p{frameworks = happy_var_3} + "haddockInterfaces" -> p{haddockInterfaces = happy_var_3} + "haddockHTMLs" -> p{haddockHTMLs = happy_var_3} + "depends" -> p{depends = []} + -- empty list only, non-empty handled below + other -> p + )}} + +happyReduce_14 = happySpecReduce_3 4# happyReduction_14 +happyReduction_14 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn9 + (case happy_var_1 of + "depends" -> (\p -> p{depends = happy_var_3}) + _other -> error "unknown key in config file" + )}} + +happyReduce_15 = happyReduce 10# 5# happyReduction_15 +happyReduction_15 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_5 of { (ITstring happy_var_5) -> + case happyOut11 happy_x_9 of { happy_var_9 -> + happyIn10 + (PackageIdentifier{ pkgName = happy_var_5, + pkgVersion = happy_var_9 } + ) `HappyStk` happyRest}} + +happyReduce_16 = happyReduce 10# 6# happyReduction_16 +happyReduction_16 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut14 happy_x_5 of { happy_var_5 -> + case happyOut16 happy_x_9 of { happy_var_9 -> + happyIn11 + (Version{ versionBranch=happy_var_5, versionTags=happy_var_9 } + ) `HappyStk` happyRest}} + +happyReduce_17 = happySpecReduce_3 7# happyReduction_17 +happyReduction_17 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn12 + (happy_var_2 + )} + +happyReduce_18 = happySpecReduce_1 8# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn13 + ([ happy_var_1 ] + )} + +happyReduce_19 = happySpecReduce_3 8# happyReduction_19 +happyReduction_19 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn13 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_20 = happySpecReduce_2 9# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = happyIn14 + ([] + ) + +happyReduce_21 = happySpecReduce_3 9# happyReduction_21 +happyReduction_21 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn14 + (happy_var_2 + )} + +happyReduce_22 = happySpecReduce_1 10# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOutTok happy_x_1 of { (ITinteger happy_var_1) -> + happyIn15 + ([ fromIntegral happy_var_1 ] + )} + +happyReduce_23 = happySpecReduce_3 10# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITinteger happy_var_1) -> + case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn15 + (fromIntegral happy_var_1 : happy_var_3 + )}} + +happyReduce_24 = happySpecReduce_2 11# happyReduction_24 +happyReduction_24 happy_x_2 + happy_x_1 + = happyIn16 + ([] + ) + +happyReduce_25 = happySpecReduce_3 11# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (reverse happy_var_2 + )} + +happyReduce_26 = happySpecReduce_1 12# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (ITstring happy_var_1) -> + happyIn17 + ([ happy_var_1 ] + )} + +happyReduce_27 = happySpecReduce_3 12# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn17 + (happy_var_3 : happy_var_1 + )}} + +happyNewToken action sts stk [] = + happyDoAction 11# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + ITocurly -> cont 1#; + ITccurly -> cont 2#; + ITobrack -> cont 3#; + ITcbrack -> cont 4#; + ITcomma -> cont 5#; + ITequal -> cont 6#; + ITvarid happy_dollar_dollar -> cont 7#; + ITconid happy_dollar_dollar -> cont 8#; + ITstring happy_dollar_dollar -> cont 9#; + ITinteger happy_dollar_dollar -> cont 10#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x)) + +happySeq = happyDontSeq + +type PackageConfig = InstalledPackageInfo + +defaultPackageConfig = emptyInstalledPackageInfo + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + | ITinteger Int + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) + | isDigit c = lexInt (c:cs) +lexer _ = error ( "Unexpected token") + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexInt cs = let (intStr, rest) = span isDigit cs + in ITinteger (read intStr) : lexer rest + + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParsePkgConfCabal.hs,v 1.1 2005/04/22 08:58:28 dons Exp $ + + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + + +{-# LINE 59 "GenericTemplate.hs" #-} + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j (happyTcHack st)) + + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 166 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/plugins/Plugins/ParsePkgConfCabal.y b/src/plugins/Plugins/ParsePkgConfCabal.y new file mode 100644 index 0000000..2c11a77 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfCabal.y @@ -0,0 +1,218 @@ +-- +-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Taken (apart from the most minor of alterations) from +-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs from GHC 6.2.2 source tree +-- and then modified to mimic the behaviour of the parser within +-- ghc/compiler/main/ParsePkgConf.y in GHC 6.4, without importing +-- heavy-weight infrastructure from the GHC source tree such as module +-- FastString, Lexer, etc. +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. +-- + +{ +{-# OPTIONS -w #-} + +module Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import List ( break ) + +} + +%token + '{' { ITocurly } + '}' { ITccurly } + '[' { ITobrack } + ']' { ITcbrack } + ',' { ITcomma } + '=' { ITequal } + VARID { ITvarid $$ } + CONID { ITconid $$ } + STRING { ITstring $$ } + INT { ITinteger $$ } + +%name parse pkgconf +%name parseOne pkg +%tokentype { Token } +%% + +pkgconf :: { [ PackageConfig ] } + : '[' ']' { [] } + | '[' pkgs ']' { reverse $2 } + +pkgs :: { [ PackageConfig ] } + : pkg { [ $1 ] } + | pkgs ',' pkg { $3 : $1 } + +pkg :: { PackageConfig } + : CONID '{' fields '}' { $3 defaultPackageConfig } + +fields :: { PackageConfig -> PackageConfig } + : field { \p -> $1 p } + | fields ',' field { \p -> $1 ($3 p) } + +field :: { PackageConfig -> PackageConfig } + : VARID '=' pkgid + {\p -> case $1 of + "package" -> p {package = $3} + _ -> error "unknown key in config file" } + + | VARID '=' STRING { id } + -- we aren't interested in the string fields, they're all + -- boring (copyright, maintainer etc.) + + | VARID '=' CONID + { case $1 of { + "exposed" -> + case $3 of { + "True" -> (\p -> p {exposed=True}); + "False" -> (\p -> p {exposed=False}); + _ -> error "exposed must be either True or False" }; + "license" -> id; -- not interested + _ -> error "unknown constructor" } + } + + | VARID '=' CONID STRING { id } + -- another case of license + + | VARID '=' strlist + {\p -> case $1 of + "exposedModules" -> p{exposedModules = $3} + "hiddenModules" -> p{hiddenModules = $3} + "importDirs" -> p{importDirs = $3} + "libraryDirs" -> p{libraryDirs = $3} + "hsLibraries" -> p{hsLibraries = $3} + "extraLibraries" -> p{extraLibraries = $3} + "includeDirs" -> p{includeDirs = $3} + "includes" -> p{includes = $3} + "hugsOptions" -> p{hugsOptions = $3} + "ccOptions" -> p{ccOptions = $3} + "ldOptions" -> p{ldOptions = $3} + "frameworkDirs" -> p{frameworkDirs = $3} + "frameworks" -> p{frameworks = $3} + "haddockInterfaces" -> p{haddockInterfaces = $3} + "haddockHTMLs" -> p{haddockHTMLs = $3} + "depends" -> p{depends = []} + -- empty list only, non-empty handled below + other -> p + } + | VARID '=' pkgidlist + { case $1 of + "depends" -> (\p -> p{depends = $3}) + _other -> error "unknown key in config file" + } + + +pkgid :: { PackageIdentifier } + : CONID '{' VARID '=' STRING ',' VARID '=' version '}' + { PackageIdentifier{ pkgName = $5, + pkgVersion = $9 } } + +version :: { Version } + : CONID '{' VARID '=' intlist ',' VARID '=' strlist '}' + { Version{ versionBranch=$5, versionTags=$9 } } + +pkgidlist :: { [PackageIdentifier] } + : '[' pkgids ']' { $2 } + -- empty list case is covered by strlist, to avoid conflicts + +pkgids :: { [PackageIdentifier] } + : pkgid { [ $1 ] } + | pkgid ',' pkgids { $1 : $3 } + +intlist :: { [Int] } + : '[' ']' { [] } + | '[' ints ']' { $2 } + +ints :: { [Int] } + : INT { [ fromIntegral $1 ] } + | INT ',' ints { fromIntegral $1 : $3 } + +strlist :: { [String] } + : '[' ']' { [] } + | '[' strs ']' { reverse $2 } + +strs :: { [String] } + : STRING { [ $1 ] } + | strs ',' STRING { $3 : $1 } + +{ + +type PackageConfig = InstalledPackageInfo + +defaultPackageConfig = emptyInstalledPackageInfo + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + | ITinteger Int + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) + | isDigit c = lexInt (c:cs) +lexer _ = error ( "Unexpected token") + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexInt cs = let (intStr, rest) = span isDigit cs + in ITinteger (read intStr) : lexer rest + + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer + +} diff --git a/src/plugins/Plugins/ParsePkgConfLite.hs b/src/plugins/Plugins/ParsePkgConfLite.hs new file mode 100644 index 0000000..6f75df7 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfLite.hs @@ -0,0 +1,624 @@ +{-# OPTIONS -fglasgow-exts -cpp -w #-} +-- parser produced by Happy Version 1.14 + + + +module Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import Plugins.Package ( PackageConfig(..), defaultPackageConfig ) + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper ) +import List ( break ) +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn5 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (PackageConfig) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (PackageConfig) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([String]) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([String]) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: ([String]) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> ([String]) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Bool) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Bool) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x1f\x00\x1e\x00\x1d\x00\x1b\x00\x1a\x00\x1c\x00\x19\x00\x01\x00\x0e\x00\x00\x00\x00\x00\x17\x00\x08\x00\x00\x00\x16\x00\x00\x00\x13\x00\x00\x00\xfe\xff\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x18\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xfd\xff\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\x00\x00\xfa\xff\x00\x00\xf9\xff\x00\x00\xf7\xff\xf4\xff\xf5\xff\x00\x00\xef\xff\xf6\xff\x00\x00\xf3\xff\xf1\xff\xf2\xff\x00\x00\xf0\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x05\x00\x04\x00\x07\x00\x04\x00\x08\x00\x09\x00\x09\x00\x08\x00\x02\x00\x01\x00\x02\x00\x05\x00\x03\x00\x04\x00\x04\x00\x05\x00\x04\x00\x05\x00\x04\x00\x06\x00\x02\x00\x02\x00\x00\x00\x07\x00\x09\x00\x08\x00\x06\x00\x01\x00\x07\x00\x04\x00\x03\x00\xff\xff\x03\x00\x0a\x00\x0a\x00\xff\xff\x08\x00\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x19\x00\x16\x00\x1d\x00\x17\x00\x0b\x00\x1a\x00\x1b\x00\x1e\x00\x06\x00\x14\x00\x08\x00\x09\x00\x15\x00\x0c\x00\x0d\x00\x1f\x00\x20\x00\x10\x00\x11\x00\x15\x00\x1b\x00\x11\x00\x04\x00\x06\x00\x0f\x00\x21\x00\x06\x00\x13\x00\x0c\x00\x0f\x00\x0b\x00\x04\x00\x00\x00\x08\x00\xff\xff\xff\xff\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 16) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16) + ] + +happy_n_terms = 11 :: Int +happy_n_nonterms = 8 :: Int + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_3 0# happyReduction_3 +happyReduction_3 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (reverse happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + ([ happy_var_1 ] + )} + +happyReduce_5 = happySpecReduce_3 1# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn7 + (happy_var_3 defaultPackageConfig + ) `HappyStk` happyRest} + +happyReduce_7 = happySpecReduce_1 3# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (\p -> happy_var_1 p + )} + +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_3 of { happy_var_3 -> + happyIn8 + (\p -> happy_var_1 (happy_var_3 p) + )}} + +happyReduce_9 = happySpecReduce_3 4# happyReduction_9 +happyReduction_9 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn9 + (\p -> case happy_var_1 of + "name" -> p{name = happy_var_3} + _ -> error "unknown key in config file" + )}} + +happyReduce_10 = happySpecReduce_3 4# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of { + "auto" -> p{auto = happy_var_3}; + _ -> p } + )}} + +happyReduce_11 = happySpecReduce_3 4# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "import_dirs" -> p{import_dirs = happy_var_3} + "library_dirs" -> p{library_dirs = happy_var_3} + "hs_libraries" -> p{hs_libraries = happy_var_3} + "extra_libraries" -> p{extra_libraries = happy_var_3} + "include_dirs" -> p{include_dirs = happy_var_3} + "c_includes" -> p{c_includes = happy_var_3} + "package_deps" -> p{package_deps = happy_var_3} + "extra_ghc_opts" -> p{extra_ghc_opts = happy_var_3} + "extra_cc_opts" -> p{extra_cc_opts = happy_var_3} + "extra_ld_opts" -> p{extra_ld_opts = happy_var_3} + "framework_dirs" -> p{framework_dirs = happy_var_3} + "extra_frameworks"-> p{extra_frameworks= happy_var_3} + _other -> p + )}} + +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = happyIn10 + ([] + ) + +happyReduce_13 = happySpecReduce_3 5# happyReduction_13 +happyReduction_13 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn10 + (reverse happy_var_2 + )} + +happyReduce_14 = happySpecReduce_1 6# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOutTok happy_x_1 of { (ITstring happy_var_1) -> + happyIn11 + ([ happy_var_1 ] + )} + +happyReduce_15 = happySpecReduce_3 6# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn11 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_16 = happyMonadReduce 1# 7# happyReduction_16 +happyReduction_16 (happy_x_1 `HappyStk` + happyRest) + = happyThen (case happyOutTok happy_x_1 of { (ITconid happy_var_1) -> + case happy_var_1 of { + "True" -> True; + "False" -> False; + _ -> error ("unknown constructor in config file: " ++ happy_var_1) }} + ) (\r -> happyReturn (happyIn12 r)) + +happyNewToken action sts stk [] = + happyDoAction 10# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + ITocurly -> cont 1#; + ITccurly -> cont 2#; + ITobrack -> cont 3#; + ITcbrack -> cont 4#; + ITcomma -> cont 5#; + ITequal -> cont 6#; + ITvarid happy_dollar_dollar -> cont 7#; + ITconid happy_dollar_dollar -> cont 8#; + ITstring happy_dollar_dollar -> cont 9#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x)) + +happySeq = happyDontSeq + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) where +lexer _ = error "Unexpected token" + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParsePkgConfLite.hs,v 1.3 2004/06/19 01:28:56 dons Exp $ + + + + + + + + + + + + + +{-# LINE 27 "GenericTemplate.hs" #-} + + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j + (happyTcHack st)) + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 165 "GenericTemplate.hs" #-} + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/plugins/Plugins/ParsePkgConfLite.y b/src/plugins/Plugins/ParsePkgConfLite.y new file mode 100644 index 0000000..08b2e24 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfLite.y @@ -0,0 +1,159 @@ +-- +-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Taken (apart from the most minor of alterations) from +-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs: +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. +-- + +{ + +{-# OPTIONS -w #-} + +module Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import Plugins.Package ( PackageConfig(..), defaultPackageConfig ) + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper ) +import List ( break ) + +} + +%token + '{' { ITocurly } + '}' { ITccurly } + '[' { ITobrack } + ']' { ITcbrack } + ',' { ITcomma } + '=' { ITequal } + VARID { ITvarid $$ } + CONID { ITconid $$ } + STRING { ITstring $$ } + +%name parse pkgconf +%name parseOne pkg +%tokentype { Token } +%% + +pkgconf :: { [ PackageConfig ] } + : '[' ']' { [] } + | '[' pkgs ']' { reverse $2 } + +pkgs :: { [ PackageConfig ] } + : pkg { [ $1 ] } + | pkgs ',' pkg { $3 : $1 } + +pkg :: { PackageConfig } + : CONID '{' fields '}' { $3 defaultPackageConfig } + +fields :: { PackageConfig -> PackageConfig } + : field { \p -> $1 p } + | fields ',' field { \p -> $1 ($3 p) } + +field :: { PackageConfig -> PackageConfig } + : VARID '=' STRING + {\p -> case $1 of + "name" -> p{name = $3} + _ -> error "unknown key in config file" } + + | VARID '=' bool + {\p -> case $1 of { + "auto" -> p{auto = $3}; + _ -> p } } + + | VARID '=' strlist + {\p -> case $1 of + "import_dirs" -> p{import_dirs = $3} + "library_dirs" -> p{library_dirs = $3} + "hs_libraries" -> p{hs_libraries = $3} + "extra_libraries" -> p{extra_libraries = $3} + "include_dirs" -> p{include_dirs = $3} + "c_includes" -> p{c_includes = $3} + "package_deps" -> p{package_deps = $3} + "extra_ghc_opts" -> p{extra_ghc_opts = $3} + "extra_cc_opts" -> p{extra_cc_opts = $3} + "extra_ld_opts" -> p{extra_ld_opts = $3} + "framework_dirs" -> p{framework_dirs = $3} + "extra_frameworks"-> p{extra_frameworks= $3} + _other -> p + } + +strlist :: { [String] } + : '[' ']' { [] } + | '[' strs ']' { reverse $2 } + +strs :: { [String] } + : STRING { [ $1 ] } + | strs ',' STRING { $3 : $1 } + +bool :: { Bool } + : CONID {% case $1 of { + "True" -> True; + "False" -> False; + _ -> error ("unknown constructor in config file: " ++ $1) } } + +{ + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) where +lexer _ = error "Unexpected token" + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer + +} diff --git a/src/plugins/Plugins/Parser.hs b/src/plugins/Plugins/Parser.hs new file mode 100644 index 0000000..9638e99 --- /dev/null +++ b/src/plugins/Plugins/Parser.hs @@ -0,0 +1,229 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program 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 +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module Plugins.Parser ( + parse, mergeModules, pretty, parsePragmas, + HsModule(..) , + replaceModName + ) where + +import Data.List +import Data.Char +import Data.Either + +import Language.Haskell.Parser +import Language.Haskell.Syntax +import Language.Haskell.Pretty + +-- +-- | parse a file (as a string) as Haskell src +-- +parse :: FilePath -- ^ module name + -> String -- ^ haskell src + -> Either String HsModule -- ^ abstract syntax + +parse f fsrc = + case parseModuleWithMode (ParseMode f) fsrc of + ParseOk src -> Right src + ParseFailed loc _ -> Left $ srcmsg loc + where + srcmsg loc = "parse error in " ++ f ++ "\n" ++ + "line: " ++ (show $ srcLine loc) ++ + ", col: " ++ (show $ srcColumn loc)++ "\n" + +-- +-- | pretty print haskell src +-- +-- doesn't handle operators with '#' at the end. i.e. unsafeCoerce# +-- +pretty :: HsModule -> String +pretty code = prettyPrintWithMode (defaultMode { linePragmas = True }) code + + +-- | +-- mergeModules : generate a full Haskell src file, give a .hs config +-- file, and a stub to take default syntax and decls from. Mostly we +-- just ensure they don't do anything bad, and that the names are +-- correct for the module. +-- +-- Transformations: +-- +-- * Take src location pragmas from the conf file (1st file) +-- * Use the template's (2nd argument) module name +-- * Only use export list from template (2nd arg) +-- * Merge top-level decls +-- * need to force the type of the plugin to match the stub, +-- overwriting any type they supply. +-- +mergeModules :: HsModule -> -- ^ Configure module + HsModule -> -- ^ Template module + HsModule -- ^ A merge of the two + +mergeModules (HsModule l _ _ is ds ) + (HsModule _ m' es' is' ds') + = (HsModule l m' es' + (mImps m' is is') + (mDecl ds ds') ) + +-- +-- replace Module name with String. +-- +replaceModName :: HsModule -> String -> HsModule +replaceModName (HsModule l _ es is ds) nm = (HsModule l (Module nm) es is ds) + +-- +-- | merge import declarations: +-- +-- * ensure that the config file doesn't import the stub name +-- * merge import lists uniquely, and when they match, merge their decls +-- +-- TODO : we don't merge imports of the same module from both files. +-- We should, and then merge the decls in their import list +-- ** rename args, too confusing. +-- +-- quick fix: strip all type signatures from the source. +-- +mImps :: Module -> -- ^ plugin module name + [HsImportDecl] -> -- ^ conf file imports + [HsImportDecl] -> -- ^ stub file imports + [HsImportDecl] + +mImps plug_mod cimps timps = + case filter (!~ self) cimps of cimps' -> unionBy (=~) cimps' timps + where + self = ( HsImportDecl undefined plug_mod undefined undefined undefined ) + +-- +-- | merge top-level declarations +-- +-- Remove decls found in template, using those from the config file. +-- Need to sort decls by types, then decls first, in both. +-- +-- * could we write a pass to handle "editor, foo :: String" ? +-- +-- we must keep the type from the template. +-- +mDecl ds es = let ds' = filter (\t->not $ typeDecl t) ds -- rm type sigs from plugin + in sortBy decls $! unionBy (=~) ds' es + where + decls a b = compare (encoding a) (encoding b) + + typeDecl :: HsDecl -> Bool + typeDecl (HsTypeSig _ _ _) = True + typeDecl _ = False + + encoding :: HsDecl -> Int + encoding d = case d of + HsFunBind _ -> 1 + HsPatBind _ _ _ _ -> 1 + _ -> 0 + +-- +-- syntactic equality over the useful Haskell abstract syntax +-- this may be extended if we try to merge the files more thoroughly +-- +class SynEq a where + (=~) :: a -> a -> Bool + (!~) :: a -> a -> Bool + n !~ m = not (n =~ m) + +instance SynEq HsDecl where + (HsPatBind _ (HsPVar n) _ _) =~ (HsPatBind _ (HsPVar m) _ _) = n == m + (HsTypeSig _ (n:_) _) =~ (HsTypeSig _ (m:_) _) = n == m + _ =~ _ = False + +instance SynEq HsImportDecl where + (HsImportDecl _ m _ _ _) =~ (HsImportDecl _ n _ _ _) = n == m + + +-- +-- | Parsing option pragmas. +-- +-- This is not a type checker. If the user supplies bogus options, +-- they'll get slightly mystical error messages. Also, we *want* to +-- handle -package options, and other *static* flags. This is more than +-- GHC. +-- +-- GHC user's guide : +-- "OPTIONS pragmas are only looked for at the top of your source +-- files, upto the first (non-literate,non-empty) line not +-- containing OPTIONS. Multiple OPTIONS pragmas are recognised." +-- +-- based on getOptionsFromSource(), in main/DriverUtil.hs +-- +parsePragmas :: String -- ^ input src + -> ([String],[String]) -- ^ normal options, global options + +parsePragmas s = look $ lines s + where + look [] = ([],[]) + look (l':ls) = + let l = remove_spaces l' + in case () of + () | null l -> look ls + | prefixMatch "#" l -> look ls + | prefixMatch "{-# LINE" l -> look ls + | Just (Option o) <- matchPragma l + -> let (as,bs) = look ls in (words o ++ as,bs) + | Just (Global g) <- matchPragma l + -> let (as,bs) = look ls in (as,words g ++ bs) + | otherwise -> ([],[]) + +-- +-- based on main/DriverUtil.hs +-- +-- extended to handle dynamic options too +-- + +data Pragma = Option !String | Global !String + +matchPragma :: String -> Maybe Pragma +matchPragma s + | Just s1 <- maybePrefixMatch "{-#" s, -- -} + Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1), + Just s3 <- maybePrefixMatch "}-#" (reverse s2) + = Just (Option (reverse s3)) + + | Just s1 <- maybePrefixMatch "{-#" s, -- -} + Just s2 <- maybePrefixMatch "GLOBALOPTIONS" (remove_spaces s1), + Just s3 <- maybePrefixMatch "}-#" (reverse s2) + = Just (Global (reverse s3)) + + | otherwise + = Nothing + +remove_spaces :: String -> String +remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- +-- verbatim from utils/Utils.lhs +-- +prefixMatch :: Eq a => [a] -> [a] -> Bool +prefixMatch [] _str = True +prefixMatch _pat [] = False +prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss + | otherwise = False + +maybePrefixMatch :: String -> String -> Maybe String +maybePrefixMatch [] rest = Just rest +maybePrefixMatch (_:_) [] = Nothing +maybePrefixMatch (p:pat) (r:rest) + | p == r = maybePrefixMatch pat rest + | otherwise = Nothing diff --git a/src/plugins/Plugins/Utils.hs b/src/plugins/Plugins/Utils.hs new file mode 100644 index 0000000..5d6d276 --- /dev/null +++ b/src/plugins/Plugins/Utils.hs @@ -0,0 +1,454 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +#include "../../../config.h" + +module Plugins.Utils ( + Arg, + + hWrite, + + mkUnique, + hMkUnique, + mkUniqueIn, + hMkUniqueIn, + + mkTemp, mkTempIn, {- internal -} + + replaceSuffix, + outFilePath, + dropSuffix, + mkModid, + + isSublistOf, -- :: Eq a => [a] -> [a] -> Bool + + dirname, + basename, + + (), (<.>), (<+>), (<>), + + newer, + + encode, + decode, + EncodedString, + + exec, + panic + + ) where + +import Plugins.Env ( isLoaded ) +import Plugins.Consts ( objSuf, hiSuf, tmpDir ) +import qualified Plugins.MkTemp ( mkstemps ) + +import Data.Char +import Data.List + +import System.IO +import System.Environment ( getEnv ) +import System.Directory + +-- +-- The fork library +-- +#if CABAL == 0 && __GLASGOW_HASKELL__ < 604 +import POpen ( popen ) +import System.Posix.Process ( getProcessStatus ) +#else +import System.Process +#endif + +-- --------------------------------------------------------------------- +-- some misc types we use + +type Arg = String + +-- --------------------------------------------------------------------- +-- | useful +-- +panic s = ioError ( userError s ) + +-- --------------------------------------------------------------------- +-- | writeFile for Handles +-- +hWrite :: Handle -> String -> IO () +hWrite hdl src = hPutStr hdl src >> hClose hdl >> return () + + +-- --------------------------------------------------------------------- +-- | mkstemps. +-- +-- We use the Haskell version now... it is faster than calling into +-- mkstemps(3). +-- + +mkstemps :: String -> Int -> IO (String,Handle) +mkstemps path slen = do + m_v <- Plugins.MkTemp.mkstemps path slen + case m_v of Nothing -> error "mkstemps : couldn't create temp file" + Just v' -> return v' + +{- + +mkstemps path slen = do + withCString path $ \ ptr -> do + let c_slen = fromIntegral $ slen+1 + fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen + name <- peekCString ptr + hdl <- fdToHandle fd + return (name, hdl) + +foreign import ccall unsafe "mkstemps" c_mkstemps :: CString -> CInt -> IO Fd + +-} + +-- --------------------------------------------------------------------- +-- | create a new temp file, returning name and handle. +-- bit like the mktemp shell utility +-- +mkTemp :: IO (String,Handle) +mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\_ -> return tmpDir) + mkTempIn tmpd + +mkTempIn :: String -> IO (String, Handle) +mkTempIn tmpd = do + (tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3 + let modname = mkModid $ dropSuffix tmpf + if and $ map (\c -> isAlphaNum c && c /= '_') modname + then return (tmpf,hdl) + else panic $ "Illegal characters in temp file: `"++tmpf++"'" + +-- --------------------------------------------------------------------- +-- | Get a new temp file, unique from those in /tmp, and from those +-- modules already loaded. Very nice for merge/eval uses. +-- +-- Will run for a long time if we can't create a temp file, luckily +-- mkstemps gives us a pretty big search space +-- +mkUnique :: IO FilePath +mkUnique = do (t,h) <- hMkUnique + hClose h >> return t + +hMkUnique :: IO (FilePath,Handle) +hMkUnique = do (t,h) <- mkTemp + alreadyLoaded <- isLoaded t -- not unique! + if alreadyLoaded + then hClose h >> removeFile t >> hMkUnique + else return (t,h) + +mkUniqueIn :: FilePath -> IO FilePath +mkUniqueIn dir = do (t,h) <- hMkUniqueIn dir + hClose h >> return t + +hMkUniqueIn :: FilePath -> IO (FilePath,Handle) +hMkUniqueIn dir = do (t,h) <- mkTempIn dir + alreadyLoaded <- isLoaded t -- not unique! + if alreadyLoaded + then hClose h >> removeFile t >> hMkUniqueIn dir + else return (t,h) + +-- --------------------------------------------------------------------- +-- +-- | execute a command and it's arguments, returning the +-- (stdout,stderr), waiting for it to exit, too. +-- + +exec :: String -> [String] -> IO ([String],[String]) + +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +-- +-- Use the forkProcess library +-- +exec prog args = do + (_,outh,errh,proc_hdl) <- runInteractiveProcess prog args Nothing Nothing + b <- waitForProcess proc_hdl -- wait + out <- hGetContents outh + err <- hGetContents errh + case b of + _exit_status -> return ( lines $ out, lines $ err ) + +#else +-- +-- 6.2.2 Posix version. +-- +exec prog args = do + (out,err,pid) <- popen prog args Nothing + b <- getProcessStatus True False pid -- wait + case b of + Nothing -> return ([], ["process `"++prog++"' has disappeared"]) + _ -> return ( lines $! out, lines $! err ) +#endif + +-- --------------------------------------------------------------------- +-- some filename manipulation stuff + +-- +-- | , <.> : join two path components +-- +infixr 6 +infixr 6 <.> + +(), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath +[] b = b +a b = a ++ "/" ++ b + +[] <.> b = b +a <.> b = a ++ "." ++ b + +[] <+> b = b +a <+> b = a ++ " " ++ b + +[] <> b = b +a <> b = a ++ b + +-- +-- | dirname : return the directory portion of a file path +-- if null, return "." +-- +dirname :: FilePath -> FilePath +dirname p = + case reverse $ dropWhile (/= '/') $ reverse p of + [] -> "." + p' -> p' + +-- +-- | basename : return the filename portion of a path +-- +basename :: FilePath -> FilePath +basename p = reverse $ takeWhile (/= '/') $ reverse p + +-- +-- drop suffix +-- +dropSuffix :: FilePath -> FilePath +dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f + +-- +-- | work out the mod name from a filepath +mkModid :: String -> String +mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (/= '/')) . reverse + +-- | return the object file, given the .conf file +-- i.e. /home/dons/foo.rc -> /home/dons/foo.o +-- +-- we depend on the suffix we are given having a lead '.' +-- +replaceSuffix :: FilePath -> String -> FilePath +replaceSuffix [] _ = [] -- ? +replaceSuffix f suf = + case reverse $ dropWhile (/= '.') $ reverse f of + [] -> f ++ suf -- no '.' in file name + f' -> f' ++ tail suf + +-- +-- Normally we create the .hi and .o files next to the .hs files. +-- For some uses this is annoying (i.e. true EDSL users don't actually +-- want to know that their code is compiled at all), and for hmake-like +-- applications. +-- +-- This code checks if "-o foo" or "-odir foodir" are supplied as args +-- to make(), and if so returns a modified file path, otherwise it +-- uses the source file to determing the path to where the object and +-- .hi file will be put. +-- +outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath) +outFilePath src args = + let objs = find_o args -- user sets explicit object path + paths = find_p args -- user sets a directory to put stuff in + in case () of { _ + | not (null objs) + -> let obj = last objs in (obj, mk_hi obj) + + | not (null paths) + -> let obj = last paths mk_o (basename src) in (obj, mk_hi obj) + + | otherwise + -> (mk_o src, mk_hi src) + } + where + outpath = "-o" + outdir = "-odir" + + mk_hi s = replaceSuffix s hiSuf + mk_o s = replaceSuffix s objSuf + + find_o [] = [] + find_o (f:f':fs) | f == outpath = [f'] + | otherwise = find_o $! f':fs + find_o _ = [] + + find_p [] = [] + find_p (f:f':fs) | f == outdir = [f'] + | otherwise = find_p $! f':fs + find_p _ = [] + +------------------------------------------------------------------------ + +-- +-- | is file1 newer than file2? +-- +-- needs some fixing to work with 6.0.x series. (is this true?) +-- +-- fileExist still seems to throw exceptions on some platforms: ia64 in +-- particular. +-- +-- invarient : we already assume the first file, 'a', exists +-- +newer :: FilePath -> FilePath -> IO Bool +newer a b = do + a_t <- getModificationTime a + b_exists <- doesFileExist b + if not b_exists + then return True -- needs compiling + else do b_t <- getModificationTime b + return ( a_t > b_t ) -- maybe need recompiling + +------------------------------------------------------------------------ +-- +-- | return the Z-Encoding of the string. +-- +-- Stolen from GHC. Use -package ghc as soon as possible +-- +type EncodedString = String + +encode :: String -> EncodedString +encode [] = [] +encode (c:cs) = encode_ch c ++ encode cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- +-- Decode is used for user printing. +-- +decode :: EncodedString -> String +decode [] = [] +decode ('Z' : d : rest) | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : decode rest +decode ('z' : d : rest) | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : decode rest +decode (c : rest) = c : decode rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = error $ "decode_upper can't handle this char `"++[ch]++"'" + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = error $ "decode_lower can't handle this char `"++[ch]++"'" + +-- Characters not having a specific code are coded as z224U +decode_num_esc :: Char -> [Char] -> String +decode_num_esc d cs + = go (digitToInt d) cs + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go n ('U' : rest) = chr n : decode rest + go _ other = error $ + "decode_num_esc can't handle this: \""++other++"\"" + + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = 'z' : shows (ord c) "U" + +decode_tuple :: Char -> EncodedString -> String +decode_tuple d cs + = go (digitToInt d) cs + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ['T'] = "()" + go n ['T'] = '(' : replicate (n-1) ',' ++ ")" + go 1 ['H'] = "(# #)" + go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)" + go _ other = error $ "decode_tuple \'"++other++"'" + +-- --------------------------------------------------------------------- + +-- +-- 'isSublistOf' takes two arguments and returns 'True' iff the first +-- list is a sublist of the second list. This means that the first list +-- is wholly contained within the second list. Both lists must be +-- finite. + +isSublistOf :: Eq a => [a] -> [a] -> Bool +isSublistOf [] _ = True +isSublistOf _ [] = False +isSublistOf x y@(_:ys) + | isPrefixOf x y = True + | otherwise = isSublistOf x ys + diff --git a/src/plugins/plugins.conf.in.cpp b/src/plugins/plugins.conf.in.cpp new file mode 100644 index 0000000..87c50ba --- /dev/null +++ b/src/plugins/plugins.conf.in.cpp @@ -0,0 +1,63 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "plugins", + auto = False, +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/plugins" ], + library_dirs = [ "${TOP}/src/plugins" ], +#endif + hs_libraries = [ "HSplugins" ], + c_includes = [ "Linker.h" ], + include_dirs = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "altdata", "hi", "unix", "haskell-src", "posix" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} + +#else + +name: plugins +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + Plugins.Consts, + Plugins.Env, + Plugins.Load, + Plugins.Make, + Plugins.MkTemp, + Plugins.PackageAPI, + Plugins.ParsePkgConfCabal, + Plugins.Parser, + Plugins.Utils, + Plugins + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/plugins +library-dirs: TOP/src/plugins +#endif +hs-libraries: HSplugins +extra-libraries: +include-dirs: +includes: Linker.h +depends: altdata, hi, unix, haskell-src, posix, Cabal +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: + +#endif diff --git a/src/printf/Makefile b/src/printf/Makefile new file mode 100644 index 0000000..e908c81 --- /dev/null +++ b/src/printf/Makefile @@ -0,0 +1,16 @@ +PKG = printf +UPKG = Printf + +YOBJ = $(UPKG)/Parser.hs +YSRC = $(UPKG)/Parser.y + +XOBJ = $(UPKG)/Lexer.hs +XSRC = $(UPKG)/Lexer.x + +TOP=../.. +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package eval + +install: install-me diff --git a/src/printf/Printf.hs b/src/printf/Printf.hs new file mode 100644 index 0000000..d83d4a2 --- /dev/null +++ b/src/printf/Printf.hs @@ -0,0 +1,25 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Printf ( + module Printf.Compile + ) where + +import Printf.Compile {-all-} + diff --git a/src/printf/Printf/Compile.hs b/src/printf/Printf/Compile.hs new file mode 100644 index 0000000..42a1871 --- /dev/null +++ b/src/printf/Printf/Compile.hs @@ -0,0 +1,390 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- +-- Some of the backend code is based on Ian Lynagh's TH version of +-- Printf. +-- +-- The specification of this implementation is taken from +-- the OpenBSD 3.5 man page for printf(3) +-- + +module Printf.Compile ( + printf, + (!), + ($>), ($<), + ) where + +import Printf.Lexer +import Printf.Parser + +import Eval.Haskell ( eval ) +import Eval.Utils ( escape ) +import Plugins.Utils ( (<>), (<+>) ) + +import AltData.Dynamic +import AltData.Typeable hiding ( typeOf ) + +import Data.List +import Data.Maybe ( isNothing, isJust ) + +import System.IO.Unsafe ( unsafePerformIO ) + +type Type = String +type Code = String + +-- --------------------------------------------------------------------- +-- +-- Generate a new Haskell function, as compiled native-code, from a +-- printf format string. It isn't applied to its arguments yet. +-- The function will return a String, but we won't typecheck this till +-- application. +-- +printf :: String -> Dynamic -- ([Dynamic] -> String) +printf fmt = run src ["Data.Char","Numeric"] + where + src = compile . parse . scan' . escape $ fmt + scan' s = either (error "lexer failed") (id) (scan s) + + run e i = case unsafePerformIO (eval e i) of + Nothing -> error "source failed to compile" + Just a -> a + +-- +-- application shortcuts. these expect all arguments to be supplied, and +-- if this is so, we can then give the result a type. +-- partial application means type annotations, or retaining everything +-- as a Dynamic +-- + +-- +-- sprintf +-- Apply a new fn to a arg list, returning a String +-- +infixr 0 $< +($<) :: Dynamic -> [Dynamic] -> String +f $< as = fromDynamic $! f `dynAppHList` as + +-- +-- printf +-- Apply a new fn to a arg list, printing out the result +-- +infixr 0 $> +($>) :: Dynamic -> [Dynamic] -> IO () +f $> as = putStr (fromDynamic $! f `dynAppHList` as) + +-- --------------------------------------------------------------------- +-- a printf code generator +-- +-- ToDo handle all the different specifiers +-- +-- Compile a printf format syntax tree into a Haskell string +-- representing a Haskell function to implement this printf. +-- +compile :: [Format] -> String +compile fmt = + let (tys,src) = compile' fmt 0 + in "toDyn $ \\" <> + spacify (map (\(ty,i) -> parens('x':show i <+> "::" <+> ty)) + (zip tys [0..length src])) <+> "->" <+> consify src + + where spacify s = concat (intersperse " " s) + consify s = concat (intersperse "++" s) + +-- --------------------------------------------------------------------- +-- +-- Compile an individual format or string literal + +compile' :: [Format] -> Int -> ([String],[String]) +compile' [] _ = ([],[]) + +compile' ((StrLit s):xs) i = ( ts, ( '"':s++"\"" ):ss ) + where (ts,ss) = compile' xs i + +compile' ((ConvSp _ _ _ _ Percent):xs) i = (ts, "\"%\"":ss) + where (ts,ss) = compile' xs $! i+1 + +compile' (c@(ConvSp _ _ _ _ t):xs) i = + (typeOf t:ts, parens( + (snd.plus.pad.alt.trunc.codeOf) c -- apply transformations + <+> ident i) : ss) + + where (ts, ss) = compile' xs $! i+1 + +-- --------------------------------------------------------------------- +-- +-- What argument type does a conversion specifier generate? +-- should be a FM +-- +typeOf :: Conv -> Type +typeOf x = case x of + D -> "Int" + O -> "Int" + Xx -> "Int" + XX -> "Int" + U -> "Int" + C -> "Char" + S -> "String" + F -> "Double" + Ee -> "Double" + EE -> "Double" + Gg -> "Double" + GG -> "Double" + Percent -> error "typeOf %: conversion specifier has no argument type" + +-- --------------------------------------------------------------------- +-- +-- Generate Haskell code for each particular format +-- +codeOf :: Format -> (Format,Code) +codeOf c@(ConvSp _ _ p _ f) = case f of + +-- diouxX The int (or appropriate variant) argument is converted to signed +-- decimal (d and i), unsigned octal (o), unsigned decimal (u), or +-- unsigned hexadecimal (x and X) notation. The letters abcdef are +-- used for x conversions; the letters ABCDEF are used for X conver- +-- sions. The precision, if any, gives the minimum number of digits +-- that must appear; if the converted value requires fewer digits, +-- it is padded on the left with zeros. + + D -> (c,"(show)") + U -> (c,"(show)") + O -> (c,"(\\v -> showOct v [])") + Xx -> (c,"(\\v -> showHex v [])") + XX -> (c,"(\\v -> map toUpper (showHex v []))") + +-- eE The double argument is rounded and converted in the style +-- [-]d.ddde+-dd where there is one digit before the decimal-point +-- character and the number of digits after it is equal to the pre- +-- cision; if the precision is missing, it is taken as 6; if the +-- precision is zero, no decimal-point character appears. An E con- +-- version uses the letter E (rather than e) to introduce the expo- +-- nent. The exponent always contains at least two digits; if the +-- value is zero, the exponent is 00. + +-- TODO prints exponent differently to printf(3) + + Ee -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->(showEFloat("++prec++")v)[])") + + EE -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->map toUpper((showEFloat ("++prec++")v)[]))") + +-- gG The double argument is converted in style f or e (or E for G con- +-- versions). The precision specifies the number of significant +-- digits. If the precision is missing, 6 digits are given; if the +-- precision is zero, it is treated as 1. Style e is used if the +-- exponent from its conversion is less than -4 or greater than or +-- equal to the precision. Trailing zeros are removed from the +-- fractional part of the result; a decimal point appears only if it +-- is followed by at least one digit. + +-- TODO unimplemented + + Gg -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->(showGFloat("++prec++")v)[])") + + GG -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->map toUpper((showGFloat ("++prec++")v)[]))") + +-- f The double argument is rounded and converted to decimal notation +-- in the style [-]ddd.ddd, where the number of digits after the +-- decimal-point character is equal to the precision specification. +-- If the precision is missing, it is taken as 6; if the precision +-- is explicitly zero, no decimal-point character appears. If a +-- decimal point appears, at least one digit appears before it. + + F -> let prec = if isNothing p then "Just 6" else show p + in (c, "(\\v -> (showFFloat ("++prec++") v) [])") + +-- c The int argument is converted to an unsigned char, and the re- +-- sulting character is written. + + C -> (c,"(\\c -> (showLitChar c) [])") + +-- s The char * argument is expected to be a pointer to an array of +-- character type (pointer to a string). Characters from the array +-- are written up to (but not including) a terminating NUL charac- +-- ter; if a precision is specified, no more than the number speci- +-- fied are written. If a precision is given, no null character +-- need be present; if the precision is not specified, or is greater +-- than the size of the array, the array must contain a terminating +-- NUL character. + + S -> (c,"(id)") + +-- % A `%' is written. No argument is converted. The complete con- +-- version specification is `%%'. + + Percent -> (c,"%") + +codeOf _ = error "codeOf: unknown conversion specifier" + +-- --------------------------------------------------------------------- +-- +-- Do we need a leading + ? +-- +-- A `+' character specifying that a sign always be placed before a +-- number produced by a signed conversion. A `+' overrides a space +-- if both are used. +-- +plus :: (Format, Code) -> (Format, Code) +plus p@(StrLit _,_) = p +plus a@(c@(ConvSp fs _w _ _ x), code) = case x of + D -> prefix + Ee-> prefix + EE-> prefix + Gg-> prefix + GG-> prefix + F -> prefix + _ -> a + + where prefix = let pref | Signed `elem` fs = "\"+\"" + | Space `elem` fs = "\" \"" + | otherwise = "[]" + in (c,parens("\\v ->"<+>pref<+>"++ v") <$> code) + + {- munge = case w of + Just w' | w' > 0 -> "tail" + _ -> "" -} + +-- --------------------------------------------------------------------- +-- Work out padding. +-- +-- A negative field width flag `-' indicates the converted value is +-- to be left adjusted on the field boundary. Except for n conver- +-- sions, the converted value is padded on the right with blanks, +-- rather than on the left with blanks or zeros. A `-' overrides a +-- `0' if both are given. +-- +-- A zero `0' character specifying zero padding. For all conver- +-- sions except n, the converted value is padded on the left with +-- zeros rather than blanks. If a precision is given with a numeric +-- conversion (d, i, o, u, x, and X), the `0' flag is ignored. +-- +pad :: (Format,Code) -> (Format,Code) +pad (c@(ConvSp fs (Just w) p _ x),code) + + | LeftAdjust `elem` fs + = (c, parens(parens("\\i c s -> if length s < i"<+> + "then s ++ take (i-length s) (repeat c) else s") + <+>show w<+>"' '")<$>code ) + + | otherwise + = (c, parens(parens("\\i c s -> if length s < i"<+> + "then take (i-length s) (repeat c) ++ s else s") + <+>show w<+>pad_chr)<$>code) + + where pad_chr | isNumeric x && isJust p = "' '" + | LeadZero `elem` fs = "'0'" + | otherwise = "' '" + +pad (c@(ConvSp _ Nothing _ _ _),code) = (c,code) + +pad ((StrLit _),_) = error "pad: can't pad str lit" + +isNumeric :: Conv -> Bool +isNumeric x = case x of + D -> True + O -> True + U -> True + Xx -> True + XX -> True + _ -> False + +-- --------------------------------------------------------------------- +-- +-- Check the 'alternate' modifier +-- +-- A hash `#' character specifying that the value should be convert- +-- ed to an ``alternate form''. For c, d, i, n, p, s, and u conver- +-- sions, this option has no effect. For o conversions, the preci- +-- sion of the number is increased to force the first character of +-- the output string to a zero (except if a zero value is printed +-- with an explicit precision of zero). For x and X conversions, a +-- non-zero result has the string `0x' (or `0X' for X conversions) +-- prepended to it. For e, E, f, g, and G conversions, the result +-- will always contain a decimal point, even if no digits follow it +-- (normally, a decimal point appears in the results of those con- +-- versions only if a digit follows). For g and G conversions, +-- trailing zeros are not removed from the result as they would oth- +-- erwise be. +-- + +alt :: (Format,Code) -> (Format,Code) +alt a@(c@(ConvSp fs _ _ _ x), code) | Alt `elem` fs = case x of + + Xx -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+> + "then \"0x\"++v else v")<$>code) + + XX -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+> + "then \"0X\"++v else v")<$>code) + + O -> (c,parens("\\v->if fst(head(readOct v)) /= 0"<+> + "then \"0\"++v else v")<$>code) + _ -> a + +alt a = a + +-- --------------------------------------------------------------------- +-- +-- Handle precision. Involves truncating strings and decimal points +-- +-- An optional precision, in the form of a period `.' followed by an op- +-- tional digit string. If the digit string is omitted, the precision +-- is taken as zero. This gives the minimum number of digits to appear +-- for d, i, o, u, x, and X conversions, the number of digits to appear +-- after the decimal-point for e, E, and f conversions, the maximum num- +-- ber of significant digits for g and G conversions, or the maximum +-- number of characters to be printed from a string for s conversions. +-- +trunc :: (Format,Code) -> (Format,Code) +trunc (c@(ConvSp _ _ (Just i) _ x), code) = case x of + S -> (c, parens("(\\i s -> if length s > i"<+> + "then take i s else s)"<+>show i)<$>code) + + _ | isNumeric x -> {-TODO-} (c, code) + | otherwise -> (c, code) + +trunc c = c + +-- --------------------------------------------------------------------- +-- make a new variable +ident i = 'x':show i + +-- wrap in parens +parens p = "("++p++")" + +-- lazy operator +infixr 6 <$> +(<$>) :: String -> String -> String +[] <$> a = a +a <$> b = a ++ " $ " ++ b + +-- --------------------------------------------------------------------- +-- +-- This bit of syntax constructs a [Dynamic]. +-- +infixr 6 ! +(!) :: Typeable a => a -> [Dynamic] -> [Dynamic] +a ! xs = toDyn a : xs + diff --git a/src/printf/Printf/Lexer.hs b/src/printf/Printf/Lexer.hs new file mode 100644 index 0000000..171fb53 --- /dev/null +++ b/src/printf/Printf/Lexer.hs @@ -0,0 +1,407 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 25 "Printf/Lexer.x" #-} + +{-# OPTIONS -w #-} +-- ^ don't want to see all the warns alex templates produce + +module Printf.Lexer ( scan, Token(..) ) where + + +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\xf7\xff\xe2\xff\xef\xff\xf9\xff\x04\x00\x00\x00\xe6\xff\xfa\xff\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\x06\x00\xff\xff\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x06\x00\xff\xff\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x0a\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x08\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x09\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x0a\x00\x20\x00\x0a\x00\xff\xff\x23\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x0a\x00\x2d\x00\xff\xff\x2b\x00\x30\x00\x2d\x00\x25\x00\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x2e\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\xff\xff\x75\x00\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x04\x00\xff\xff\xff\xff\x04\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,10) [[],[(AlexAcc (alex_action_2))],[],[],[(AlexAcc (alex_action_0))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))]] +{-# LINE 54 "Printf/Lexer.x" #-} + + +mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token + +mkflags (_,_,input) len = return (FlagT (take len input)) +mkconv (_,_,(c:_)) _ = return (ConvT c) +mklength (_,_,(c:_)) _ = return (LengthT c) +mkint (_,_,input) len = return (IntT (read (take len input))) +mkstr (_,_,input) len = return (StrT (take len input)) +mkdot _ _ = return DotT + +alexEOF = return EOFT + +data Token + = FlagT [Char] + | ConvT Char + | LengthT Char + | IntT Int + | StrT String + | DotT + | EOFT + deriving (Eq, Show) + +scan :: String -> Either String [Token] +scan str = runAlex str $ do + let loop tks = do + tok <- alexMonadScan; + if tok == EOFT then do return $! reverse tks + else loop $! (tok:tks) + loop [] + + + +flag,fmt :: Int +flag = 1 +fmt = 2 +alex_action_0 = mkstr +alex_action_1 = begin flag +alex_action_2 = mkflags `andBegin` fmt +alex_action_3 = mkint +alex_action_4 = mkdot +alex_action_5 = mklength +alex_action_6 = mkconv `andBegin` 0 +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + +{-# LINE 34 "GenericTemplate.hs" #-} + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# + +{-# INLINE alexIndexShortOffAddr #-} +alexIndexShortOffAddr (AlexA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `unsafeAt` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexShortOffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexShortOffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexShortOffAddr alex_table offset + else alexIndexShortOffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i +{-# LINE 1 "wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p,c,[]) = Nothing +alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either String a +runAlex input (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input, + alex_chr = '\n', + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return a = Alex $ \s -> Right (s,a) + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> + Right (s, (pos,c,inp)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp) + = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of + s@(AlexState{}) -> Right (s, ()) + +alexError :: String -> Alex a +alexError message = Alex $ \s -> Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +alexMonadScan = do + inp <- alexGetInput + sc <- alexGetStartCode + case alexScan inp sc of + AlexEOF -> alexEOF + AlexError inp' -> alexError "lexical error" + AlexSkip inp' len -> do + alexSetInput inp' + alexMonadScan + AlexToken inp' len action -> do + alexSetInput inp' + action inp len + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip input len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code input len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +-- andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input len = do alexSetStartCode code; action input len + +-- token :: (String -> Int -> token) -> AlexAction token +token t input len = return (t input len) + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +{-# LINE 146 "wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + +{-# LINE 162 "wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + +{-# LINE 180 "wrappers.hs" #-} + diff --git a/src/printf/Printf/Lexer.x b/src/printf/Printf/Lexer.x new file mode 100644 index 0000000..2b9a310 --- /dev/null +++ b/src/printf/Printf/Lexer.x @@ -0,0 +1,86 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program 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 +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- Lexer for printf format strings +-- Based on B1.2 Formatted Output, from Kernighan and Ritchie. +-- + +{ + +{-# OPTIONS -w #-} +-- ^ don't want to see all the warns alex templates produce + +module Printf.Lexer ( scan, Token(..) ) where + +} + +%wrapper "monad" + +$digit = 0-9 +$conv = [dioxXucsfeEgGpn\%] +$len = [hlL] +$flag = [\-\+\ 0\#] +$str = [. # \%] + +printf :- + +<0> $str+ { mkstr } +<0> \% { begin flag } + + $flag* { mkflags `andBegin` fmt } + + $digit+ { mkint } + \. { mkdot } + $len { mklength } + $conv { mkconv `andBegin` 0 } + +{ + + +mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token + +mkflags (_,_,input) len = return (FlagT (take len input)) +mkconv (_,_,(c:_)) _ = return (ConvT c) +mklength (_,_,(c:_)) _ = return (LengthT c) +mkint (_,_,input) len = return (IntT (read (take len input))) +mkstr (_,_,input) len = return (StrT (take len input)) +mkdot _ _ = return DotT + +alexEOF = return EOFT + +data Token + = FlagT [Char] + | ConvT Char + | LengthT Char + | IntT Int + | StrT String + | DotT + | EOFT + deriving (Eq, Show) + +scan :: String -> Either String [Token] +scan str = runAlex str $ do + let loop tks = do + tok <- alexMonadScan; + if tok == EOFT then do return $! reverse tks + else loop $! (tok:tks) + loop [] + +} diff --git a/src/printf/Printf/Parser.hs b/src/printf/Printf/Parser.hs new file mode 100644 index 0000000..82cfb64 --- /dev/null +++ b/src/printf/Printf/Parser.hs @@ -0,0 +1,719 @@ +{-# OPTIONS -fglasgow-exts -cpp -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +-- parser produced by Happy Version 1.14 + + +-- ^ grr. happy needs them all on one line + +module Printf.Parser where + +import Printf.Lexer +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: ([Format]) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ([Format]) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Format) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Format) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Format) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Format) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Format) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Format) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ([Flag]) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ([Flag]) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Maybe Prec) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Maybe Prec) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Maybe Width) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Maybe Width) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Length) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Length) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Conv) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Conv) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x0f\x00\x00\x00\x14\x00\x0f\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x15\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x0a\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfc\xff\xfb\xff\xf3\xff\xfa\xff\xf7\xff\xef\xff\xf4\xff\xfd\xff\x00\x00\xf2\xff\xf1\xff\xf0\xff\xf5\xff\xef\xff\xf6\xff\xf8\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\x00\x00\xf9\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x08\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x02\x00\x03\x00\x07\x00\x12\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x05\x00\x14\x00\x15\x00\x06\x00\x08\x00\x07\x00\x13\x00\x13\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x23\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x0f\x00\x10\x00\x22\x00\x11\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x11\x00\x08\x00\x09\x00\x09\x00\x13\x00\x0c\x00\x13\x00\x0b\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 30) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30) + ] + +happy_n_terms = 23 :: Int +happy_n_nonterms = 9 :: Int + +happyReduce_1 = happySpecReduce_0 0# happyReduction_1 +happyReduction_1 = happyIn4 + ([] + ) + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_1 2# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOutTok happy_x_1 of { (StrT happy_var_1) -> + happyIn6 + (StrLit happy_var_1 + )} + +happyReduce_6 = happyReduce 6# 3# happyReduction_6 +happyReduction_6 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut9 happy_x_4 of { happy_var_4 -> + case happyOut11 happy_x_5 of { happy_var_5 -> + case happyOut12 happy_x_6 of { happy_var_6 -> + happyIn7 + (ConvSp happy_var_1 happy_var_2 happy_var_4 happy_var_5 happy_var_6 + ) `HappyStk` happyRest}}}}} + +happyReduce_7 = happyReduce 4# 3# happyReduction_7 +happyReduction_7 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + case happyOut12 happy_x_4 of { happy_var_4 -> + happyIn7 + (ConvSp happy_var_1 happy_var_2 Nothing happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_8 = happySpecReduce_1 4# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOutTok happy_x_1 of { (FlagT happy_var_1) -> + happyIn8 + (mkFlags happy_var_1 + )} + +happyReduce_9 = happySpecReduce_1 5# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOutTok happy_x_1 of { (IntT happy_var_1) -> + happyIn9 + (Just happy_var_1 + )} + +happyReduce_10 = happySpecReduce_0 5# happyReduction_10 +happyReduction_10 = happyIn9 + (Nothing + ) + +happyReduce_11 = happySpecReduce_1 6# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOutTok happy_x_1 of { (IntT happy_var_1) -> + happyIn10 + (Just happy_var_1 + )} + +happyReduce_12 = happySpecReduce_0 6# happyReduction_12 +happyReduction_12 = happyIn10 + (Nothing + ) + +happyReduce_13 = happySpecReduce_1 7# happyReduction_13 +happyReduction_13 happy_x_1 + = happyIn11 + (Short + ) + +happyReduce_14 = happySpecReduce_1 7# happyReduction_14 +happyReduction_14 happy_x_1 + = happyIn11 + (Long + ) + +happyReduce_15 = happySpecReduce_1 7# happyReduction_15 +happyReduction_15 happy_x_1 + = happyIn11 + (Double + ) + +happyReduce_16 = happySpecReduce_0 7# happyReduction_16 +happyReduction_16 = happyIn11 + (Default + ) + +happyReduce_17 = happySpecReduce_1 8# happyReduction_17 +happyReduction_17 happy_x_1 + = happyIn12 + (D + ) + +happyReduce_18 = happySpecReduce_1 8# happyReduction_18 +happyReduction_18 happy_x_1 + = happyIn12 + (D + ) + +happyReduce_19 = happySpecReduce_1 8# happyReduction_19 +happyReduction_19 happy_x_1 + = happyIn12 + (O + ) + +happyReduce_20 = happySpecReduce_1 8# happyReduction_20 +happyReduction_20 happy_x_1 + = happyIn12 + (Xx + ) + +happyReduce_21 = happySpecReduce_1 8# happyReduction_21 +happyReduction_21 happy_x_1 + = happyIn12 + (XX + ) + +happyReduce_22 = happySpecReduce_1 8# happyReduction_22 +happyReduction_22 happy_x_1 + = happyIn12 + (U + ) + +happyReduce_23 = happySpecReduce_1 8# happyReduction_23 +happyReduction_23 happy_x_1 + = happyIn12 + (C + ) + +happyReduce_24 = happySpecReduce_1 8# happyReduction_24 +happyReduction_24 happy_x_1 + = happyIn12 + (S + ) + +happyReduce_25 = happySpecReduce_1 8# happyReduction_25 +happyReduction_25 happy_x_1 + = happyIn12 + (F + ) + +happyReduce_26 = happySpecReduce_1 8# happyReduction_26 +happyReduction_26 happy_x_1 + = happyIn12 + (Ee + ) + +happyReduce_27 = happySpecReduce_1 8# happyReduction_27 +happyReduction_27 happy_x_1 + = happyIn12 + (EE + ) + +happyReduce_28 = happySpecReduce_1 8# happyReduction_28 +happyReduction_28 happy_x_1 + = happyIn12 + (Gg + ) + +happyReduce_29 = happySpecReduce_1 8# happyReduction_29 +happyReduction_29 happy_x_1 + = happyIn12 + (GG + ) + +happyReduce_30 = happySpecReduce_1 8# happyReduction_30 +happyReduction_30 happy_x_1 + = happyIn12 + (Percent + ) + +happyNewToken action sts stk [] = + happyDoAction 22# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + LengthT 'h' -> cont 1#; + LengthT 'l' -> cont 2#; + LengthT 'L' -> cont 3#; + ConvT 'd' -> cont 4#; + ConvT 'i' -> cont 5#; + ConvT 'o' -> cont 6#; + ConvT 'x' -> cont 7#; + ConvT 'X' -> cont 8#; + ConvT 'u' -> cont 9#; + ConvT 'c' -> cont 10#; + ConvT 's' -> cont 11#; + ConvT 'f' -> cont 12#; + ConvT 'e' -> cont 13#; + ConvT 'E' -> cont 14#; + ConvT 'g' -> cont 15#; + ConvT 'G' -> cont 16#; + ConvT '%' -> cont 17#; + DotT -> cont 18#; + IntT happy_dollar_dollar -> cont 19#; + StrT happy_dollar_dollar -> cont 20#; + FlagT happy_dollar_dollar -> cont 21#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + +------------------------------------------------------------------------ +-- +-- abstract syntax for printf format strings +-- +data Format + = StrLit String + | ConvSp { flags :: [Flag], + width :: (Maybe Width), + precision :: (Maybe Prec ), + lenght :: Length, + conv :: Conv } + deriving (Show, Eq) + +type Width = Int +type Prec = Int + +data Flag + = LeftAdjust -- - + | Signed -- + + | Space -- ' ' + | LeadZero -- 0 + | Alt -- # + deriving (Show, Eq) + +data Length + = Short -- h + | Long -- l + | Double -- L + | Default + deriving (Show, Eq) + +data Conv + = D + | O + | Xx | XX + | U + | C + | S + | F + | Ee | EE + | Gg | GG + | Percent + deriving (Show, Eq) + +mkFlags :: [Char] -> [Flag] +mkFlags [] = [] +mkFlags (c:cs) = (case c of + '-' -> LeftAdjust + '+' -> Signed + ' ' -> Space + '0' -> LeadZero + '#' -> Alt) : mkFlags cs + +happyError :: [Token] -> a +happyError [] = error "Parser" "parse error" +happyError tks = error $ "Parser: " ++ show tks +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: Parser.hs,v 1.1 2004/06/28 03:56:01 dons Exp $ + + + + + + + + + + + + + +{-# LINE 27 "GenericTemplate.hs" #-} + + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j + (happyTcHack st)) + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 165 "GenericTemplate.hs" #-} + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/printf/Printf/Parser.y b/src/printf/Printf/Parser.y new file mode 100644 index 0000000..ca6fe13 --- /dev/null +++ b/src/printf/Printf/Parser.y @@ -0,0 +1,174 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program 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 +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- Parser for printf format strings +-- Based on B1.2 Formatted Output, from Kernighan and Ritchie. +-- + +{ + +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +-- ^ grr. happy needs them all on one line + +module Printf.Parser where + +import Printf.Lexer + +} + +%name parse +%tokentype { Token } +%token + + 'h' { LengthT 'h' } + 'l' { LengthT 'l' } + 'L' { LengthT 'L' } + + 'd' { ConvT 'd' } + 'i' { ConvT 'i' } + 'o' { ConvT 'o' } + 'x' { ConvT 'x' } + 'X' { ConvT 'X' } + 'u' { ConvT 'u' } + 'c' { ConvT 'c' } + 's' { ConvT 's' } + 'f' { ConvT 'f' } + 'e' { ConvT 'e' } + 'E' { ConvT 'E' } + 'g' { ConvT 'g' } + 'G' { ConvT 'G' } + '%' { ConvT '%' } + + '.' { DotT } + + INT { IntT $$ } + STRING { StrT $$ } + FLAGS { FlagT $$ } + +%% + +printf :: { [Format] } + : {- epsilon -} { [] } + | format0 printf { $1 : $2 } + +format0 :: { Format } + : string { $1 } + | format { $1 } + +string :: { Format } + : STRING { StrLit $1 } + +format :: { Format } + : flags width '.' precision length conv { ConvSp $1 $2 $4 $5 $6 } + | flags width length conv { ConvSp $1 $2 Nothing $3 $4 } + +flags :: { [Flag] } + : FLAGS { mkFlags $1 } + +precision :: { Maybe Prec } + : INT { Just $1 } + | {- epsilon -} { Nothing } + +width :: { Maybe Width } + : INT { Just $1 } + | {- epsilon -} { Nothing } + +length :: { Length } + : 'h' { Short } + | 'l' { Long } + | 'L' { Double } + | {- epsilon -} { Default} + +conv :: { Conv } + : 'd' { D } + | 'i' { D } -- n.b + | 'o' { O } + | 'x' { Xx } + | 'X' { XX } + | 'u' { U } + | 'c' { C } + | 's' { S } + | 'f' { F } + | 'e' { Ee } + | 'E' { EE } + | 'g' { Gg } + | 'G' { GG } + | '%' { Percent } + +{ + +------------------------------------------------------------------------ +-- +-- abstract syntax for printf format strings +-- +data Format + = StrLit String + | ConvSp { flags :: [Flag], + width :: (Maybe Width), + precision :: (Maybe Prec ), + lenght :: Length, + conv :: Conv } + deriving (Show, Eq) + +type Width = Int +type Prec = Int + +data Flag + = LeftAdjust -- - + | Signed -- + + | Space -- ' ' + | LeadZero -- 0 + | Alt -- # + deriving (Show, Eq) + +data Length + = Short -- h + | Long -- l + | Double -- L + | Default + deriving (Show, Eq) + +data Conv + = D + | O + | Xx | XX + | U + | C + | S + | F + | Ee | EE + | Gg | GG + | Percent + deriving (Show, Eq) + +mkFlags :: [Char] -> [Flag] +mkFlags [] = [] +mkFlags (c:cs) = (case c of + '-' -> LeftAdjust + '+' -> Signed + ' ' -> Space + '0' -> LeadZero + '#' -> Alt) : mkFlags cs + +happyError :: [Token] -> a +happyError [] = error "Parser" "parse error" +happyError tks = error $ "Parser: " ++ show tks + +} diff --git a/src/printf/printf.conf.in.cpp b/src/printf/printf.conf.in.cpp new file mode 100644 index 0000000..9b5b563 --- /dev/null +++ b/src/printf/printf.conf.in.cpp @@ -0,0 +1,54 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "printf", + auto = False, + hs_libraries = [ "HSprintf" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/printf" ], + library_dirs = [ "${TOP}/src/printf" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "eval" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: printf +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: False +exposed-modules: + Printf.Compile, + Printf.Lexer, + Printf.Parser, + Printf + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/printf +library-dirs: TOP/src/printf +#endif +hs-libraries: HSprintf +extra-libraries: +include-dirs: +includes: +depends: eval +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif