diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,5 @@ + +Don Stewart +Sean Seefried +Andre Pang + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /dev/null +++ b/Makefile @@ -0,0 +1,44 @@ +# 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) + +# +# regress check. TODO check expected output +# +check: + @( d=/tmp/plugins.tmp.$$$$ ; mkdir $$d ; export TMPDIR=$$d ;\ + for i in `find testsuite ! -name CVS -type d -maxdepth 2 -mindepth 2 | sort` ; 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 + +clean: + cd docs && $(MAKE) clean + runhaskell Setup.lhs clean 2> /dev/null || true + rm -rf $(CLEAN_FILES) + find testsuite -name '*.a' -exec rm {} \; + find testsuite -name '*~' -exec rm {} \; + find testsuite -name 'a.out' -exec rm {} \; + find testsuite -name '*.hi' -exec rm {} \; + find testsuite -name '*.o' -exec rm {} \; + find testsuite -name '*.core' -exec rm {} \; + find testsuite -name 'package.conf' -exec rm {} \; + rm -f testsuite/makewith/io/TestIO.conf + rm -f testsuite/makewith/unsafeio/Unsafe.conf + rm -rf testsuite/plugs/plugs/plugs + rm -rf testsuite/plugs/plugs/runplugs + rm -rf $(EXTRA_CLEANS) + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,111 @@ + +------------------------------------------------------------------------ + 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. + +------------------------------------------------------------------------ + +BUILDING: + $ chmod +x Setup.lhs configure + $ ./Setup.lhs configure --prefix=/usr/local + $ ./Setup.lhs build + $ ./Setup.lhs install + +------------------------------------------------------------------------ + +DEPENDENCIES: + +* Requires GHC >= 6.4 +* Requires Cabal + +------------------------------------------------------------------------ + +* Optional: + If you are doing a lot of `merge'-related operations, and require + an extended haskell parser, you can compile hs-plugins to use + HSX, Niklas Broberg's Haskell parser library, available at: + + darcs get http://www.cs.chalmers.se/~d00nibro/haskell-src-exts + + To get hs-plugins to use HSX, use: + + $ mv plugins.cabal.hsx plugins.cabal + $ ./Setup.lhs configure --enable-hsx + + Make sure to install HSX first though :) + +------------------------------------------------------------------------ + +* On cygwin/windows you (a) make sure the cygwin "find" is before the + windows "find" on your PATH, and (b) to give the windows-style path + (e.g., "c:/cygwin/usr/local") in the ./configure --prefix=foo/bar + step + +* '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 >= autoreconf-2.53 + +* The documentation relies on haddock, latex, dvips, tex2page: + + $ cd doc && make + +------------------------------------------------------------------------ + +EXAMPLES: + +Have a look in the testsuite/ 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.4 or greater, though most testing has be done on 6.4. +The 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 +powerpc-*-linux | 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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMainWithHooks defaultUserHooks diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,18 @@ +For 1.0 +---------- + ++ hs-plugins doesn't know to look for packages in the user packages, +only in the global packages + ++ version numbers in package loads are annyoing + ++ .hi file parser is broken on Itanium, again. + ++ build way=p and way='' + +Cabal +-------- + +What we'd like is a cabalMake version of make, so rather than just +compiling simple plugins, we let cabalMake rebuild whole Haskell apps -- +like Yi! diff --git a/config.guess b/config.guess new file mode 100644 --- /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 --- /dev/null +++ b/config.h.in @@ -0,0 +1,46 @@ +/* config.h.in. Generated from configure.ac by autoheader. */ + +/* Defined if compiling with mingw */ +#undef CYGWIN + +/* Defined if a debugging version is to be built */ +#undef DEBUG + +/* Path to ghc libraries */ +#undef GHC_LIB_PATH + +/* Define to 1 if you have the `arc4random' function. */ +#undef HAVE_ARC4RANDOM + +/* Whether symbols are prefixed with a leading underscore */ +#undef LEADING_UNDERSCORE + +/* Defined if compiling on the mac */ +#undef MACOSX + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* Path to top of build tree */ +#undef TOP + +/* Which ghc to use */ +#undef WITH_GHC + +/* Defined if hs-plugins is to be built with Niklas Broberg's HSX parser */ +#undef WITH_HSX + +/* Defined if compiling with mingw */ +#undef __MINGW32__ diff --git a/config.mk.in b/config.mk.in new file mode 100644 --- /dev/null +++ b/config.mk.in @@ -0,0 +1,4 @@ +default: all +TOP = @TOP@ +GHC = @GHC@ +GLASGOW_HASKELL = @GLASGOW_HASKELL@ diff --git a/config.sub b/config.sub new file mode 100644 --- /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 b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,3840 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.59. +# +# Copyright (C) 2003 Free Software Foundation, Inc. +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_executable_p="test -f" + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + + +# Name of the host. +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +exec 6>&1 + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_config_libobj_dir=. +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Maximum number of lines to put in a shell here document. +# This variable seems obsolete. It should probably be removed, and +# only ac_max_sed_lines should be used. +: ${ac_max_here_lines=38} + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= + +ac_unique_file="src/System/Plugins.hs" +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS build build_cpu build_vendor build_os PREFIX TOP GHC GLASGOW_HASKELL HASKELL_SRC TEX TEX2PAGE CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA LIBOBJS LTLIBOBJS' +ac_subst_files='' + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +ac_prev= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_option in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + eval "enable_$ac_feature=no" ;; + + -enable-* | --enable-*) + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; + esac + eval "enable_$ac_feature='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package| sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; + esac + eval "with_$ac_package='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/-/_/g'` + eval "with_$ac_package=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` + eval "$ac_envvar='$ac_optarg'" + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute paths. +for ac_var in exec_prefix prefix +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* | NONE | '' ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# Be sure to have absolute paths. +for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ + localstatedir libdir includedir oldincludedir infodir mandir +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_confdir=`(dirname "$0") 2>/dev/null || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 + { (exit 1); exit 1; }; } + else + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } + fi +fi +(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || + { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 + { (exit 1); exit 1; }; } +srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` +ac_env_build_alias_set=${build_alias+set} +ac_env_build_alias_value=$build_alias +ac_cv_env_build_alias_set=${build_alias+set} +ac_cv_env_build_alias_value=$build_alias +ac_env_host_alias_set=${host_alias+set} +ac_env_host_alias_value=$host_alias +ac_cv_env_host_alias_set=${host_alias+set} +ac_cv_env_host_alias_value=$host_alias +ac_env_target_alias_set=${target_alias+set} +ac_env_target_alias_value=$target_alias +ac_cv_env_target_alias_set=${target_alias+set} +ac_cv_env_target_alias_value=$target_alias +ac_env_CC_set=${CC+set} +ac_env_CC_value=$CC +ac_cv_env_CC_set=${CC+set} +ac_cv_env_CC_value=$CC +ac_env_CFLAGS_set=${CFLAGS+set} +ac_env_CFLAGS_value=$CFLAGS +ac_cv_env_CFLAGS_set=${CFLAGS+set} +ac_cv_env_CFLAGS_value=$CFLAGS +ac_env_LDFLAGS_set=${LDFLAGS+set} +ac_env_LDFLAGS_value=$LDFLAGS +ac_cv_env_LDFLAGS_set=${LDFLAGS+set} +ac_cv_env_LDFLAGS_value=$LDFLAGS +ac_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_env_CPPFLAGS_value=$CPPFLAGS +ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_cv_env_CPPFLAGS_value=$CPPFLAGS + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +_ACEOF + + cat <<_ACEOF +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data [PREFIX/share] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --infodir=DIR info documentation [PREFIX/info] + --mandir=DIR man documentation [PREFIX/man] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Features: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-debug Enable a debug version of hs-plugins to be built + --enable-hsx Enable a debug version of hs-plugins to be built + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-ghc= use a specific Haskell compiler + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +_ACEOF +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + ac_popdir=`pwd` + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d $ac_dir || continue + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + cd $ac_dir + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_srcdir/configure.gnu; then + echo + $SHELL $ac_srcdir/configure.gnu --help=recursive + elif test -f $ac_srcdir/configure; then + echo + $SHELL $ac_srcdir/configure --help=recursive + elif test -f $ac_srcdir/configure.ac || + test -f $ac_srcdir/configure.in; then + echo + $ac_configure --help + else + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi + cd $ac_popdir + done +fi + +test -n "$ac_init_help" && exit 0 +if $ac_init_version; then + cat <<\_ACEOF + +Copyright (C) 2003 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit 0 +fi +exec 5>config.log +cat >&5 <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.59. Invocation command line was + + $ $0 $@ + +_ACEOF +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +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 || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +hostinfo = `(hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + echo "PATH: $as_dir" +done + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_sep= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; + 2) + ac_configure_args1="$ac_configure_args1 '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" + # Get rid of the leading space. + ac_sep=" " + ;; + esac + done +done +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Be sure not to use single quotes in there, as some shells, +# such as our DU 5.0 friend, will then `close' the trap. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + echo + # The following way of writing the cache mishandles newlines in values, +{ + (set) 2>&1 | + case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in + *ac_space=\ *) + sed -n \ + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + ;; + *) + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + ;; + esac; +} + echo + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + echo + for ac_var in $ac_subst_vars + do + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" + done | sort + echo + + if test -n "$ac_subst_files"; then + cat <<\_ASBOX +## ------------- ## +## Output files. ## +## ------------- ## +_ASBOX + echo + for ac_var in $ac_subst_files + do + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" + done | sort + echo + fi + + if test -s confdefs.h; then + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + echo + sed "/^$/d" confdefs.h | sort + echo + fi + test "$ac_signal" != 0 && + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core && + rm -rf conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status + ' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo >confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . $cache_file;; + *) . ./$cache_file;; + esac + fi +else + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in `(set) 2>&1 | + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val="\$ac_cv_env_${ac_var}_value" + eval ac_new_val="\$ac_env_${ac_var}_value" + case $ac_old_set,$ac_new_set in + set,) + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + + + + + + + + + + + + + + +# Prepare to generate the config.h.in file + ac_config_headers="$ac_config_headers config.h" + + +# untested on earlier than 2.52, but it won't work anyway + + +# Find out what type of system we're running on +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f $ac_dir/shtool; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&5 +echo "$as_me: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&2;} + { (exit 1); exit 1; }; } +fi +ac_config_guess="$SHELL $ac_aux_dir/config.guess" +ac_config_sub="$SHELL $ac_aux_dir/config.sub" +ac_configure="$SHELL $ac_aux_dir/configure" # This should be Cygnus configure. + +# Make sure we can run config.sub. +$ac_config_sub sun4 >/dev/null 2>&1 || + { { echo "$as_me:$LINENO: error: cannot run $ac_config_sub" >&5 +echo "$as_me: error: cannot run $ac_config_sub" >&2;} + { (exit 1); exit 1; }; } + +echo "$as_me:$LINENO: checking build system type" >&5 +echo $ECHO_N "checking build system type... $ECHO_C" >&6 +if test "${ac_cv_build+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_build_alias=$build_alias +test -z "$ac_cv_build_alias" && + ac_cv_build_alias=`$ac_config_guess` +test -z "$ac_cv_build_alias" && + { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 +echo "$as_me: error: cannot guess build type; you must specify one" >&2;} + { (exit 1); exit 1; }; } +ac_cv_build=`$ac_config_sub $ac_cv_build_alias` || + { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_build_alias failed" >&5 +echo "$as_me: error: $ac_config_sub $ac_cv_build_alias failed" >&2;} + { (exit 1); exit 1; }; } + +fi +echo "$as_me:$LINENO: result: $ac_cv_build" >&5 +echo "${ECHO_T}$ac_cv_build" >&6 +build=$ac_cv_build +build_cpu=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +build_vendor=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +build_os=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + + + +Platform="$build_cpu-$build_vendor-$build_os" + +# This isn't right for msys mingw. +PREFIX="$prefix" +if test "$prefix" = "NONE" +then + if test "$build_os" = "cygwin" + then + PREFIX="c:/cygwin$ac_default_prefix" + else + PREFIX="$ac_default_prefix" + fi +fi + + +case $Platform in +powerpc-apple-darwin*) + MACOSX=yes + +cat >>confdefs.h <<_ACEOF +#define MACOSX 1 +_ACEOF + + LEADING_UNDERSCORE=1 + ;; +*) + MACOSX=no + LEADING_UNDERSCORE=0 + ;; +esac + +if test "$build_os" = "mingw32" +then + +cat >>confdefs.h <<\_ACEOF +#define __MINGW32__ 1 +_ACEOF + + LEADING_UNDERSCORE=1 +fi + +if test "$build_os" = "cygwin" +then + +cat >>confdefs.h <<\_ACEOF +#define CYGWIN 1 +_ACEOF + + LEADING_UNDERSCORE=1 +fi + + +cat >>confdefs.h <<_ACEOF +#define LEADING_UNDERSCORE $LEADING_UNDERSCORE +_ACEOF + + +# Find pwd, in a cygwin friendly way. +# Suggested by: http://www.haskell.org/ghc/docs/latest/html/users_guide/ch11s04.html +TOP=`echo "Directory.getCurrentDirectory >>= putStrLn.init.tail.show " | ghc --interactive -ignore-dot-ghci -v0` + + +cat >>confdefs.h <<_ACEOF +#define TOP "$TOP" +_ACEOF + + + +# necessary tools + +# allow user supplied haskell compiler + +# Check whether --with-ghc or --without-ghc was given. +if test "${with_ghc+set}" = set; then + withval="$with_ghc" + GHC="$withval" + if test ! -f "$GHC" ; then + { { echo "$as_me:$LINENO: error: $GHC not found. You need GHC to build this project" >&5 +echo "$as_me: error: $GHC not found. You need GHC to build this project" >&2;} + { (exit 1); exit 1; }; } + fi + +else + # Extract the first word of "ghc", so it can be a program name with args. +set dummy ghc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_GHC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$GHC"; then + ac_cv_prog_GHC="$GHC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_GHC="ghc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +GHC=$ac_cv_prog_GHC +if test -n "$GHC"; then + echo "$as_me:$LINENO: result: $GHC" >&5 +echo "${ECHO_T}$GHC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + if test -z "$GHC" ; then + { { echo "$as_me:$LINENO: error: You need GHC to build this project" >&5 +echo "$as_me: error: You need GHC to build this project" >&2;} + { (exit 1); exit 1; }; } + fi + + +fi; + +cat >>confdefs.h <<_ACEOF +#define WITH_GHC "$GHC" +_ACEOF + + + +# Work out value of __GLASGOW_HASKELL__ +if test -n "$GHC" ; then + echo "$as_me:$LINENO: checking for value of __GLASGOW_HASKELL__" >&5 +echo $ECHO_N "checking for value of __GLASGOW_HASKELL__... $ECHO_C" >&6 + echo "main = print __GLASGOW_HASKELL__" > t.hs + GLASGOW_HASKELL=`echo 'main' | "$GHC" --interactive -ignore-dot-ghci -v0 -cpp t.hs` + rm t.hs + echo "$as_me:$LINENO: result: $GLASGOW_HASKELL" >&5 +echo "${ECHO_T}$GLASGOW_HASKELL" >&6 +fi + + +# find path to GHC libs, for runtime_loader +if test -n "$GHC" ; then + echo "$as_me:$LINENO: checking for ghc library directory" >&5 +echo $ECHO_N "checking for ghc library directory... $ECHO_C" >&6 + GHC_LIB_PATH=`$GHC --print-libdir` + echo "$as_me:$LINENO: result: $GHC_LIB_PATH" >&5 +echo "${ECHO_T}$GHC_LIB_PATH" >&6 +fi + +cat >>confdefs.h <<_ACEOF +#define GHC_LIB_PATH "$GHC_LIB_PATH" +_ACEOF + + +# Allow a debugging version of hs-plugins to be built +# Check whether --enable-debug or --disable-debug was given. +if test "${enable_debug+set}" = set; then + enableval="$enable_debug" + + +cat >>confdefs.h <<_ACEOF +#define DEBUG 1 +_ACEOF + +else + : +fi; + +# Allow a debugging version of hs-plugins to be built +# Check whether --enable-hsx or --disable-hsx was given. +if test "${enable_hsx+set}" = set; then + enableval="$enable_hsx" + HASKELL_SRC=haskell-src-exts ; + +cat >>confdefs.h <<_ACEOF +#define WITH_HSX 1 +_ACEOF + +else + HASKELL_SRC=haskell-src +fi; + + + +# Extract the first word of "tex", so it can be a program name with args. +set dummy tex; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_TEX+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$TEX"; then + ac_cv_prog_TEX="$TEX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_TEX="tex" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +TEX=$ac_cv_prog_TEX +if test -n "$TEX"; then + echo "$as_me:$LINENO: result: $TEX" >&5 +echo "${ECHO_T}$TEX" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +if test -z "$TEX" ; then + { echo "$as_me:$LINENO: WARNING: tex is needed to build some of the documentation" >&5 +echo "$as_me: WARNING: tex is needed to build some of the documentation" >&2;} +fi +# Extract the first word of "tex2page", so it can be a program name with args. +set dummy tex2page; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_TEX2PAGE+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$TEX2PAGE"; then + ac_cv_prog_TEX2PAGE="$TEX2PAGE" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_TEX2PAGE="tex2page" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +TEX2PAGE=$ac_cv_prog_TEX2PAGE +if test -n "$TEX2PAGE"; then + echo "$as_me:$LINENO: result: $TEX2PAGE" >&5 +echo "${ECHO_T}$TEX2PAGE" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +if test -z "$TEX2PAGE" ; then + { echo "$as_me:$LINENO: WARNING: tex2page is needed to build some of the documentation + http://www.ccs.neu.edu/home/dorai/tex2page/tex2page-doc.html" >&5 +echo "$as_me: WARNING: tex2page is needed to build some of the documentation + http://www.ccs.neu.edu/home/dorai/tex2page/tex2page-doc.html" >&2;} +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + test -n "$ac_ct_CC" && break +done + + CC=$ac_ct_CC +fi + +fi + + +test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&5 +echo "$as_me: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + +# Provide some information about the compiler. +echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 +ac_compiler=`set X $ac_compile; echo $2` +{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 +ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` +if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is +# not robust to junk in `.', hence go to wildcards (a.*) only as a last +# resort. + +# Be careful to initialize this variable, since it used to be cached. +# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. +ac_cv_exeext= +# b.out is created by i960 compilers. +for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; + * ) + break;; + esac +done +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: C compiler cannot create executables +See \`config.log' for more details." >&5 +echo "$as_me: error: C compiler cannot create executables +See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; } +fi + +ac_exeext=$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_file" >&5 +echo "${ECHO_T}$ac_file" >&6 + +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether the C compiler works" >&5 +echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 +# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 +# If not cross compiling, check that we can run a simple program. +if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + fi + fi +fi +echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + +rm -f a.out a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 +echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 +echo "$as_me:$LINENO: result: $cross_compiling" >&5 +echo "${ECHO_T}$cross_compiling" >&6 + +echo "$as_me:$LINENO: checking for suffix of executables" >&5 +echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext + break;; + * ) break;; + esac +done +else + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +echo "${ECHO_T}$ac_cv_exeext" >&6 + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +echo "$as_me:$LINENO: checking for suffix of object files" >&5 +echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 +if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +echo "${ECHO_T}$ac_cv_objext" >&6 +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 +if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_compiler_gnu=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_compiler_gnu=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 +GCC=`test $ac_compiler_gnu = yes && echo yes` +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +CFLAGS="-g" +echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_prog_cc_g=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 +echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_prog_cc_stdc=no +ac_save_CC=$CC +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +# Don't try gcc -ansi; that turns off useful extensions and +# breaks some systems' header files. +# AIX -qlanglvl=ansi +# Ultrix and OSF/1 -std1 +# HP-UX 10.20 and later -Ae +# HP-UX older versions -Aa -D_HPUX_SOURCE +# SVR4 -Xc -D__EXTENSIONS__ +for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg +break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext +done +rm -f conftest.$ac_ext conftest.$ac_objext +CC=$ac_save_CC + +fi + +case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 +echo "${ECHO_T}none needed" >&6 ;; + *) + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; +esac + +# Some people use a C++ compiler to compile C. Since we use `exit', +# in C++ we need to declare it. In case someone uses the same compiler +# for both compiling C and C++ we need to have the C++ compiler decide +# the declaration of exit, since it's the most demanding environment. +cat >conftest.$ac_ext <<_ACEOF +#ifndef __cplusplus + choke me +#endif +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' +do + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +#include +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +continue +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest* +if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h +fi + +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +for ac_func in arc4random +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AmigaOS /C/install, which installs bootblocks on floppy discs +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# OS/2's system install, which has a completely different semantic +# ./install, which can be erroneously created by make from ./install.sh. +echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 +echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6 +if test -z "$INSTALL"; then +if test "${ac_cv_path_install+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + # Account for people who put trailing slashes in PATH elements. +case $as_dir/ in + ./ | .// | /cC/* | \ + /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ + ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ + /usr/ucb/* ) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then + if test $ac_prog = install && + grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + elif test $ac_prog = install && + grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # program-specific install script used by HP pwplus--don't use. + : + else + ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" + break 3 + fi + fi + done + done + ;; +esac +done + + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL=$ac_cv_path_install + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL=$ac_install_sh + fi +fi +echo "$as_me:$LINENO: result: $INSTALL" >&5 +echo "${ECHO_T}$INSTALL" >&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + +# System.Process uses cmd or command.com shell on Windows, doen't use Cygwin or MSYS shell + ac_config_files="$ac_config_files config.mk testsuite/makewith/io/TestIO.conf testsuite/makewith/unsafeio/Unsafe.conf" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +{ + (set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + ;; + esac; +} | + sed ' + t clear + : clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + : end' >>confcache +if diff $cache_file confcache >/dev/null 2>&1; then :; else + if test -w $cache_file; then + test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" + cat confcache >$cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/; +s/:*\${srcdir}:*/:/; +s/:*@srcdir@:*/:/; +s/^\([^=]*=[ ]*\):*/\1/; +s/:*$//; +s/^[^=]*=[ ]*$//; +}' +fi + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_i=`echo "$ac_i" | + sed 's/\$U\././;s/\.o$//;s/\.obj$//'` + # 2. Add them. + ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" + ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: ${CONFIG_STATUS=./config.status} +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false +SHELL=\${CONFIG_SHELL-$SHELL} +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 +echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 +echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_executable_p="test -f" + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + +exec 6>&1 + +# Open the log real soon, to keep \$[0] and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. Logging --version etc. is OK. +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX +} >&5 +cat >&5 <<_CSEOF + +This file was extended by $as_me, which was +generated by GNU Autoconf 2.59. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +_CSEOF +echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 +echo >&5 +_ACEOF + +# Files that config.status was made for. +if test -n "$ac_config_files"; then + echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_headers"; then + echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_links"; then + echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_commands"; then + echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS +fi + +cat >>$CONFIG_STATUS <<\_ACEOF + +ac_cs_usage="\ +\`$as_me' instantiates files from templates according to the +current configuration. + +Usage: $0 [OPTIONS] [FILE]... + + -h, --help print this help, then exit + -V, --version print version number, then exit + -q, --quiet do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to ." +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.59, + with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" + +Copyright (C) 2003 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." +srcdir=$srcdir +INSTALL="$INSTALL" +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=*) + ac_option=`expr "x$1" : 'x\([^=]*\)='` + ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` + ac_shift=: + ;; + -*) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + *) # This is not an option, so the user has probably given explicit + # arguments. + ac_option=$1 + ac_need_defaults=false;; + esac + + case $ac_option in + # Handling of the options. +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --vers* | -V ) + echo "$ac_cs_version"; exit 0 ;; + --he | --h) + # Conflict between --help and --header + { { echo "$as_me:$LINENO: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit 0 ;; + --debug | --d* | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + CONFIG_FILES="$CONFIG_FILES $ac_optarg" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; } ;; + + *) ac_config_targets="$ac_config_targets $1" ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +if \$ac_cs_recheck; then + echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion +fi + +_ACEOF + + + + + +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_config_target in $ac_config_targets +do + case "$ac_config_target" in + # Handling of arguments. + "config.mk" ) CONFIG_FILES="$CONFIG_FILES config.mk" ;; + "testsuite/makewith/io/TestIO.conf" ) CONFIG_FILES="$CONFIG_FILES testsuite/makewith/io/TestIO.conf" ;; + "testsuite/makewith/unsafeio/Unsafe.conf" ) CONFIG_FILES="$CONFIG_FILES testsuite/makewith/unsafeio/Unsafe.conf" ;; + "config.h" ) CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; + esac +done + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason to put it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Create a temporary directory, and hook for its removal unless debugging. +$debug || +{ + trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 +} + +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./confstat$$-$RANDOM + (umask 077 && mkdir $tmp) +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF + +# +# CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "\$CONFIG_FILES"; then + # Protect against being on the right side of a sed subst in config.status. + sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; + s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF +s,@SHELL@,$SHELL,;t t +s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t +s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t +s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t +s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t +s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t +s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t +s,@exec_prefix@,$exec_prefix,;t t +s,@prefix@,$prefix,;t t +s,@program_transform_name@,$program_transform_name,;t t +s,@bindir@,$bindir,;t t +s,@sbindir@,$sbindir,;t t +s,@libexecdir@,$libexecdir,;t t +s,@datadir@,$datadir,;t t +s,@sysconfdir@,$sysconfdir,;t t +s,@sharedstatedir@,$sharedstatedir,;t t +s,@localstatedir@,$localstatedir,;t t +s,@libdir@,$libdir,;t t +s,@includedir@,$includedir,;t t +s,@oldincludedir@,$oldincludedir,;t t +s,@infodir@,$infodir,;t t +s,@mandir@,$mandir,;t t +s,@build_alias@,$build_alias,;t t +s,@host_alias@,$host_alias,;t t +s,@target_alias@,$target_alias,;t t +s,@DEFS@,$DEFS,;t t +s,@ECHO_C@,$ECHO_C,;t t +s,@ECHO_N@,$ECHO_N,;t t +s,@ECHO_T@,$ECHO_T,;t t +s,@LIBS@,$LIBS,;t t +s,@build@,$build,;t t +s,@build_cpu@,$build_cpu,;t t +s,@build_vendor@,$build_vendor,;t t +s,@build_os@,$build_os,;t t +s,@PREFIX@,$PREFIX,;t t +s,@TOP@,$TOP,;t t +s,@GHC@,$GHC,;t t +s,@GLASGOW_HASKELL@,$GLASGOW_HASKELL,;t t +s,@HASKELL_SRC@,$HASKELL_SRC,;t t +s,@TEX@,$TEX,;t t +s,@TEX2PAGE@,$TEX2PAGE,;t t +s,@CC@,$CC,;t t +s,@CFLAGS@,$CFLAGS,;t t +s,@LDFLAGS@,$LDFLAGS,;t t +s,@CPPFLAGS@,$CPPFLAGS,;t t +s,@ac_ct_CC@,$ac_ct_CC,;t t +s,@EXEEXT@,$EXEEXT,;t t +s,@OBJEXT@,$OBJEXT,;t t +s,@INSTALL_PROGRAM@,$INSTALL_PROGRAM,;t t +s,@INSTALL_SCRIPT@,$INSTALL_SCRIPT,;t t +s,@INSTALL_DATA@,$INSTALL_DATA,;t t +s,@LIBOBJS@,$LIBOBJS,;t t +s,@LTLIBOBJS@,$LTLIBOBJS,;t t +CEOF + +_ACEOF + + cat >>$CONFIG_STATUS <<\_ACEOF + # Split the substitutions into bite-sized pieces for seds with + # small command number limits, like on Digital OSF/1 and HP-UX. + ac_max_sed_lines=48 + ac_sed_frag=1 # Number of current file. + ac_beg=1 # First line for current file. + ac_end=$ac_max_sed_lines # Line after last line for current file. + ac_more_lines=: + ac_sed_cmds= + while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + else + sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + fi + if test ! -s $tmp/subs.frag; then + ac_more_lines=false + else + # The purpose of the label and of the branching condition is to + # speed up the sed processing (if there are no `@' at all, there + # is no need to browse any of the substitutions). + # These are the two extra sed commands mentioned above. + (echo ':t + /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + else + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + fi + ac_sed_frag=`expr $ac_sed_frag + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_lines` + fi + done + if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat + fi +fi # test -n "$CONFIG_FILES" + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. + ac_dir=`(dirname "$ac_file") 2>/dev/null || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + case $INSTALL in + [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; + *) ac_INSTALL=$ac_top_builddir$INSTALL ;; + esac + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +s,@INSTALL@,$ac_INSTALL,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + +done +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + +# +# CONFIG_HEADER section. +# + +# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where +# NAME is the cpp macro being defined and VALUE is the value it is being given. +# +# ac_d sets the value in "#define NAME VALUE" lines. +ac_dA='s,^\([ ]*\)#\([ ]*define[ ][ ]*\)' +ac_dB='[ ].*$,\1#\2' +ac_dC=' ' +ac_dD=',;t' +# ac_u turns "#undef NAME" without trailing blanks into "#define NAME VALUE". +ac_uA='s,^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_uB='$,\1#\2define\3' +ac_uC=' ' +ac_uD=',;t' + +for ac_file in : $CONFIG_HEADERS; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + test x"$ac_file" != x- && { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + # Do quote $f, to prevent DOS paths from being IFS'd. + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } + # Remove the trailing spaces. + sed 's/[ ]*$//' $ac_file_inputs >$tmp/in + +_ACEOF + +# Transform confdefs.h into two sed scripts, `conftest.defines' and +# `conftest.undefs', that substitutes the proper values into +# config.h.in to produce config.h. The first handles `#define' +# templates, and the second `#undef' templates. +# And first: Protect against being on the right side of a sed subst in +# config.status. Protect against being in an unquoted here document +# in config.status. +rm -f conftest.defines conftest.undefs +# Using a here document instead of a string reduces the quoting nightmare. +# Putting comments in sed scripts is not portable. +# +# `end' is used to avoid that the second main sed command (meant for +# 0-ary CPP macros) applies to n-ary macro definitions. +# See the Autoconf documentation for `clear'. +cat >confdef2sed.sed <<\_ACEOF +s/[\\&,]/\\&/g +s,[\\$`],\\&,g +t clear +: clear +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*\)\(([^)]*)\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1\2${ac_dC}\3${ac_dD},gp +t end +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD},gp +: end +_ACEOF +# If some macros were called several times there might be several times +# the same #defines, which is useless. Nevertheless, we may not want to +# sort them, since we want the *last* AC-DEFINE to be honored. +uniq confdefs.h | sed -n -f confdef2sed.sed >conftest.defines +sed 's/ac_d/ac_u/g' conftest.defines >conftest.undefs +rm -f confdef2sed.sed + +# This sed command replaces #undef with comments. This is necessary, for +# example, in the case of _POSIX_SOURCE, which is predefined and required +# on some systems where configure will not decide to define it. +cat >>conftest.undefs <<\_ACEOF +s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */, +_ACEOF + +# Break up conftest.defines because some shells have a limit on the size +# of here documents, and old seds have small limits too (100 cmds). +echo ' # Handle all the #define templates only if necessary.' >>$CONFIG_STATUS +echo ' if grep "^[ ]*#[ ]*define" $tmp/in >/dev/null; then' >>$CONFIG_STATUS +echo ' # If there are no defines, we may have an empty if/fi' >>$CONFIG_STATUS +echo ' :' >>$CONFIG_STATUS +rm -f conftest.tail +while grep . conftest.defines >/dev/null +do + # Write a limited-size here document to $tmp/defines.sed. + echo ' cat >$tmp/defines.sed <>$CONFIG_STATUS + # Speed up: don't consider the non `#define' lines. + echo '/^[ ]*#[ ]*define/!b' >>$CONFIG_STATUS + # Work around the forget-to-reset-the-flag bug. + echo 't clr' >>$CONFIG_STATUS + echo ': clr' >>$CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.defines >>$CONFIG_STATUS + echo 'CEOF + sed -f $tmp/defines.sed $tmp/in >$tmp/out + rm -f $tmp/in + mv $tmp/out $tmp/in +' >>$CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.defines >conftest.tail + rm -f conftest.defines + mv conftest.tail conftest.defines +done +rm -f conftest.defines +echo ' fi # grep' >>$CONFIG_STATUS +echo >>$CONFIG_STATUS + +# Break up conftest.undefs because some shells have a limit on the size +# of here documents, and old seds have small limits too (100 cmds). +echo ' # Handle all the #undef templates' >>$CONFIG_STATUS +rm -f conftest.tail +while grep . conftest.undefs >/dev/null +do + # Write a limited-size here document to $tmp/undefs.sed. + echo ' cat >$tmp/undefs.sed <>$CONFIG_STATUS + # Speed up: don't consider the non `#undef' + echo '/^[ ]*#[ ]*undef/!b' >>$CONFIG_STATUS + # Work around the forget-to-reset-the-flag bug. + echo 't clr' >>$CONFIG_STATUS + echo ': clr' >>$CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.undefs >>$CONFIG_STATUS + echo 'CEOF + sed -f $tmp/undefs.sed $tmp/in >$tmp/out + rm -f $tmp/in + mv $tmp/out $tmp/in +' >>$CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.undefs >conftest.tail + rm -f conftest.undefs + mv conftest.tail conftest.undefs +done +rm -f conftest.undefs + +cat >>$CONFIG_STATUS <<\_ACEOF + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + echo "/* Generated by configure. */" >$tmp/config.h + else + echo "/* $ac_file. Generated by configure. */" >$tmp/config.h + fi + cat $tmp/in >>$tmp/config.h + rm -f $tmp/in + if test x"$ac_file" != x-; then + if diff $ac_file $tmp/config.h >/dev/null 2>&1; then + { echo "$as_me:$LINENO: $ac_file is unchanged" >&5 +echo "$as_me: $ac_file is unchanged" >&6;} + else + ac_dir=`(dirname "$ac_file") 2>/dev/null || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + rm -f $ac_file + mv $tmp/config.h $ac_file + fi + else + cat $tmp/config.h + rm -f $tmp/config.h + fi +done +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || { (exit 1); exit 1; } +fi + + diff --git a/configure.ac b/configure.ac new file mode 100644 --- /dev/null +++ b/configure.ac @@ -0,0 +1,142 @@ +# +# 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) +# + +# SUBSTs go into config.mk.in (TOP,PREFIX,GHC,INSTAlL) +# AC_DEFINES go into config.h +# only AC_DEFINES are visible in Haskell src + +# sanity test +AC_INIT(src/System/Plugins.hs) + +# Prepare to generate the config.h.in file +AC_CONFIG_HEADERS([config.h]) + +# 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 + +Platform="$build_cpu-$build_vendor-$build_os" + +# This isn't right for msys mingw. +PREFIX="$prefix" +if test "$prefix" = "NONE" +then + if test "$build_os" = "cygwin" + then + PREFIX="c:/cygwin$ac_default_prefix" + else + PREFIX="$ac_default_prefix" + fi +fi +AC_SUBST(PREFIX) + +case $Platform in +powerpc-apple-darwin*) + MACOSX=yes + AC_DEFINE_UNQUOTED(MACOSX, [1], [Defined if compiling on the mac]) + LEADING_UNDERSCORE=1 + ;; +*) + MACOSX=no + LEADING_UNDERSCORE=0 + ;; +esac + +if test "$build_os" = "mingw32" +then + AC_DEFINE(__MINGW32__,[1],[Defined if compiling with mingw]) + LEADING_UNDERSCORE=1 +fi + +if test "$build_os" = "cygwin" +then + AC_DEFINE(CYGWIN,[1],[Defined if compiling with mingw]) + LEADING_UNDERSCORE=1 +fi + +AC_DEFINE_UNQUOTED(LEADING_UNDERSCORE, $LEADING_UNDERSCORE, + [Whether symbols are prefixed with a leading underscore]) + +# Find pwd, in a cygwin friendly way. +# Suggested by: http://www.haskell.org/ghc/docs/latest/html/users_guide/ch11s04.html +TOP=`echo "Directory.getCurrentDirectory >>= putStrLn.init.tail.show " | ghc --interactive -ignore-dot-ghci -v0` + +AC_DEFINE_UNQUOTED(TOP, "$TOP", [Path to top of build tree]) +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_DEFINE_UNQUOTED(WITH_GHC, "$GHC", [Which ghc to use]) +AC_SUBST(GHC) + +# 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 -ignore-dot-ghci -v0 -cpp t.hs` + rm t.hs + AC_MSG_RESULT([$GLASGOW_HASKELL]) +fi +AC_SUBST(GLASGOW_HASKELL) + +# 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_DEFINE_UNQUOTED(GHC_LIB_PATH, "$GHC_LIB_PATH", [Path to ghc libraries]) + +# 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], + [ + AC_DEFINE_UNQUOTED(DEBUG, [1], [Defined if a debugging version is to be built]) ], + [ : ]) + +# Allow a debugging version of hs-plugins to be built +AC_ARG_ENABLE(hsx, + [ --enable-hsx Enable a debug version of hs-plugins to be built], + [ HASKELL_SRC=haskell-src-exts ; + AC_DEFINE_UNQUOTED(WITH_HSX, [1], + [Defined if hs-plugins is to be built with Niklas Broberg's HSX parser]) ], + [ HASKELL_SRC=haskell-src ]) + +AC_SUBST(HASKELL_SRC) + +AC_CHECK_PROG(TEX,tex,tex) +if test -z "$TEX" ; then + AC_MSG_WARN(tex is needed to build some of the documentation) +fi +AC_CHECK_PROG(TEX2PAGE,tex2page,tex2page) +if test -z "$TEX2PAGE" ; then + AC_MSG_WARN(tex2page is needed to build some of the documentation + http://www.ccs.neu.edu/home/dorai/tex2page/tex2page-doc.html) +fi + +AC_CHECK_FUNCS(arc4random) + +AC_PROG_INSTALL + +# System.Process uses cmd or command.com shell on Windows, doen't use Cygwin or MSYS shell +AC_CONFIG_FILES([config.mk testsuite/makewith/io/TestIO.conf testsuite/makewith/unsafeio/Unsafe.conf]) +AC_OUTPUT + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 --- /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) + sed -f 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 --- /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 --- /dev/null +++ b/docs/hs-plugins.1 @@ -0,0 +1,36 @@ +.TH HS-PLUGINS 1 2005-12-27 "hs-plugins version 1.0" "User Manual" + +.SH NAME +hs-plugins \- dynamic linker library for Haskell + +.SH DESCRIPTION +.ds c \fIhs-plugins\fP +\*c is a library for loading code written in Haskell into an +application at runtime, in the form of plugins. It also provides a +mechanism for (re-)compiling Haskell source at runtime. Thirdly, a +combination of runtime compilation and dynamic loading provides a set +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.4 or later. + +.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 2003-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 --- /dev/null +++ b/docs/hs-plugins.hdir @@ -0,0 +1,1 @@ +hs-plugins diff --git a/docs/hs-plugins.tex b/docs/hs-plugins.tex new file mode 100644 --- /dev/null +++ b/docs/hs-plugins.tex @@ -0,0 +1,1804 @@ +\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-1.0.tar.gz} + {version 1.0}} +% +\medskip + +\hsplugins{} is a library for loading code written in Haskell into an +application at runtime, in the form of plugins. It also provides a +mechanism for (re-)compiling Haskell source at runtime. Thirdly, a +combination of runtime compilation and dynamic loading provides a set of +\code{eval} functions-- a form of runtime metaprogramming. Values +exported by Haskell plugins are transparently available to Haskell host +applications, and bindings exist to use Haskell dynamically in C, Perl +and Objective C programs. \hsplugins{} requires GHC 6.4 or later. + +\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-1.0.tar.gz} + +\item +Darcs repository of the latest code:\\ +\url{darcs get http://www.cse.unsw.edu.au/~dons/code/hs-plugins} + +\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 +Papers: +\begin{itemize} +\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/papers/PSSC04.html} + +\item +A paper on dynamic applications in Haskell, utilizing \hsplugins{}:\\ +\url{http://www.cse.unsw.edu.au/~dons/papers/SC05.html} +\end{itemize} + +\end{itemize} + +It is known to run on \code{i386-\{linux,freebsd,openbsd\}}, +\code{sparc-solaris2}, \code{powerpc-\{macosx,linux\}} and flavours of +Windows. + +\section{History} + +\begin{itemize} + \item Jan 2006, v1.0 + \begin{itemize} + \item Cabalised build system + \item Behave better on 64 bit platforms + \item Haddock documentation of the API. + \item A couple of bug fixes + \end{itemize} + + \item June 2005, v0.9.10 + \begin{itemize} + \item Support for GHC 6.4, with help from Sean + Seefried for the package.conf parser. + \item Ported to Windows of various flavours thanks to Vivian McPhail and Shelarcy + \item Removed posix and unix dependencies + \item Now uses HSX parser, thanks to Niklas Broberg + \item Extended load interface, thanks to Lemmih + \item Source now in a darcs repository + \item Supports building with GNU make -jN + \item Simplified module hierarchy, moved under System.* namespace + \item pdynload clarifications, thanks to Alistair Bayley + \item Miscellaneous bug fixes + \end{itemize} + + \item February 2005, 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 September 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 Haskell code (which may +be spread over multiple modules), and have an application (implemented in +any language with a Haskell FFI binding, including Haskell) load and use +your code at runtime. + +\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 runtime system's dynamic linker, 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 a +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. 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}. + +The \emph{evaluator}, \code{eval}, utilizes the loader and compilation +manager. When passed a string containing a Haskell expression, 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, and can be +used to embed Haskell evaluation facilities in an application. + +\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{ +import System.Plugins + +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}. + +\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. + +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). + +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) +} + +\scm{ +pdynload_ :: FilePath + -> [FilePath] + -> [PackageConf] + -> [Arg] + -> 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. + +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. + +The type of the plugin's resource field must be equivalent to the +\code{Type}. There are some restrictions on the arguments that may be +passed to pdynload. Currently, we require: + \begin{itemize} + \item The object name has the suffix (.o) removed and this + becomes a qualified module name in the generated type-checker + input file. + + \item The type name must be a single fully-qualified + type-identifier, as the module name is stripped off (i.e. + everything up to the last ".") and used as a qualified import. + This means that you can't use, for example, \code{"Int -> + String"} as a type (type synonyms are fine, though). + +\end{itemize} + +For example, \code{pdynload "API2.o" ["./"] [] "API.PluginAPI" +"doAction"} generates: + +\begin{quote} +\scm{ +module where +import qualified API -- comes from API.PluginAPI argument +import qualified API2 -- comes from API2.o argument +_ = API2.doAction :: API.PluginAPI +} +\end{quote} + +\begin{quote} +\scm{ +unload :: Module -> IO () +} + +\scm{ +unloadAll :: Module -> IO () +} +\end{quote} + +Unload an object, \emph{but not its dependencies} from the address +space. \code{unloadAll} performs cascading unloading of a module +\emph{and} its dependencies. + +\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-0.1" +} +\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{ +import System.Plugins + +make :: FilePath + -> [Arg] + -> IO MakeStatus + +makeAll :: FilePath + -> [Arg] + -> IO MakeStatus + +recompileAll :: Module + -> [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. + +\code{recompileAll} is like \code{makeAll}, but rather than relying on +\code{ghc --make}, we explicitly check a module's dependencies. + +\begin{quote} +\scm{ +merge :: FilePath -> FilePath -> IO MergeStatus + +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus + +mergeToDir :: 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. The merging +operation uses the HSX parser library to parse Haskell source files. + +\code{mergeTo} behaves like \code{merge}, but we can specify the file in +which to place output. \code{mergeToDir} lets you specify a directory in +which to place merged files. + +\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. + +\begin{quote} +\scm{ +hasChanged :: Module -> IO Bool +} +\end{quote} + +\code{hasChanged} returns \code{True} if the module or any of its +dependencies have older object files than source files. Defaults to +\code{True} if some files couldn't be located. + +\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. 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 a runtime metaprogramming +\code{run} operator for closed code fragments. + +\subsection*{Interface} + +\begin{quote} +\scm{ +import System.Eval.Haskell + +eval :: Typeable a => String -> [Import] -> IO (Maybe a) + +eval_ :: Typeable a => + String -- code to compile + -> [Import] -- any imports + -> [String] -- extra ghc flags + -> [FilePath] -- extra package.conf files + -> [FilePath] -- include search paths + -> IO (Either [String] (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, or did not typecheck at its splice point. \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}. As usual, \code{eval\_} is a +version of \code{eval} that lets you pass extra flags to ghc and to the +dynamic loader. + +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 System.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 System.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 System.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{Utilities for use with eval} +\code{hs-plugins} proves the following utilities for use with \code{eval}: +\begin{itemize} +\item +\code{mkHsValues} is a helper function for converting \code{Data.Map}s +of names and values into Haskell code. It relies on the assumption +that the passed values' Show instances produce valid Haskell +literals (this is true for all prelude types). It's type is as follows: +\begin{quote} +\scm{ +mkHsValues :: (Show a) => Data.Map String a -> String +} +\end{quote} +\end{itemize} +% \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} +% + +\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. 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 System.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 System.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 2003-5, 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 main issue is a 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). + +\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 System.Eval.Haskell +import System.Plugins + +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 --- /dev/null +++ b/docs/munge.sed @@ -0,0 +1,16 @@ + +# 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 --- /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 --- /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/install.sh b/install.sh new file mode 100644 --- /dev/null +++ b/install.sh diff --git a/plugins.cabal b/plugins.cabal new file mode 100644 --- /dev/null +++ b/plugins.cabal @@ -0,0 +1,38 @@ +name: plugins +version: 1.0 +license: LGPL +License-file: LICENSE +author: Don Stewart +maintainer: dons@cse.unsw.edu.au +exposed-modules: + AltData.Dynamic, + AltData.Typeable, + Language.Hi.Binary, + Language.Hi.FastMutInt, + Language.Hi.FastString, + Language.Hi.Parser, + Language.Hi.PrimPacked, + Language.Hi.Syntax, + System.Eval, + System.Eval.Haskell, + System.Eval.Utils, + System.MkTemp, + System.Plugins, + System.Plugins.Consts, + System.Plugins.Env, + System.Plugins.Load, + System.Plugins.LoadTypes, + System.Plugins.Make, + System.Plugins.Package, + System.Plugins.PackageAPI, + System.Plugins.ParsePkgConfCabal, + System.Plugins.Parser, + System.Plugins.Process, + System.Plugins.Utils +c-sources: + src/Language/Hi/hschooks.c +includes: Linker.h +extensions: CPP, ForeignFunctionInterface +Build-Depends: base, Cabal, haskell-src +ghc-options: -Wall -O -fasm -funbox-strict-fields -fno-warn-missing-signatures +hs-source-dir: src diff --git a/plugins.cabal.hsx b/plugins.cabal.hsx new file mode 100644 --- /dev/null +++ b/plugins.cabal.hsx @@ -0,0 +1,38 @@ +name: plugins +version: 1.0 +license: LGPL +License-file: LICENSE +author: Don Stewart +maintainer: dons@cse.unsw.edu.au +exposed-modules: + AltData.Dynamic, + AltData.Typeable, + Language.Hi.Binary, + Language.Hi.FastMutInt, + Language.Hi.FastString, + Language.Hi.Parser, + Language.Hi.PrimPacked, + Language.Hi.Syntax, + System.Eval, + System.Eval.Haskell, + System.Eval.Utils, + System.MkTemp, + System.Plugins, + System.Plugins.Consts, + System.Plugins.Env, + System.Plugins.Load, + System.Plugins.LoadTypes, + System.Plugins.Make, + System.Plugins.Package, + System.Plugins.PackageAPI, + System.Plugins.ParsePkgConfCabal, + System.Plugins.Parser, + System.Plugins.Process, + System.Plugins.Utils +c-sources: + src/Language/Hi/hschooks.c +includes: Linker.h +extensions: CPP, ForeignFunctionInterface +Build-Depends: base, Cabal, haskell-src-exts +ghc-options: -Wall -O -fvia-C -funbox-strict-fields -fno-warn-missing-signatures +hs-source-dir: src diff --git a/scripts/Setup-with-ghc.lhs b/scripts/Setup-with-ghc.lhs new file mode 100644 --- /dev/null +++ b/scripts/Setup-with-ghc.lhs @@ -0,0 +1,20 @@ +#!/usr/bin/env runhaskell +> module Main where +> import Distribution.Simple +> import Distribution.Setup ( ConfigFlags (..) ) +> import System.Directory ( findExecutable ) +> +> main :: IO () +> main = defaultMainWithHooks (defaultUserHooks { postConf = defaultPostConf }) +> where defaultPostConf args flags lbi {- xx -} +> = do args' <- fmap (args++) (configToArgs flags) +> (postConf defaultUserHooks) args' flags lbi {- xx -} +> +> -- need to pass with-ghc arg onto ./configure for non-standard ghcs +> configToArgs :: ConfigFlags -> IO [String] +> configToArgs (ConfigFlags { configHcPath = Just hcPath }) +> = do exec <- findExecutable hcPath +> case exec of +> Just realPath -> return ["--with-ghc="++realPath] +> Nothing -> return ["--with-ghc="++hcPath] +> configToArgs _ = return [] diff --git a/scripts/mkrelease.sh b/scripts/mkrelease.sh new file mode 100644 --- /dev/null +++ b/scripts/mkrelease.sh @@ -0,0 +1,11 @@ +#!/bin/sh + +cd /tmp +rm -rf hs-plugins-0.9.10* + +darcs get --partial --set-scripts-executable /home/dons/hs-plugins +cd hs-plugins +rm -rf _darcs +cd .. +mv hs-plugins hs-plugins-0.9.10 +tar czf hs-plugins-0.9.10.tar.gz hs-plugins-0.9.10 diff --git a/scripts/openbsd-port/Makefile b/scripts/openbsd-port/Makefile new file mode 100644 --- /dev/null +++ b/scripts/openbsd-port/Makefile @@ -0,0 +1,21 @@ +# $OpenBSD$ + +COMMENT= "dynamic link library for Haskell" + +V= 0.9.10 +DISTNAME= hs-plugins-${V} +CATEGORIES= devel +MAINTAINER= Don Stewart +HOMEPAGE= http://www.cse.unsw.edu.au/~dons/hs-plugins/ +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 --- /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 --- /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 --- /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/AltData/Dynamic.hs b/src/AltData/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/AltData/Dynamic.hs @@ -0,0 +1,162 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- | +-- Module : Data.Dynamic +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Dynamic interface provides basic support for dynamic types. +-- +-- Operations for injecting values of arbitrary type into +-- a dynamically typed value, Dynamic, are provided, together +-- with operations for converting dynamic values into a concrete +-- (monomorphic) type. +-- +----------------------------------------------------------------------------- + +module AltData.Dynamic ( + + -- Module Data.Typeable re-exported for convenience + module AltData.Typeable, + + -- * The @Dynamic@ type + Dynamic, -- abstract, instance of: Show, Typeable + + -- * Converting to and from @Dynamic@ + toDyn, -- :: Typeable a => a -> Dynamic + fromDyn, -- :: Typeable a => Dynamic -> a -> a + fromDynamic, -- :: Typeable a => Dynamic -> Maybe a + +#if __GLASGOW_HASKELL__ >= 603 + -- * Applying functions of dynamic type + dynApply, + dynApp, + dynTypeRep + +#endif + ) where + +import AltData.Typeable +import Data.Maybe + +import System.IO.Unsafe (unsafePerformIO) + +import GHC.Base +import GHC.Show +#if __GLASGOW_HASKELL__ >= 603 +import GHC.Err +#endif + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# + +------------------------------------------------------------- +-- +-- The type Dynamic +-- +------------------------------------------------------------- + +{-| + A value of type 'Dynamic' is an object encapsulated together with its type. + + A 'Dynamic' may only represent a monomorphic value; an attempt to + create a value of type 'Dynamic' from a polymorphically-typed + expression will result in an ambiguity error (see 'toDyn'). + + 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation + of the object\'s type; useful for debugging. +-} +data Dynamic = Dynamic TypeRep Obj + +instance Typeable Dynamic where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") [] +#else + typeOf _ = mkAppTy (mkTyCon "AltData.Dynamic") [] +#endif + +instance Show Dynamic where + -- the instance just prints the type representation. + showsPrec _ (Dynamic t _) = + showString "<<" . + showsPrec 0 t . + showString ">>" + +type Obj = forall a . a + -- Dummy type to hold the dynamically typed value. + -- + -- In GHC's new eval/apply execution model this type must + -- be polymorphic. It can't be a constructor, because then + -- GHC will use the constructor convention when evaluating it, + -- and this will go wrong if the object is really a function. On + -- the other hand, if we use a polymorphic type, GHC will use + -- a fallback convention for evaluating it that works for all types. + -- (using a function type here would also work). + +-- | Converts an arbitrary value into an object of type 'Dynamic'. +-- +-- The type of the object must be an instance of 'Typeable', which +-- ensures that only monomorphically-typed objects may be converted to +-- 'Dynamic'. To convert a polymorphic object into 'Dynamic', give it +-- a monomorphic type signature. For example: +-- +-- > toDyn (id :: Int -> Int) +-- +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. See also 'fromDynamic'. +fromDyn :: Typeable a + => Dynamic -- ^ the dynamically-typed object + -> a -- ^ a default value + -> a -- ^ returns: the value of the first argument, if + -- it has the correct type, otherwise the value of + -- the second argument. +fromDyn (Dynamic t v) def + | typeOf def == t = unsafeCoerce v + | otherwise = def + +-- | Converts a 'Dynamic' object back into an ordinary Haskell value of +-- the correct type. See also 'fromDyn'. +fromDynamic + :: Typeable a + => Dynamic -- ^ the dynamically-typed object + -> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed + -- object has the correct type (and @a@ is its value), + -- or 'Nothing' otherwise. +fromDynamic (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 + +#if __GLASGOW_HASKELL__ >= 603 + +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = + case funResultTy t1 t2 of + Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) + Nothing -> Nothing + + +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) + +dynTypeRep :: Dynamic -> TypeRep +dynTypeRep (Dynamic tr _) = tr + +#endif diff --git a/src/AltData/Typeable.hs b/src/AltData/Typeable.hs new file mode 100644 --- /dev/null +++ b/src/AltData/Typeable.hs @@ -0,0 +1,960 @@ +{-# 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 +-- + +-- 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. +-- +-- could use packed strings here. +-- +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/Language/Hi/Binary.hs b/src/Language/Hi/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Language/Hi/Binary.hs @@ -0,0 +1,581 @@ +{-# 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 Language.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 Language.Hi.FastMutInt +import Language.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 +#if __GLASGOW_HASKELL__ < 605 + get bh = do h <- getWord8 bh + case h of + 0 -> return [] + _ -> do x <- get bh + xs <- get bh + return (x:xs) +#else + get bh = do + b <- getByte bh + len <- if b == 0xff + then get bh + else return (fromIntegral b :: Word32) + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len +#endif + +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 +#if WORD_SIZE_IN_BITS == 32 +binaryInterfaceMagic = 0x1face :: Word32 +#elif WORD_SIZE_IN_BITS == 64 +binaryInterfaceMagic = 0x1face64 :: Word32 +#endif + +getBinFileWithDict :: Binary a => FilePath -> IO a +getBinFileWithDict file_path = do + bh <- Language.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 <- Language.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/Language/Hi/FastMutInt.hs b/src/Language/Hi/FastMutInt.hs new file mode 100644 --- /dev/null +++ b/src/Language/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 Language.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/Language/Hi/FastString.hs b/src/Language/Hi/FastString.hs new file mode 100644 --- /dev/null +++ b/src/Language/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 Language.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 Language.Hi.PrimPacked + +import System.IO +import Data.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/Language/Hi/Parser.hs b/src/Language/Hi/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Hi/Parser.hs @@ -0,0 +1,720 @@ +{-# 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 Language.Hi.Parser ( readIface, module Language.Hi.Syntax ) where + +import Language.Hi.Syntax +import Language.Hi.Binary +import Language.Hi.FastString + +#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 String -- '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/Language/Hi/PrimPacked.hs b/src/Language/Hi/PrimPacked.hs new file mode 100644 --- /dev/null +++ b/src/Language/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 Language.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/Language/Hi/Syntax.hs b/src/Language/Hi/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/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 Language.Hi.Syntax where + +import Language.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/Language/Hi/hschooks.c b/src/Language/Hi/hschooks.c new file mode 100644 --- /dev/null +++ b/src/Language/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/Language/Hi/hschooks.h b/src/Language/Hi/hschooks.h new file mode 100644 --- /dev/null +++ b/src/Language/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/System/Eval.hs b/src/System/Eval.hs new file mode 100644 --- /dev/null +++ b/src/System/Eval.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 System.Eval ( + module System.Eval.Haskell, + ) where + +import System.Eval.Haskell {-all-} + diff --git a/src/System/Eval/Haskell.hs b/src/System/Eval/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/System/Eval/Haskell.hs @@ -0,0 +1,302 @@ +-- +-- Copyright (C) 2004-5 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 +-- + +-- +-- | Evaluate Haskell at runtime, using runtime compilation and dynamic +-- loading. Arguments are compiled to native code, and dynamically +-- loaded, returning a Haskell value representing the compiled argument. +-- The underlying implementation treats 'String' arguments as the source +-- for plugins to be compiled at runtime. +-- + +module System.Eval.Haskell ( + eval, + eval_, + unsafeEval, + unsafeEval_, + typeOf, + mkHsValues, + +{- + 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 System.Eval.Utils, + + ) where + +import System.Eval.Utils +import System.Plugins.Make +import System.Plugins.Load + +import AltData.Dynamic ( Dynamic ) +import AltData.Typeable ( Typeable ) + +import Data.Either +import Data.Map as Map + +import System.IO +import System.Directory + +-- import Foreign.C +-- import Foreign + +-- | 'eval' provides a typesafe (to a limit) form of runtime evaluation +-- for Haskell -- a limited form of /runtime metaprogramming/. The +-- 'String' argument to 'eval' is a Haskell source fragment to evaluate +-- at rutime. @imps@ are a list of module names to use in the context of +-- the compiled value. +-- +-- The value returned by 'eval' is constrained to be 'Typeable' -- +-- meaning we can perform a /limited/ runtime typecheck, using the +-- 'dynload' function. One consequence of this is that the code must +-- evaluate to a monomorphic value (which will be wrapped in a +-- 'Dynamic'). +-- +-- If the evaluated code typechecks under the 'Typeable' constraints, +-- 'Just v' is returned. 'Nothing' indicates typechecking failed. +-- Typechecking may fail at two places: when compiling the argument, or +-- when typechecking the splice point. 'eval' resembles a +-- metaprogramming 'run' operator for /closed/ source fragments. +-- +-- To evaluate polymorphic values you need to wrap them in data +-- structures using rank-N types. +-- +-- Examples: +-- +-- > do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int) +-- > when (isJust i) $ putStrLn (show (fromJust i)) +-- +eval :: Typeable a => String -> [Import] -> IO (Maybe a) +eval src imps = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths + tmpf <- mkUniqueWith dynwrap src imps + 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 + +-- +-- | 'eval_' is a variety of 'eval' with all the internal hooks +-- available. You are able to set any extra arguments to the compiler +-- (for example, optimisation flags) or dynamic loader, as well as +-- having any errors returned in an 'Either' type. +-- +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 + +-- | Sometimes when constructing string fragments to evaluate, the +-- programmer is able to provide some other constraint on the evaluated +-- string, such that the evaluated expression will be typesafe, without +-- requiring a 'Typeable' constraint. In such cases, the monomorphic +-- restriction is annoying. 'unsafeEval' removes any splice-point +-- typecheck, with an accompanying obligation on the programmer to +-- ensure that the fragment evaluated will be typesafe at the point it +-- is spliced. +-- +-- An example of how to do this would be to wrap the fragment in a call +-- to 'show'. The augmented fragment would then be checked when compiled +-- to return a 'String', and the programmer can rely on this, without +-- requiring a splice-point typecheck, and thus no 'Typeable' +-- restriction. +-- +-- Note that if you get the proof wrong, your program will likely +-- segfault. +-- +-- Example: +-- +-- > do s <- unsafeEval "map toUpper \"haskell\"" ["Data.Char"] +-- > when (isJust s) $ putStrLn (fromJust s) +-- +unsafeEval :: String -> [Import] -> IO (Maybe a) +unsafeEval src mods = do + pwd <- getCurrentDirectory + tmpf <- mkUniqueWith wrap src mods + status <- make tmpf [] + 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 + +-- +-- | 'unsafeEval_' is a form of 'unsafeEval' with all internal hooks +-- exposed. This is useful for application wishing to return error +-- messages to users, to specify particular libraries to link against +-- and so on. +-- +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 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 +------------------------------------------------------------------------ +-- +-- | 'mkHsValues' is a helper function for converting 'Data.Map's +-- of names and values into Haskell code. It relies on the assumption of +-- names and values into Haskell code. It relies on the assumption that +-- the passed values' Show instances produce valid Haskell literals +-- (this is true for all Prelude types). +-- +mkHsValues :: (Show a) => Map.Map String a -> String +mkHsValues values = concat $ elems $ Map.mapWithKey convertToHs values + where convertToHs :: (Show a) => String -> a -> String + convertToHs name value = name ++ " = " ++ show value ++ "\n" +------------------------------------------------------------------------ +-- +-- | 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 :: IO (LoadStatus Dynamic) + case m_v of + LoadFailure _ -> return "" + LoadSuccess _ v -> 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/System/Eval/Utils.hs b/src/System/Eval/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/Eval/Utils.hs @@ -0,0 +1,96 @@ +-- +-- 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 System.Eval.Utils ( + + Import, + symbol, + escape, + getPaths, + + mkUniqueWith, + cleanup, + + module Data.Maybe, + module Control.Monad, + + ) where + +import System.Plugins.Load ( Symbol ) +import System.Plugins.Utils + +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 + let make_line = ["-Onot","-fglasgow-exts","-package","plugins"] + return (make_line,[]) + +-- --------------------------------------------------------------------- +-- 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/System/MkTemp.hs b/src/System/MkTemp.hs new file mode 100644 --- /dev/null +++ b/src/System/MkTemp.hs @@ -0,0 +1,278 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- glaexts for I# ops +-- +-- Copyright (c) 2004-5 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 System.MkTemp ( + + mktemp, -- :: FilePath -> IO Maybe FilePath + mkstemp, -- :: FilePath -> IO Maybe (FilePath, Handle) + mkstemps, -- :: FilePath -> Int -> IO Maybe (FilePath,Handle) + mkdtemp, -- :: FilePath -> IO Maybe FilePath + + ) where + +import Data.List +import Data.Char ( chr, ord, isDigit ) +import Control.Monad ( liftM ) +import Control.Exception ( handleJust ) +import System.Directory ( doesDirectoryExist, doesFileExist, createDirectory ) +import System.IO +#ifndef __MINGW32__ +import System.IO.Error ( isAlreadyExistsError ) +#else +import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError ) +#endif + +import GHC.IOBase ( IOException(IOError), + Exception(IOException), + IOErrorType(AlreadyExists) ) + +#ifndef __MINGW32__ +import qualified System.Posix.Internals ( c_getpid ) +#endif + +#ifdef HAVE_ARC4RANDOM +import GHC.Base hiding ( ord, chr ) +import GHC.Int +#else +import System.Random ( getStdRandom, Random(randomR) ) +#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 :: Exception -> Maybe Exception +alreadyExists e@(IOException ioe) + | isAlreadyExistsError ioe = Just e + | otherwise = Nothing +alreadyExists _ = Nothing + +isInUse :: Exception -> Maybe () +#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 +-- +-- N.B. race condition between testing existence and opening +-- But we can live with that to avoid a posix dependency, right? +-- +open0600 :: FilePath -> IO Handle +open0600 f = do + b <- doesFileExist f + if b then ioError err -- race + else openFile f ReadWriteMode + where + err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing + +{- +-- 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 } +-} + +-- +-- create a directory mode 0700 if possible +-- +mkdir0700 :: FilePath -> IO () +mkdir0700 dir = createDirectory dir +{- + System.Posix.Directory.createDirectory dir ownerModes +-} + +-- | getProcessId, stolen from GHC /main\/SysTools.lhs/ +-- +#ifdef __MINGW32__ +-- relies on Int == Int32 on Windows +foreign import ccall unsafe "_getpid" getProcessID' :: IO Int +getProcessID :: IO Int +getProcessID = liftM abs getProcessID' +#else +getProcessID :: IO Int +#ifdef CYGWIN +getProcessID = System.Posix.Internals.c_getpid >>= return . abs . fromIntegral +#else +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif +#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 "stdlib.h arc4random" c_arc4random :: IO Int32 +#endif diff --git a/src/System/Plugins.hs b/src/System/Plugins.hs new file mode 100644 --- /dev/null +++ b/src/System/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 System.Plugins ( + + -- $Description + + module System.Plugins.Make, + module System.Plugins.Load, + + ) where + +import System.Plugins.Make {-all-} +import System.Plugins.Load {-all-} + +-- +-- $Description +-- +-- [@NAME@] hs-plugins library : compile and load Haskell code at runtime +-- + diff --git a/src/System/Plugins/Consts.hs b/src/System/Plugins/Consts.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Consts.hs @@ -0,0 +1,78 @@ +-- +-- 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 System.Plugins.Consts where + +#include "../../../config.h" + + +#if __GLASGOW_HASKELL__ >= 604 +import System.Directory ( getTemporaryDirectory ) +import System.IO.Unsafe ( unsafePerformIO ) +#endif + + +-- | path to *build* dir, used by eval() for testing the examples +top = TOP + +-- | what is ghc called? +ghc = WITH_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" +#if defined(CYGWIN) || defined(__MINGW32__) +dllSuf = ".dll" +#else +dllSuf = ".so" +#endif + +-- | 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 __GLASGOW_HASKELL__ >= 604 +tmpDir = unsafePerformIO getTemporaryDirectory +{-# NOINLINE tmpDir #-} +#else +#if !defined(__MINGW32__) +tmpDir = "/tmp" +#else +tmpDir = error "tmpDir not defined for this platform. Try setting the TMPDIR env var" +#endif +#endif diff --git a/src/System/Plugins/Env.hs b/src/System/Plugins/Env.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Env.hs @@ -0,0 +1,465 @@ +-- +-- Copyright (C) 2004-5 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 System.Plugins.Env ( + env, + withModEnv, + withDepEnv, + withPkgEnvs, + withMerged, + modifyModEnv, + modifyDepEnv, + modifyPkgEnv, + modifyMerged, + addModule, + rmModule, + addModules, + isLoaded, + loaded, + addModuleDeps, + getModuleDeps, + rmModuleDeps, + isMerged, + lookupMerged, + addMerge, + addPkgConf, + union, + grabDefaultPkgConf, + readPackageConf, + lookupPkg + + ) where + +#include "../../../config.h" + +import System.Plugins.LoadTypes (Module) +import System.Plugins.PackageAPI {- everything -} +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import System.Plugins.ParsePkgConfCabal( parsePkgConf ) +#else +import System.Plugins.ParsePkgConfLite ( parsePkgConf ) +#endif +import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix ) + +import Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) +import Data.Maybe ( isJust, isNothing, fromMaybe ) +import Data.List ( isPrefixOf, nub ) + +import System.IO.Unsafe ( unsafePerformIO ) +import System.Directory ( doesFileExist ) +#if defined(CYGWIN) || defined(__MINGW32__) +import Prelude hiding ( catch, ioError ) +import System.Environment ( getEnv ) +import System.IO.Error ( catch, ioError, isDoesNotExistError ) +#endif + +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 (Module,Int) (a hash of +-- package\/object names to Modules and how many times they've been +-- loaded). +-- +-- 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 (Module,Int) + +type DepEnv = FiniteMap Module [Module] + +-- 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 DepEnv, + 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 + ref2 <- newIORef emptyFM + p <- grabDefaultPkgConf + ref3 <- newIORef p -- package.conf info + ref4 <- newIORef emptyFM -- merged files + return (mvar, ref1, ref2, ref3, ref4) +{-# 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 any -Env function. Nice and threadsafe +-- +withModEnv :: Env -> (ModEnv -> IO a) -> IO a +withDepEnv :: Env -> (DepEnv -> 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) +withDepEnv (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 () +modifyDepEnv :: Env -> (DepEnv -> IO DepEnv) -> IO () +modifyPkgEnv :: Env -> (PkgEnvs -> IO PkgEnvs) -> IO () +modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO () + +modifyModEnv (mvar,ref,_,_,_) f = lockAndWrite mvar ref f +modifyDepEnv (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 -> Module -> IO () +addModule s m = modifyModEnv env $ \fm -> let c = maybe 0 snd (lookupFM fm s) + in return $ addToFM fm s (m,c+1) + +--getModule :: String -> IO (Maybe Module) +--getModule s = withModEnv env $ \fm -> return (lookupFM fm s) + +-- +-- | remove a module name from the environment. Returns True if the +-- module was actually removed. +-- +rmModule :: String -> IO Bool +rmModule s = do modifyModEnv env $ \fm -> let c = maybe 1 snd (lookupFM fm s) + fm' = delFromFM fm s + in if c-1 <= 0 + then return fm' + else return fm + withModEnv env $ \fm -> return (isNothing (lookupFM fm s)) + +-- +-- | insert a list of module names all in one go +-- +addModules :: [(String,Module)] -> IO () +addModules ns = mapM_ (uncurry addModule) ns + +-- +-- | 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) + +-- ----------------------------------------------------------- +-- +-- module dependency stuff +-- + +-- +-- | Set the dependencies of a Module. +-- +addModuleDeps :: Module -> [Module] -> IO () +addModuleDeps m deps = modifyDepEnv env $ \fm -> return $ addToFM fm m deps + +-- +-- | Get module dependencies. Nothing if none have been recored. +-- +getModuleDeps :: Module -> IO [Module] +getModuleDeps m = withDepEnv env $ \fm -> return $ fromMaybe [] (lookupFM fm m) + + +-- +-- | Unrecord a module from the environment. +-- +rmModuleDeps :: Module -> IO () +rmModuleDeps m = modifyDepEnv env $ \fm -> return $ delFromFM fm m + +-- ----------------------------------------------------------- +-- 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 foldr (\p fm' -> addToFM fm' (packageName p) p) fm ps' : ls + +-- +-- | 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. +-- +-- . 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. +-- +-- 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],[FilePath]) +lookupPkg p = do + t <- lookupPkg' p + case t of ([],(f,g)) -> return (f,g) + (ps,(f,g)) -> do gss <- mapM lookupPkg ps + let (f',g') = unzip gss + return $ (nub $ (concat f') ++ f,nub $ (concat g') ++ g) + +data LibrarySpec + = DLL String -- -lLib + | DLLPath FilePath -- -Lpath + +classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) +classifyLdInput ('-':'l':lib) = return (Just (DLL lib)) +classifyLdInput ('-':'L':path) = return (Just (DLLPath path)) +classifyLdInput _ = return Nothing + +-- TODO need to define a MAC\/DARWIN symbol +#if defined(MACOSX) +mkSOName root = "lib" ++ root ++ ".dylib" +#elif defined(CYGWIN) || defined(__MINGW32__) +-- Win32 DLLs have no .dll extension here, because addDLL tries +-- both foo.dll and foo.drv +mkSOName root = root +#else +mkSOName root = "lib" ++ root ++ ".so" +#endif + +-- +-- 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],[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 hslibs = hsLibraries package + extras' = extraLibraries package + cbits = filter (\e -> reverse (take (length "_cbits") (reverse e)) == "_cbits") extras' + extras = filter (not . flip elem (cbits++["m","gmp"])) extras' + ldopts = ldOptions package + deppkgs = packageDeps package + ldInput <- mapM classifyLdInput ldopts + let ldOptsLibs = [ path | Just (DLL path) <- ldInput ] + ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ] + dlls = map mkSOName (extras ++ ldOptsLibs) +#if defined(CYGWIN) || defined(__MINGW32__) + libdirs = fix_topdir (libraryDirs package) ++ ldOptsPaths +#else + libdirs = libraryDirs package ++ ldOptsPaths +#endif + libs <- mapM (findHSlib libdirs) (hslibs ++ cbits) +#if defined(CYGWIN) || defined(__MINGW32__) + windowsos <- catch (getEnv "OS") + (\e -> if isDoesNotExistError e then return "Windows_98" else ioError e) + windowsdir <- + if windowsos == "Windows_9X" -- I don't know Windows 9X has OS system variable + then return "C:/windows" + else return "C:/winnt" + sysroot <- catch (getEnv "SYSTEMROOT") + (\e -> if isDoesNotExistError e then return windowsdir else ioError e) -- guess at a reasonable default + let syslibdir = sysroot ++ (if windowsos == "Windows_9X" then "/SYSTEM" else "/SYSTEM32") + libs' <- mapM (findDLL $ syslibdir : libdirs) dlls +#else + libs' <- mapM (findDLL libdirs) dlls +#endif + return (deppkgs, (filterRight libs,map (either id id) libs') ) + +#if defined(CYGWIN) || defined(__MINGW32__) + -- replace $topdir + fix_topdir [] = [] + fix_topdir (x:xs) = replace_topdir x : fix_topdir xs + + replace_topdir [] = [] + replace_topdir ('$':xs) + | take 6 xs == "topdir" = ghcLibraryPath ++ (drop 6 xs) + | otherwise = '$' : replace_topdir xs + replace_topdir (x:xs) = x : replace_topdir xs +#endif + -- a list elimination form for the Maybe type + filterRight :: [Either left right] -> [right] + filterRight [] = [] + filterRight (Right x:xs) = x:filterRight xs + filterRight (Left _:xs) = filterRight 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 (Either String FilePath) + findHSlib [] lib = return (Left lib) + findHSlib (dir:dirs) lib = do + let l = dir lib ++ sysPkgSuffix + b <- doesFileExist l + if b then return $ Right l -- found it! + else findHSlib dirs lib + + findDLL :: [FilePath] -> String -> IO (Either String FilePath) + findDLL [] lib = return (Left lib) + findDLL (dir:dirs) lib = do + let l = dir lib + b <- doesFileExist l + if b then return $ Right l + else findDLL 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/System/Plugins/Load.hs b/src/System/Plugins/Load.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Load.hs @@ -0,0 +1,694 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004-5 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 interface to the GHC runtime's dynamic linker, providing runtime +-- loading and linking of Haskell object files, commonly known as +-- /plugins/. + +module System.Plugins.Load ( + + -- * The @LoadStatus@ type + LoadStatus(..) + + -- * High-level interface + , load + , load_ + , dynload + , pdynload + , pdynload_ + , unload + , unloadAll + , reload + , Module(..) + + -- * Low-level interface + , initLinker -- start it up + , loadModule -- load a vanilla .o + , loadFunction -- retrieve a function from an object + , 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 + + , getImports + + ) where + +#include "../../../config.h" + +import System.Plugins.Make ( build ) +import System.Plugins.Env +import System.Plugins.Utils +import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore ) +import System.Plugins.LoadTypes + +import Language.Hi.Parser + +import AltData.Dynamic ( fromDynamic, 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 +import System.IO ( hClose ) + +-- TODO need a loadPackage p package.conf :: IO () primitive + +-- +-- | The @LoadStatus@ type encodes the return status of functions that +-- perform dynamic loading in a type isomorphic to 'Either'. Failure +-- returns a list of error strings, success returns a reference to a +-- loaded module, and the Haskell value corresponding to the symbol that +-- was indexed. +-- +data LoadStatus a + = LoadSuccess Module a + | LoadFailure Errors + +-- +-- | 'load' is the basic interface to the dynamic loader. A call to +-- 'load' imports a single object file into the caller's address space, +-- returning the value associated with the symbol requested. Libraries +-- and modules that the requested module depends upon are loaded and +-- linked in turn. +-- +-- The first argument is the path to the object file to load, the second +-- argument is a list of directories to search for dependent modules. +-- The third argument is a list of paths to user-defined, but +-- unregistered, /package.conf/ files. The 'Symbol' argument is the +-- symbol name of the value you with to retrieve. +-- +-- The value returned must be given an explicit type signature, or +-- provided with appropriate type constraints such that Haskell compiler +-- can determine the expected type returned by 'load', as the return +-- type is notionally polymorphic. +-- +-- Example: +-- +-- > do mv <- load "Plugin.o" ["api"] [] "resource" +-- > case mv of +-- > LoadFailure msg -> print msg +-- > LoadSuccess _ v -> return v +-- +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,moduleDeps) <- 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 (mapM_ unloadAll (m:moduleDeps)) + +#if DEBUG + putStrLn " ... done" >> hFlush stdout +#endif + addModuleDeps m' moduleDeps + 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 fromDynamic (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 +-- +-- 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 + (tmpf1,hdl1) <- mkTemp -- and send .hi file here. + hClose hdl1 + + let nm = mkModid (basename tmpf) + src = mkTest nm (hierize' . mkModid . hierize $ obj) + (fst $ break (=='.') ty) ty sym + is = map ("-i"++) incs -- api + i = "-i" ++ dirname obj -- plugin + + hWrite hdl src + + e <- build tmpf tmpf1 (i:is++args++["-fno-code","-ohi "++tmpf1]) + mapM_ removeFile [tmpf,tmpf1] + return e + + where + -- fix up hierarchical names + hierize [] = [] + hierize ('/':cs) = '\\' : hierize cs + hierize (c:cs) = c : hierize cs + + hierize'[] = [] + hierize' ('\\':cs) = '.' : hierize' cs + hierize' (c:cs) = c : hierize' cs + +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 its 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 m = rmModuleDeps m >> unloadObj m + +------------------------------------------------------------------------ +-- +-- | unload a module and its dependencies +-- we have the dependencies, so cascaded unloading is possible +-- +unloadAll :: Module -> IO () +unloadAll m = do moduleDeps <- getModuleDeps m + rmModuleDeps m + mapM_ unloadAll moduleDeps + unload m + + +-- +-- | 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 (unloadAll m) +#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 + = loadFunction_ (mi_module i) valsym + +loadFunction_ :: String + -> String + -> IO (Maybe a) +loadFunction_ m valsym + = do let symbol = prefixUnderscore++m++"_"++(encode valsym)++"_closure" +#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 ) + + + +-- +-- | 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 +-- + + +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 (emptyMod p) -- 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 a -> IO () +resolveObjs unloadLoaded + = do r <- c_resolveObjs + when (not r) $ unloadLoaded >> panic "resolvedObjs failed." + + +-- | Unload a module +unloadObj :: Module -> IO () +unloadObj (Module { path = p, kind = k, key = ky }) = case k of + Vanilla -> withCString p $ \c_p -> do + removed <- rmModule name + when (removed) $ do r <- c_unloadObj c_p + when (not r) (panic "unloadObj: failed") + Shared -> return () -- can't unload .so? + where name = case ky of Object s -> s ; Package pk -> pk +-- +-- | from ghci\/ObjLinker.c +-- +-- Load a .so type object file. +-- +loadShared :: FilePath -> IO Module +loadShared str = do +#if DEBUG + putStrLn $ " shared: " ++ str +#endif + 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,dlls) <- lookupPkg p + mapM_ (\l -> loadObject l (Package (mkModid l))) libs +#if DEBUG + putStr (' ':show libs) >> hFlush stdout + putStr (' ':show dlls) >> hFlush stdout +#endif + mapM_ loadShared dlls + + + +-- +-- 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 (\(a,_) -> (filter (isSublistOf pkg') ) a) (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,[Module]) +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 (mapM_ unloadPackage ps') +#if DEBUG + when (not (null ps')) $ putStrLn "done" + putStr "Loading object" + mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods'' +#endif + moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods'' + return (hiface,moduleDeps) + +-- --------------------------------------------------------------------- +-- Nice interface to .hi parser +-- +getImports :: String -> IO [String] +getImports m = do + hi <- readIface (m ++ hiSuf) + return $ dep_mods (mi_deps hi) + +-- --------------------------------------------------------------------- +-- 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/System/Plugins/LoadTypes.hs b/src/System/Plugins/LoadTypes.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/LoadTypes.hs @@ -0,0 +1,52 @@ +-- +-- Copyright (c) 2005 Lemmih +-- Copyright (c) 2005 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 System.Plugins.LoadTypes + ( Key (..) + , Symbol + , Type + , Errors + , PackageConf + , Module (..) + , ObjType (..) + ) where + +import Language.Hi.Parser + +data Key = Object String | Package String + +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 + } +instance Ord Module where + compare m1 m2 = mname m1 `compare` mname m2 + +instance Eq Module where + m1 == m2 = mname m1 == mname m2 + +data ObjType = Vanilla | Shared deriving Eq diff --git a/src/System/Plugins/Make.hs b/src/System/Plugins/Make.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Make.hs @@ -0,0 +1,443 @@ +-- +-- Copyright (C) 2004-5 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 interface to a Haskell compiler, providing the facilities of a +-- compilation manager. + +module System.Plugins.Make ( + + -- * The @MakeStatus@ type + MakeStatus(..), + + -- * The @MakeCode@ type + MakeCode(..), + + -- * Compiling Haskell modules + make, + makeAll, + makeWith, + + -- * Handling reecompilation + hasChanged, + hasChanged', + recompileAll, + recompileAll', + + -- * Merging together Haskell source files + MergeStatus(..), + MergeCode, + Args, + Errors, + merge, + mergeTo, + mergeToDir, + + -- * Cleaning up temporary files + makeClean, + makeCleaner, + + -- * Low-level compilation primitives + build, {- internal -} + + ) where + +import System.Plugins.Utils +import System.Plugins.Parser +import System.Plugins.LoadTypes ( Module (Module, path) ) +import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf ) +import System.Plugins.Process ( exec ) +import System.Plugins.Env ( lookupMerged, addMerge + , getModuleDeps) + +#if DEBUG +import System.IO (hFlush, stdout, openFile, IOMode(..),hClose, hPutStr) +#else +import System.IO (openFile, IOMode(..),hClose,hPutStr) +#endif + +import System.Directory ( doesFileExist, removeFile + , getModificationTime ) + +import Control.Exception ( handleJust ) +import GHC.IOBase ( Exception(IOException) ) + +#if __GLASGOW_HASKELL__ >= 604 +import System.IO.Error ( isDoesNotExistError ) +#endif + +-- +-- | The @MakeStatus@ type represents success or failure of compilation. +-- Compilation can fail for the usual reasons: syntax errors, type +-- errors and the like. The @MakeFailure@ constructor returns any error +-- messages produced by the compiler. @MakeSuccess@ returns a @MakeCode@ +-- value, and the path to the object file produced. +-- +data MakeStatus + = MakeSuccess MakeCode FilePath -- ^ compilation was successful + | MakeFailure Errors -- ^ compilation failed + deriving (Eq,Show) + +-- | The @MakeCode@ type is used when compilation is successful, to +-- distinguish two cases: +-- * The source file needed recompiling, and this was done +-- * The source file was already up to date, recompilation was skipped +data MakeCode + = ReComp -- ^ recompilation was performed + | NotReq -- ^ recompilation was not required + deriving (Eq,Show) + +-- +-- | An equivalent status for the preprocessor phase +-- +data MergeStatus + = MergeSuccess MergeCode Args FilePath -- ^ the merge was successful + | MergeFailure Errors -- ^ failure, and any errors returned + deriving (Eq,Show) + +-- +-- | Merging may be avoided if the source files are older than an +-- existing merged result. The @MergeCode@ type indicates whether +-- merging was performed, or whether it was unneccessary. +-- +type MergeCode = MakeCode + +-- | A list of @String@ arguments +type Args = [Arg] + +-- | Convience synonym +type Errors = [String] + +-- touch. + +-- --------------------------------------------------------------------- +-- | One-shot unconditional compilation of a single Haskell module. +-- @make@ behaves like 'ghc -c'. Extra arguments to 'ghc' may be passed +-- in the 'args' parameter, they will be appended to the argument list. +-- @make@ always recompiles its target, whether or not it is out of +-- date. +-- +-- A side-effect of calling 'make' is to have GHC produce a @.hi@ file +-- containing a list of package and objects that the source depends on. +-- Subsequent calls to 'load' will use this interface file to load +-- module and library dependencies prior to loading the object itself. +-- +make :: FilePath -> [Arg] -> IO MakeStatus +make src args = rawMake src ("-c":args) True + +-- | 'makeAll' recursively compiles any dependencies it can find using +-- GHC's @--make@ flag. Dependencies will be recompiled only if they are +-- visible to 'ghc' -- this may require passing appropriate include path +-- flags in the 'args' parameter. 'makeAll' takes the top-level file as +-- the first argument. +-- +makeAll :: FilePath -> [Arg] -> IO MakeStatus +makeAll src args = + rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False + +-- | This is a variety of 'make' that first calls 'merge' to +-- combine the plugin source with a syntax stub. The result is then +-- compiled. This is provided for 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: +-- +-- > module A where +-- > a :: Integer +-- > a = 1 +-- +-- and +-- +-- > module B where +-- > a :: Int +-- +-- Calling @makeWith "A" "B" []@ will merge the module name and types +-- from module B into module A, generating a third file: +-- +-- > {-# LINE 1 "A.hs" #-} +-- > module MxYz123 where +-- > {-# LINE 3 "B.hs" #-} +-- > a :: Int +-- > {-# LINE 4 "A.hs" #-} +-- > a = 1 +-- +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' + +------------------------------------------------------------------------ +-- +-- | @hasChanged@ returns @True@ if the module or any of its +-- dependencies have older object files than source files. Defaults to +-- @True@ if some files couldn't be located. +-- +hasChanged :: Module -> IO Bool +hasChanged = hasChanged' ["hs","lhs"] + +hasChanged' :: [String] -> Module -> IO Bool +hasChanged' suffices m@(Module {path = p}) + = do modFile <- doesFileExist p + mbFile <- findFile suffices p + case mbFile of + Just f | modFile + -> do srcT <- getModificationTime f + objT <- getModificationTime p + if srcT > objT + then return True + else do deps <- getModuleDeps m + depsStatus <- mapM (hasChanged' suffices) deps + return (or depsStatus) + _ -> return True + +-- +-- | 'recompileAll' is like 'makeAll', but rather than relying on +-- @ghc --make@, we explicitly check a module\'s dependencies using our +-- internal map of module dependencies. Performance is thus better, and +-- the result is more accurate. +-- +recompileAll :: Module -> [Arg] -> IO MakeStatus +recompileAll = recompileAll' ["hs","lhs"] + +recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus +recompileAll' suffices m args + = do changed <- hasChanged m + if changed + then do mbSource <- findFile suffices (path m) + case mbSource of + Nothing + -> error $ "Couldn't find source for object file: " ++ path m + Just source + -> makeAll source args + else return (MakeSuccess NotReq (path m)) + +-- --------------------------------------------------------------------- +-- 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 + } + +-- +-- | Lower-level than 'make'. 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 + -- does this work in the presence of hier plugins? + -- won't handle hier names properly. + + 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 + + (_out,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) +-- +-- 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. +-- +-- '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 +-- @-package@ flag to GHC, they may specify this using the non-standard +-- @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 +-- @OPTIONS@ pragma. The merging operation uses the parser hs-plugins +-- was configured with, either 'Language.Haskell' or the HSX parser, to +-- parse Haskell source files. +-- +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 + +-- | 'mergeTo' behaves like 'merge', but we can specify the file in +-- which to place output. +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus +mergeTo src stb out = rawMerge src stb out False + +-- | 'mergeToDir' behaves like 'merge', but lets you specify a target +-- directory. +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/System/Plugins/Package.hs b/src/System/Plugins/Package.hs new file mode 100644 --- /dev/null +++ b/src/System/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 System.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/System/Plugins/PackageAPI.hs b/src/System/Plugins/PackageAPI.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/PackageAPI.hs @@ -0,0 +1,95 @@ +-- +-- 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 System.Plugins.PackageAPI ( + PackageName + , PackageConfig + , packageName + , packageName_ + , importDirs + , hsLibraries + , libraryDirs + , extraLibraries + , ldOptions + , packageDeps + , updImportDirs + , updLibraryDirs + ) where + +#include "../../../config.h" + +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import Distribution.InstalledPackageInfo +import Distribution.Package +#else +import System.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 + +ldOptions :: PackageConfig -> [String] +ldOptions = extra_ld_opts + +#endif diff --git a/src/System/Plugins/ParsePkgConfCabal.hs b/src/System/Plugins/ParsePkgConfCabal.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/ParsePkgConfCabal.hs @@ -0,0 +1,796 @@ +{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -w #-} + +module System.Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Data.Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import Data.List ( break ) +import Data.Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.15 + +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' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity +happyRunIdentity (HappyIdentity a) = a + +instance Monad HappyIdentity where + return = HappyIdentity + (HappyIdentity p) >>= q = q p + +happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b +happyThen = (>>=) +happyReturn :: () => a -> HappyIdentity a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> HappyIdentity a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [Token] -> HappyIdentity a +happyError' = HappyIdentity . happyError + +parse tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x)) + +happySeq = happyDoSeq + +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$ + + +{-# 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 + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +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 170 "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_ tk + +{- 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/System/Plugins/ParsePkgConfCabal.y_in b/src/System/Plugins/ParsePkgConfCabal.y_in new file mode 100644 --- /dev/null +++ b/src/System/Plugins/ParsePkgConfCabal.y_in @@ -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 System.Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Data.Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import Data.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/System/Plugins/ParsePkgConfLite.hs b/src/System/Plugins/ParsePkgConfLite.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/ParsePkgConfLite.hs @@ -0,0 +1,616 @@ +{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -w #-} + +module System.Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import System.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 + +-- parser produced by Happy Version 1.15 + +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 = happySpecReduce_1 7# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOutTok happy_x_1 of { (ITconid happy_var_1) -> + happyIn12 + ( case happy_var_1 of { + "True" -> True; + "False" -> False; + _ -> error ("unknown constructor in config file: " ++ happy_var_1) } + )} + +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' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity +happyRunIdentity (HappyIdentity a) = a + +instance Monad HappyIdentity where + return = HappyIdentity + (HappyIdentity p) >>= q = q p + +happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b +happyThen = (>>=) +happyReturn :: () => a -> HappyIdentity a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> HappyIdentity a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [Token] -> HappyIdentity a +happyError' = HappyIdentity . happyError + +parse tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyRunIdentity happySomeParser where + happySomeParser = 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" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id$ + + +{-# 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 + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +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 170 "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_ tk + +{- 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/System/Plugins/ParsePkgConfLite.y b/src/System/Plugins/ParsePkgConfLite.y new file mode 100644 --- /dev/null +++ b/src/System/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 System.Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import System.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/System/Plugins/Parser.hs b/src/System/Plugins/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Parser.hs @@ -0,0 +1,238 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004-5 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 System.Plugins.Parser ( + parse, mergeModules, pretty, parsePragmas, + HsModule(..) , + replaceModName + ) where + +#include "../../../config.h" + +import Data.List +import Data.Char +import Data.Either + +#if defined(WITH_HSX) +import Language.Haskell.Hsx +#else +import Language.Haskell.Parser +import Language.Haskell.Syntax +import Language.Haskell.Pretty +#endif + +-- +-- | parse a file (as a string) as Haskell src +-- +parse :: FilePath -- ^ module name + -> String -- ^ haskell src + -> Either String HsModule -- ^ abstract syntax + +parse f fsrc = +#if defined(WITH_HSX) + case parseFileContentsWithMode (ParseMode f) fsrc of +#else + case parseModuleWithMode (ParseMode f) fsrc of +#endif + 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 (not.typeDecl) ds + 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, up to 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/System/Plugins/Process.hs b/src/System/Plugins/Process.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Process.hs @@ -0,0 +1,89 @@ +-- +-- | A Posix.popen compatibility mapping. +-- +-- If we use this, we should build -threaded +-- +module System.Plugins.Process (exec, popen) where + +import System.Exit +#if __GLASGOW_HASKELL__ >= 604 +import System.IO +import System.Process +import Control.Concurrent (forkIO) +#else +import qualified Posix as P +#endif + +import qualified Control.Exception + +-- +-- slight wrapper over popen for calls that don't care about stdin to the program +-- +exec :: String -> [String] -> IO ([String],[String]) +exec f as = do + (a,b,_) <- popen f as (Just []) + return (lines a, lines b) + +#if __GLASGOW_HASKELL__ >= 604 + +type ProcessID = ProcessHandle + +-- +-- Ignoring exit status for now. +-- +-- XXX there are still issues. Large amounts of output can cause what +-- seems to be a dead lock on the pipe write from runplugs, for example. +-- Posix.popen doesn't have this problem, so maybe we can reproduce its +-- pipe handling somehow. +-- +popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID) +popen file args minput = + Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do + + (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing + + case minput of + Just input -> hPutStr inp input >> hClose inp -- importante! + Nothing -> return () + + -- Now, grab the input + output <- hGetContents out + errput <- hGetContents err + + -- SimonM sez: + -- ... avoids blocking the main thread, but ensures that all the + -- data gets pulled as it becomes available. you have to force the + -- output strings before waiting for the process to terminate. + -- + forkIO (Control.Exception.evaluate (length output) >> return ()) + forkIO (Control.Exception.evaluate (length errput) >> return ()) + + -- And now we wait. We must wait after we read, unsurprisingly. + exitCode <- waitForProcess pid -- blocks without -threaded, you're warned. + case exitCode of + ExitFailure code + | null errput -> let errMsg = file ++ ": failed with error code " ++ show code + in return ([],errMsg,error errMsg) + _ -> return (output,errput,pid) + +#else + +-- +-- catch so that we can deal with forkProcess failing gracefully. and +-- getProcessStatus is needed so as not to get a bunch of zombies, +-- leading to forkProcess failing. +-- +-- Large amounts of input will cause problems with blocking as we wait +-- on the process to finish. Make sure no lambdabot processes will +-- generate 1000s of lines of output. +-- +popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID) +popen f s m = + Control.Exception.handle (\e -> return ([], show e, error $ show e )) $ do + x@(_,_,pid) <- P.popen f s m + b <- P.getProcessStatus True False pid -- wait + return $ case b of + Nothing -> ([], "process has disappeared", pid) + _ -> x + +#endif diff --git a/src/System/Plugins/Utils.hs b/src/System/Plugins/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/Plugins/Utils.hs @@ -0,0 +1,503 @@ +-- +-- 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 System.Plugins.Utils ( + Arg, + + hWrite, + + mkUnique, + hMkUnique, + mkUniqueIn, + hMkUniqueIn, + + findFile, + + mkTemp, mkTempIn, {- internal -} + + replaceSuffix, + outFilePath, + dropSuffix, + mkModid, + changeFileExt, + joinFileExt, + splitFileExt, + + isSublistOf, -- :: Eq a => [a] -> [a] -> Bool + + dirname, + basename, + + (), (<.>), (<+>), (<>), + + newer, + + encode, + decode, + EncodedString, + + panic + + ) where + +#include "../../../config.h" + +import System.Plugins.Env ( isLoaded ) +import System.Plugins.Consts ( objSuf, hiSuf, tmpDir ) +import qualified System.MkTemp ( mkstemps ) + +import Data.Char +import Data.List + +import System.IO +import System.Environment ( getEnv ) +import System.Directory + +-- --------------------------------------------------------------------- +-- 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 <- System.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) + +findFile :: [String] -> FilePath -> IO (Maybe FilePath) +findFile [] _ = return Nothing +findFile (ext:exts) file + = do let l = changeFileExt file ext + b <- doesFileExist l + if b then return $ Just l + else findFile exts file + +-- --------------------------------------------------------------------- +-- 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 = + let x = findIndices (== '\\') p + y = findIndices (== '/') p + in + if not $ null x + then if not $ null y + then if (maximum x) > (maximum y) then dirname' '\\' p else dirname' '/' p + else dirname' '\\' p + else dirname' '/' p + where + dirname' chara pa = + case reverse $ dropWhile (/= chara) $ reverse pa of + [] -> "." + pa' -> pa' + +-- +-- | basename : return the filename portion of a path +-- +basename :: FilePath -> FilePath +basename p = + let x = findIndices (== '\\') p + y = findIndices (== '/') p + in + if not $ null x + then if not $ null y + then if (maximum x) > (maximum y) then basename' '\\' p else basename' '/' p + else basename' '\\' p + else basename' '/' p + where + basename' chara pa = reverse $ takeWhile (/= chara) $ reverse pa + +-- +-- 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 (\x -> ('/'/= x) && ('\\' /= x))) . reverse + + +----------------------------------------------------------- +-- Code from Cabal ---------------------------------------- + +-- | Changes the extension of a file path. +changeFileExt :: FilePath -- ^ The path information to modify. + -> String -- ^ The new extension (without a leading period). + -- Specify an empty string to remove an existing + -- extension from path. + -> FilePath -- ^ A string containing the modified path information. +changeFileExt fpath ext = joinFileExt name ext + where + (name,_) = splitFileExt fpath + +-- | The 'joinFileExt' function is the opposite of 'splitFileExt'. +-- It joins a file name and an extension to form a complete file path. +-- +-- The general rule is: +-- +-- > filename `joinFileExt` ext == path +-- > where +-- > (filename,ext) = splitFileExt path +joinFileExt :: String -> String -> FilePath +joinFileExt fpath "" = fpath +joinFileExt fpath ext = fpath ++ '.':ext + +-- | Split the path into file name and extension. If the file doesn\'t have extension, +-- the function will return empty string. The extension doesn\'t include a leading period. +-- +-- Examples: +-- +-- > splitFileExt "foo.ext" == ("foo", "ext") +-- > splitFileExt "foo" == ("foo", "") +-- > splitFileExt "." == (".", "") +-- > splitFileExt ".." == ("..", "") +-- > splitFileExt "foo.bar."== ("foo.bar.", "") +splitFileExt :: FilePath -> (String, String) +splitFileExt p = + case break (== '.') fname of + (suf@(_:_),_:pre) -> (reverse (pre++fpath), reverse suf) + _ -> (p, []) + where + (fname,fpath) = break isPathSeparator (reverse p) + +-- | Checks whether the character is a valid path separator for the host +-- platform. The valid character is a 'pathSeparator' but since the Windows +-- operating system also accepts a slash (\"\/\") since DOS 2, the function +-- checks for it on this platform, too. +isPathSeparator :: Char -> Bool +isPathSeparator ch = +#if defined(CYGWIN) || defined(__MINGW32__) + ch == '/' || ch == '\\' +#else + ch == '/' +#endif + +-- Code from Cabal end ------------------------------------ +----------------------------------------------------------- + + +-- | 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/testsuite/README b/testsuite/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/TIMINGS b/testsuite/TIMINGS new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/build.mk b/testsuite/build.mk new file mode 100644 --- /dev/null +++ b/testsuite/build.mk @@ -0,0 +1,40 @@ +# how to build the default projects + +include $(TOP)/config.mk +include $(TOP)/testsuite/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)/testsuite/$(TEST)/api +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/testsuite/check.mk b/testsuite/check.mk new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/conf/simple/Mailrc.conf b/testsuite/conf/simple/Mailrc.conf new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/conf/simple/Mailrc.stub b/testsuite/conf/simple/Mailrc.stub new file mode 100644 --- /dev/null +++ b/testsuite/conf/simple/Mailrc.stub @@ -0,0 +1,28 @@ +module Mailrc ( resource ) where + +import API + +resource :: Interface +resource = mail + + + + + + + + + + + + + + + + + + + + + + diff --git a/testsuite/conf/simple/Makefile b/testsuite/conf/simple/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/conf/simple/Makefile @@ -0,0 +1,4 @@ +TEST= conf/simple + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/conf/simple/api/API.hs b/testsuite/conf/simple/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/conf/simple/prog/Main.hs b/testsuite/conf/simple/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/conf/simple/prog/Main.hs @@ -0,0 +1,22 @@ + +import System.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/testsuite/conf/simple/prog/expected b/testsuite/conf/simple/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/conf/simple/prog/expected @@ -0,0 +1,1 @@ +sh diff --git a/testsuite/dynload/io/Makefile b/testsuite/dynload/io/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/io/Makefile @@ -0,0 +1,6 @@ +TEST=dynload/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/io/TestIO.hs b/testsuite/dynload/io/TestIO.hs new file mode 100644 --- /dev/null +++ b/testsuite/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.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_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/testsuite/dynload/io/api/API.hs b/testsuite/dynload/io/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/io/api/API.hs @@ -0,0 +1,19 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData.Typeable + +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/testsuite/dynload/io/prog/Main.hs b/testsuite/dynload/io/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/io/prog/Main.hs @@ -0,0 +1,12 @@ + +import System.Plugins +import API + +main = do + m_v <- dynload "../TestIO.o" ["../api"] + [] "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/testsuite/dynload/io/prog/expected b/testsuite/dynload/io/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/dynload/io/prog/expected @@ -0,0 +1,1 @@ +True diff --git a/testsuite/dynload/poly/Makefile b/testsuite/dynload/poly/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/poly/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/poly +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/poly/Plugin.hs b/testsuite/dynload/poly/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/poly/Plugin.hs @@ -0,0 +1,12 @@ +module Plugin where + +import API +import AltData.Dynamic + +my_fun = plugin { + equals = \x y -> (x /= y) -- a strange equals function :) + } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/testsuite/dynload/poly/api/API.hs b/testsuite/dynload/poly/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/poly/api/API.hs @@ -0,0 +1,24 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData.Typeable + +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/testsuite/dynload/poly/prog/Main.hs b/testsuite/dynload/poly/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import System.Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + [] + "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/testsuite/dynload/poly/prog/expected b/testsuite/dynload/poly/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/dynload/poly/prog/expected @@ -0,0 +1,2 @@ +True +True diff --git a/testsuite/dynload/should_fail/Makefile b/testsuite/dynload/should_fail/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/should_fail/Plugin.hs b/testsuite/dynload/should_fail/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail/Plugin.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData.Dynamic + +v :: Int +v = 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/testsuite/dynload/should_fail/api/API.hs b/testsuite/dynload/should_fail/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData.Typeable + +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/testsuite/dynload/should_fail/prog/Main.hs b/testsuite/dynload/should_fail/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail/prog/Main.hs @@ -0,0 +1,14 @@ + +import System.Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" + ["../api"] + [] + "resource_dyn" + + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ function v + diff --git a/testsuite/dynload/should_fail/prog/expected b/testsuite/dynload/should_fail/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_1/Makefile b/testsuite/dynload/should_fail_1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_1/Plugin.hs b/testsuite/dynload/should_fail_1/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_1/Plugin.hs @@ -0,0 +1,15 @@ +-- +-- trying to be really mean. +-- + +module Plugin where + +import API +import AltData.Dynamic + +v :: Int -> Int +v = \x -> 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/testsuite/dynload/should_fail_1/api/API.hs b/testsuite/dynload/should_fail_1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_1/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData.Typeable + +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/testsuite/dynload/should_fail_1/prog/Main.hs b/testsuite/dynload/should_fail_1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_1/prog/Main.hs @@ -0,0 +1,11 @@ + +import System.Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + [] "resource_dyn" + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/testsuite/dynload/should_fail_1/prog/expected b/testsuite/dynload/should_fail_1/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_2/Makefile b/testsuite/dynload/should_fail_2/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_2/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_2 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/should_fail_2/Plugin.in b/testsuite/dynload/should_fail_2/Plugin.in new file mode 100644 --- /dev/null +++ b/testsuite/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.Typeable +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf v, unsafeCoerce v) + diff --git a/testsuite/dynload/should_fail_2/Plugin.stub b/testsuite/dynload/should_fail_2/Plugin.stub new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_2/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/testsuite/dynload/should_fail_2/api/API.hs b/testsuite/dynload/should_fail_2/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_2/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData.Typeable +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/testsuite/dynload/should_fail_2/prog/Main.hs b/testsuite/dynload/should_fail_2/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_2/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/dynload/should_fail_2/prog/expected b/testsuite/dynload/should_fail_2/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_2/prog/expected.604 b/testsuite/dynload/should_fail_2/prog/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_2/prog/expected.605 b/testsuite/dynload/should_fail_2/prog/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_2/prog/expected.605 @@ -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/testsuite/dynload/should_fail_3/Makefile b/testsuite/dynload/should_fail_3/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_3/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_3 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/should_fail_3/Plugin.in b/testsuite/dynload/should_fail_3/Plugin.in new file mode 100644 --- /dev/null +++ b/testsuite/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.Typeable +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf plugin, unsafeCoerce v) + diff --git a/testsuite/dynload/should_fail_3/Plugin.stub b/testsuite/dynload/should_fail_3/Plugin.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_3/api/API.hs b/testsuite/dynload/should_fail_3/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_3/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} + +module API where + +import AltData.Typeable +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/testsuite/dynload/should_fail_3/prog/Main.hs b/testsuite/dynload/should_fail_3/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_3/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/dynload/should_fail_3/prog/expected b/testsuite/dynload/should_fail_3/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_3/prog/expected.604 b/testsuite/dynload/should_fail_3/prog/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/dynload/should_fail_3/prog/expected.605 b/testsuite/dynload/should_fail_3/prog/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/dynload/should_fail_3/prog/expected.605 @@ -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/testsuite/dynload/simple/Makefile b/testsuite/dynload/simple/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/dynload/simple/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/simple +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/dynload/simple/Plugin.hs b/testsuite/dynload/simple/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/simple/Plugin.hs @@ -0,0 +1,11 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData.Dynamic + +my_fun = plugin { function = "plugin says \"hello\"" } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/testsuite/dynload/simple/api/API.hs b/testsuite/dynload/simple/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/simple/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData.Typeable + +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/testsuite/dynload/simple/prog/Main.hs b/testsuite/dynload/simple/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/dynload/simple/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import System.Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + [] + "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/testsuite/dynload/simple/prog/expected b/testsuite/dynload/simple/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/dynload/simple/prog/expected @@ -0,0 +1,1 @@ +plugin says "hello" diff --git a/testsuite/eval.mk b/testsuite/eval.mk new file mode 100644 --- /dev/null +++ b/testsuite/eval.mk @@ -0,0 +1,25 @@ +include $(TOP)/config.mk +include $(TOP)/testsuite/check.mk + +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/testsuite/eval/eval1/Main.hs b/testsuite/eval/eval1/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval1/Main.hs @@ -0,0 +1,5 @@ + +import System.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/testsuite/eval/eval1/Makefile b/testsuite/eval/eval1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval1/expected b/testsuite/eval/eval1/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval1/expected @@ -0,0 +1,1 @@ +7 diff --git a/testsuite/eval/eval2/Main.hs b/testsuite/eval/eval2/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval2/Main.hs @@ -0,0 +1,6 @@ +import System.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/testsuite/eval/eval2/Makefile b/testsuite/eval/eval2/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval2/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval2/expected b/testsuite/eval/eval2/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval2/expected @@ -0,0 +1,1 @@ +HASKELL diff --git a/testsuite/eval/eval3/Main.hs b/testsuite/eval/eval3/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval3/Main.hs @@ -0,0 +1,38 @@ +{-# 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/testsuite/eval/eval_fn1/Poly.hs +-- +-- + +#include "../../../config.h" + +import System.Eval +import AltData.Dynamic + +main = do + a <- return $ toDyn (3::Integer) + + -- so, we try to compile a function that takes a dyn. + -- looks like with GHC 6.4, we need to make sure the package.confs work: + m_b <- unsafeEval_ "\\dyn -> fromDyn dyn (7 :: Integer)" + ["AltData.Dynamic"] + [ ] + [ ] + [] + + case m_b of + Left s -> mapM_ putStrLn s + Right b -> putStrLn $ show (b a :: Integer) -- now apply it + +{- +-- 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"] [] [] +-} + diff --git a/testsuite/eval/eval3/Makefile b/testsuite/eval/eval3/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval3/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval3/expected b/testsuite/eval/eval3/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval3/expected @@ -0,0 +1,1 @@ +3 diff --git a/testsuite/eval/eval_/Main.hs b/testsuite/eval/eval_/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_/Main.hs @@ -0,0 +1,9 @@ + +import System.Eval.Haskell + +main = do i <- eval_ "Just (7 :: Int)" + ["Maybe"] + ["-fglasgow-exts"] + [] + [] :: IO (Either [String] (Maybe (Maybe Int))) + print i diff --git a/testsuite/eval/eval_/Makefile b/testsuite/eval/eval_/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval_/expected b/testsuite/eval/eval_/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_/expected @@ -0,0 +1,1 @@ +Right (Just (Just 7)) diff --git a/testsuite/eval/eval_fn/Main.hs b/testsuite/eval/eval_fn/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn/Main.hs @@ -0,0 +1,10 @@ +-- +-- lambda abstraction! +-- +-- +-- needs unsafeEval because eval has a broken Dynamic check +-- +import System.Eval.Haskell + +main = do fn <- unsafeEval "(\\x -> (x,x::Int))" [] :: IO (Maybe (Int -> (Int,Int))) + when (isJust fn) $ putStrLn $ show $ (fromJust fn) 7 diff --git a/testsuite/eval/eval_fn/Makefile b/testsuite/eval/eval_fn/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval_fn/expected b/testsuite/eval/eval_fn/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn/expected @@ -0,0 +1,1 @@ +(7,7) diff --git a/testsuite/eval/eval_fn1/Main.hs b/testsuite/eval/eval_fn1/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn1/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- polymorphic eval! +-- + +module Main where + +import Poly +import System.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/testsuite/eval/eval_fn1/Makefile b/testsuite/eval/eval_fn1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/eval_fn1/Poly.hs b/testsuite/eval/eval_fn1/Poly.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/eval_fn1/expected b/testsuite/eval/eval_fn1/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/eval_fn1/expected @@ -0,0 +1,2 @@ +True +False diff --git a/testsuite/eval/foreign_eval/Makefile b/testsuite/eval/foreign_eval/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/testsuite/eval/foreign_eval/README b/testsuite/eval/foreign_eval/README new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval/README @@ -0,0 +1,1 @@ +run a string of Haskell code from a C program. diff --git a/testsuite/eval/foreign_eval/dont_test b/testsuite/eval/foreign_eval/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval/dont_test diff --git a/testsuite/eval/foreign_eval/expected b/testsuite/eval/foreign_eval/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval/expected @@ -0,0 +1,1 @@ +10946 diff --git a/testsuite/eval/foreign_eval/main.c b/testsuite/eval/foreign_eval/main.c new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/foreign_eval1/Makefile b/testsuite/eval/foreign_eval1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/testsuite/eval/foreign_eval1/dont_test b/testsuite/eval/foreign_eval1/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval1/dont_test diff --git a/testsuite/eval/foreign_eval1/expected b/testsuite/eval/foreign_eval1/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_eval1/expected @@ -0,0 +1,1 @@ +10946 diff --git a/testsuite/eval/foreign_eval1/main.c b/testsuite/eval/foreign_eval1/main.c new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/foreign_should_fail/Makefile b/testsuite/eval/foreign_should_fail/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/testsuite/eval/foreign_should_fail/dont_test b/testsuite/eval/foreign_should_fail/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail/dont_test diff --git a/testsuite/eval/foreign_should_fail/expected b/testsuite/eval/foreign_should_fail/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail/expected @@ -0,0 +1,2 @@ +:1: parse error on input `in' +failed! diff --git a/testsuite/eval/foreign_should_fail/expected.604 b/testsuite/eval/foreign_should_fail/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail/expected.604 @@ -0,0 +1,1 @@ +failed! diff --git a/testsuite/eval/foreign_should_fail/expected.605 b/testsuite/eval/foreign_should_fail/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail/expected.605 @@ -0,0 +1,1 @@ +failed! diff --git a/testsuite/eval/foreign_should_fail/main.c b/testsuite/eval/foreign_should_fail/main.c new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/foreign_should_fail_illtyped/Makefile b/testsuite/eval/foreign_should_fail_illtyped/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail_illtyped/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/testsuite/eval/foreign_should_fail_illtyped/dont_test b/testsuite/eval/foreign_should_fail_illtyped/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail_illtyped/dont_test diff --git a/testsuite/eval/foreign_should_fail_illtyped/expected b/testsuite/eval/foreign_should_fail_illtyped/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/foreign_should_fail_illtyped/expected.604 b/testsuite/eval/foreign_should_fail_illtyped/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail_illtyped/expected.604 @@ -0,0 +1,1 @@ +failed! diff --git a/testsuite/eval/foreign_should_fail_illtyped/expected.605 b/testsuite/eval/foreign_should_fail_illtyped/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/eval/foreign_should_fail_illtyped/expected.605 @@ -0,0 +1,1 @@ +failed! diff --git a/testsuite/eval/foreign_should_fail_illtyped/main.c b/testsuite/eval/foreign_should_fail_illtyped/main.c new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/eval/unsafeidir/Main.hs b/testsuite/eval/unsafeidir/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/unsafeidir/Main.hs @@ -0,0 +1,16 @@ + +import System.Plugins.Make +import System.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/testsuite/eval/unsafeidir/Makefile b/testsuite/eval/unsafeidir/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/eval/unsafeidir/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/eval/unsafeidir/a/Extra.hs b/testsuite/eval/unsafeidir/a/Extra.hs new file mode 100644 --- /dev/null +++ b/testsuite/eval/unsafeidir/a/Extra.hs @@ -0,0 +1,3 @@ +module Extra where + +extra = "an extra value" diff --git a/testsuite/eval/unsafeidir/expected b/testsuite/eval/unsafeidir/expected new file mode 100644 --- /dev/null +++ b/testsuite/eval/unsafeidir/expected @@ -0,0 +1,1 @@ +"Just 7an extra value" diff --git a/testsuite/foreign.mk b/testsuite/foreign.mk new file mode 100644 --- /dev/null +++ b/testsuite/foreign.mk @@ -0,0 +1,22 @@ +include $(TOP)/config.mk +include $(TOP)/testsuite/check.mk + + +INCLUDES= -I$(TOP) + +# 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) -package plugins $(INCLUDES) $(PKGFLAGS) $(SRC) + +clean: + rm -rf *.hi *.o *~ $(BIN) diff --git a/testsuite/hier/hier1/Makefile b/testsuite/hier/hier1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier1/Modules/Flags.hs b/testsuite/hier/hier1/Modules/Flags.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier1/Modules/Makefile b/testsuite/hier/hier1/Modules/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier1/Modules/Makefile @@ -0,0 +1,6 @@ + +all: + ghc -O -c Flags.hs + +clean: + rm -f *.hi *.o diff --git a/testsuite/hier/hier1/Plugin.hs b/testsuite/hier/hier1/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier1/api/API.hs b/testsuite/hier/hier1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier1/prog/Main.hs b/testsuite/hier/hier1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier1/prog/Main.hs @@ -0,0 +1,21 @@ +-- +-- Test multiple plugins +-- + + +module Main where + +import System.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/testsuite/hier/hier1/prog/expected b/testsuite/hier/hier1/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier1/prog/expected @@ -0,0 +1,1 @@ +4 diff --git a/testsuite/hier/hier2/A/B/C/Module.hs b/testsuite/hier/hier2/A/B/C/Module.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier2/A/Makefile b/testsuite/hier/hier2/A/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier2/Makefile b/testsuite/hier/hier2/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier2/api/API.hs b/testsuite/hier/hier2/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier2/api/API.hs @@ -0,0 +1,4 @@ +module API where + +-- just a dummy for the build system + diff --git a/testsuite/hier/hier2/prog/Main.hs b/testsuite/hier/hier2/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/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 System.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/testsuite/hier/hier2/prog/expected b/testsuite/hier/hier2/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier2/prog/expected @@ -0,0 +1,1 @@ +"You found me" diff --git a/testsuite/hier/hier3/Main.hs b/testsuite/hier/hier3/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier3/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import System.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/testsuite/hier/hier3/Makefile b/testsuite/hier/hier3/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier3/Makefile @@ -0,0 +1,7 @@ +TEST= hier/hier3 + +EXTRA_OBJS=One.o Two.o +EXTRAFLAGS= + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/hier/hier3/One.hs b/testsuite/hier/hier3/One.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier3/Two.hs b/testsuite/hier/hier3/Two.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier3/Two.hs @@ -0,0 +1,4 @@ +module Two where + +resource = "This is the top plugin" + diff --git a/testsuite/hier/hier3/expected b/testsuite/hier/hier3/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier4/A.hs b/testsuite/hier/hier4/A.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier4/B.hs b/testsuite/hier/hier4/B.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier4/C.hs b/testsuite/hier/hier4/C.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/hier/hier4/D.hs b/testsuite/hier/hier4/D.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier4/D.hs @@ -0,0 +1,6 @@ + +module D where + +class D a where + +data T a = T diff --git a/testsuite/hier/hier4/Main.hs b/testsuite/hier/hier4/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier4/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import System.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/testsuite/hier/hier4/Makefile b/testsuite/hier/hier4/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier4/Makefile @@ -0,0 +1,4 @@ +TEST= hier/hier4 + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/hier/hier4/expected b/testsuite/hier/hier4/expected new file mode 100644 --- /dev/null +++ b/testsuite/hier/hier4/expected @@ -0,0 +1,1 @@ +YES diff --git a/testsuite/iface/null/A.hs b/testsuite/iface/null/A.hs new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/testsuite/iface/null/B.hs b/testsuite/iface/null/B.hs new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/testsuite/iface/null/Main.hs b/testsuite/iface/null/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/Main.hs @@ -0,0 +1,9 @@ +module Main ( main ) where + +import Language.Hi.Parser + +import A +import B + +main = do iface <- readIface "Main.hi" + putStrLn (showIface iface) diff --git a/testsuite/iface/null/Makefile b/testsuite/iface/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/iface/null/expected b/testsuite/iface/null/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/iface/null/expected.604 b/testsuite/iface/null/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/expected.604 @@ -0,0 +1,5 @@ +interface "unknown" Main +module dependencies: A, B +package dependencies: base-1.0, plugins-1.0 +import B +import A diff --git a/testsuite/iface/null/expected.605 b/testsuite/iface/null/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/iface/null/expected.605 @@ -0,0 +1,5 @@ +interface "unknown" Main +module dependencies: A, B +package dependencies: base-1.0, plugins-1.0 +import B +import A diff --git a/testsuite/load/io/Makefile b/testsuite/load/io/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/io/Makefile @@ -0,0 +1,6 @@ +TEST= load/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/load/io/TestIO.hs b/testsuite/load/io/TestIO.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/io/api/API.hs b/testsuite/load/io/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/io/prog/Main.hs b/testsuite/load/io/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/io/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import System.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/testsuite/load/io/prog/expected b/testsuite/load/io/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/io/prog/expected @@ -0,0 +1,1 @@ +True diff --git a/testsuite/load/load_0/Makefile b/testsuite/load/load_0/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/load_0/Makefile @@ -0,0 +1,6 @@ +TEST= load/load_0 + +EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/load/load_0/Test.hs b/testsuite/load/load_0/Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/load_0/Test.hs @@ -0,0 +1,6 @@ + +module Test where + +import API + +resource = test { field = "success" } diff --git a/testsuite/load/load_0/api/API.hs b/testsuite/load/load_0/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/load_0/prog/Main.hs b/testsuite/load/load_0/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/load_0/prog/Main.hs @@ -0,0 +1,11 @@ + +import System.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/testsuite/load/load_0/prog/expected b/testsuite/load/load_0/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/load_0/prog/expected @@ -0,0 +1,1 @@ +"success" diff --git a/testsuite/load/loadpkg/Main.hs b/testsuite/load/loadpkg/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/loadpkg/Main.hs @@ -0,0 +1,4 @@ + +import System.Plugins + +main = loadPackageWith "posix" [] diff --git a/testsuite/load/loadpkg/Makefile b/testsuite/load/loadpkg/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/loadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/loadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/load/loadpkg/expected b/testsuite/load/loadpkg/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/loadpkg/expected diff --git a/testsuite/load/null/Makefile b/testsuite/load/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/null/Makefile @@ -0,0 +1,4 @@ +TEST= load/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/load/null/Null.hs b/testsuite/load/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/null/api/API.hs b/testsuite/load/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/null/prog/Main.hs b/testsuite/load/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/null/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import System.Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + let includes = [TOP ++ "/testsuite/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/testsuite/load/null/prog/expected b/testsuite/load/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/null/prog/expected @@ -0,0 +1,1 @@ +42 diff --git a/testsuite/load/thiemann0/Makefile b/testsuite/load/thiemann0/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann0/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann0 + +#EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/load/thiemann0/Test.hs b/testsuite/load/thiemann0/Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/thiemann0/api/API.hs b/testsuite/load/thiemann0/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/thiemann0/prog/Main.hs b/testsuite/load/thiemann0/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann0/prog/Main.hs @@ -0,0 +1,16 @@ + +import System.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/testsuite/load/thiemann0/prog/expected b/testsuite/load/thiemann0/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann0/prog/expected @@ -0,0 +1,1 @@ +"SUCCESS" diff --git a/testsuite/load/thiemann2/C.hs b/testsuite/load/thiemann2/C.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/thiemann2/Makefile b/testsuite/load/thiemann2/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann2/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann2 +EXTRAFLAGS+=-iprog + +TOP=../../.. +include ../../build.mk + diff --git a/testsuite/load/thiemann2/api/API.hs b/testsuite/load/thiemann2/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/thiemann2/prog/A.hs b/testsuite/load/thiemann2/prog/A.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/load/thiemann2/prog/B.hs b/testsuite/load/thiemann2/prog/B.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann2/prog/B.hs @@ -0,0 +1,3 @@ +module B where + +resource = "i'm in b" diff --git a/testsuite/load/thiemann2/prog/Main.hs b/testsuite/load/thiemann2/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann2/prog/Main.hs @@ -0,0 +1,20 @@ + +import System.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/testsuite/load/thiemann2/prog/expected b/testsuite/load/thiemann2/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/thiemann2/prog/expected @@ -0,0 +1,1 @@ +"i'm in b" diff --git a/testsuite/load/unloadpkg/Main.hs b/testsuite/load/unloadpkg/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/load/unloadpkg/Main.hs @@ -0,0 +1,6 @@ + +import System.Plugins + +main = do loadPackage "posix" + unloadPackage "posix" + loadPackage "posix" diff --git a/testsuite/load/unloadpkg/Makefile b/testsuite/load/unloadpkg/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/load/unloadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/unloadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/load/unloadpkg/expected b/testsuite/load/unloadpkg/expected new file mode 100644 --- /dev/null +++ b/testsuite/load/unloadpkg/expected diff --git a/testsuite/loadCLib/null/Makefile b/testsuite/loadCLib/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/loadCLib/null/Makefile @@ -0,0 +1,4 @@ +TEST= loadCLib/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/loadCLib/null/Null.hs b/testsuite/loadCLib/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/loadCLib/null/Null.hs @@ -0,0 +1,12 @@ +module Null ( resource ) where + +import API +import Data.Dynamic +import Prelude hiding (null) +import Graphics.Rendering.OpenGL + +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/testsuite/loadCLib/null/api/API.hs b/testsuite/loadCLib/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/loadCLib/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/testsuite/loadCLib/null/prog/Main.hs b/testsuite/loadCLib/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/loadCLib/null/prog/Main.hs @@ -0,0 +1,11 @@ + +import System.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 err -> error (unlines err) + LoadSuccess m v -> do putStrLn ( show (a v) ) ; unload m diff --git a/testsuite/loadCLib/null/prog/expected b/testsuite/loadCLib/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/loadCLib/null/prog/expected @@ -0,0 +1,1 @@ +42 diff --git a/testsuite/make/makeall001/A.hs b/testsuite/make/makeall001/A.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/makeall001/A.hs @@ -0,0 +1,3 @@ +module A where + +a = "a" diff --git a/testsuite/make/makeall001/B.hs b/testsuite/make/makeall001/B.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/makeall001/B.hs @@ -0,0 +1,3 @@ +module B where + +b = "b" diff --git a/testsuite/make/makeall001/C.hs b/testsuite/make/makeall001/C.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/makeall001/C.hs @@ -0,0 +1,3 @@ +module C where + +c = "c" diff --git a/testsuite/make/makeall001/Makefile b/testsuite/make/makeall001/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/makeall001/Makefile @@ -0,0 +1,3 @@ +TEST= make/makeall001 +TOP=../../.. +include ../../build.mk diff --git a/testsuite/make/makeall001/Tiny.hs b/testsuite/make/makeall001/Tiny.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/makeall001/api/API.hs b/testsuite/make/makeall001/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/makeall001/prog/Main.hs b/testsuite/make/makeall001/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/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 System.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/testsuite/make/makeall001/prog/expected b/testsuite/make/makeall001/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/makeall001/prog/expected @@ -0,0 +1,1 @@ +abc diff --git a/testsuite/make/null/Makefile b/testsuite/make/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/null/Makefile @@ -0,0 +1,4 @@ +TEST= make/null + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/make/null/Null.hs b/testsuite/make/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/null/api/API.hs b/testsuite/make/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/null/prog/Main.hs b/testsuite/make/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/null/prog/Main.hs @@ -0,0 +1,13 @@ + +-- an example where we want to compile and load a file + +import System.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/testsuite/make/null/prog/expected b/testsuite/make/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/null/prog/expected @@ -0,0 +1,1 @@ +42 diff --git a/testsuite/make/o/Makefile b/testsuite/make/o/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/o/Makefile @@ -0,0 +1,3 @@ +TEST=make/o +TOP =../../.. +include ../../build.mk diff --git a/testsuite/make/o/Plugin.hs b/testsuite/make/o/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/o/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/testsuite/make/o/api/API.hs b/testsuite/make/o/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/o/prog/Main.hs b/testsuite/make/o/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/o/prog/Main.hs @@ -0,0 +1,28 @@ +import System.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 +#if __GLASGOW_HASKELL__ >= 604 + tmpDir <- getTemporaryDirectory +#else + let tmpDir = "/tmp" +#endif + make "../Plugin.hs" [ "-i../api", "-o", (tmpDir ++ "/Plugin.o") ] + m_v <- load (tmpDir ++ "/Plugin.o") ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + + mapM_ removeFile [ (tmpDir ++ "/Plugin.hi"), (tmpDir ++ "/Plugin.o") ] diff --git a/testsuite/make/o/prog/expected b/testsuite/make/o/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/o/prog/expected @@ -0,0 +1,1 @@ +hello out there diff --git a/testsuite/make/odir/Makefile b/testsuite/make/odir/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/odir/Makefile @@ -0,0 +1,3 @@ +TEST= make/odir +TOP=../../.. +include ../../build.mk diff --git a/testsuite/make/odir/Plugin.hs b/testsuite/make/odir/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/odir/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/testsuite/make/odir/api/API.hs b/testsuite/make/odir/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/odir/prog/Main.hs b/testsuite/make/odir/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/odir/prog/Main.hs @@ -0,0 +1,21 @@ +import System.Plugins +import API +import System.Directory + +main = do +#if __GLASGOW_HASKELL__ >= 604 + tmpDir <- getTemporaryDirectory +#else + let tmpDir = "/tmp" +#endif + status <- make "../Plugin.hs" [ "-i../api", "-odir", tmpDir ] + 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 [(tmpDir ++ "/Plugin.hi"), (tmpDir ++ "/Plugin.o") ] + diff --git a/testsuite/make/odir/prog/expected b/testsuite/make/odir/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/odir/prog/expected @@ -0,0 +1,1 @@ +hello out there diff --git a/testsuite/make/remake001/Bar.hs b/testsuite/make/remake001/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undefined diff --git a/testsuite/make/remake001/Foo.hs b/testsuite/make/remake001/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/testsuite/make/remake001/Main.hs b/testsuite/make/remake001/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001/Main.hs @@ -0,0 +1,36 @@ +-- +-- expected output: +-- $ ./a.out +-- True +-- False +-- True +-- False +-- + +import System.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/testsuite/make/remake001/Makefile b/testsuite/make/remake001/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001/Makefile @@ -0,0 +1,4 @@ +TEST= merge/remake001 + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/make/remake001/expected b/testsuite/make/remake001/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +ReComp +NotReq diff --git a/testsuite/make/remake001_should_fail/Bar.hs b/testsuite/make/remake001_should_fail/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001_should_fail/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undef {- error -} diff --git a/testsuite/make/remake001_should_fail/Foo.hs b/testsuite/make/remake001_should_fail/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001_should_fail/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/testsuite/make/remake001_should_fail/Main.hs b/testsuite/make/remake001_should_fail/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001_should_fail/Main.hs @@ -0,0 +1,31 @@ + +import System.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/testsuite/make/remake001_should_fail/Makefile b/testsuite/make/remake001_should_fail/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001_should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= make/remake001_should_fail + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/make/remake001_should_fail/expected b/testsuite/make/remake001_should_fail/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/remake001_should_fail/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +"make failure" +"make failure" diff --git a/testsuite/make/simple/Makefile b/testsuite/make/simple/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/make/simple/Makefile @@ -0,0 +1,3 @@ +TEST= make/simple +TOP=../../.. +include ../../build.mk diff --git a/testsuite/make/simple/Tiny.hs b/testsuite/make/simple/Tiny.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/simple/api/API.hs b/testsuite/make/simple/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/make/simple/prog/Main.hs b/testsuite/make/simple/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/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 System.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/testsuite/make/simple/prog/expected b/testsuite/make/simple/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/make/simple/prog/expected @@ -0,0 +1,1 @@ +hello strange world diff --git a/testsuite/makewith/global_pragma/Makefile b/testsuite/makewith/global_pragma/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/global_pragma/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/global_pragma + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/makewith/global_pragma/Plugin.hs b/testsuite/makewith/global_pragma/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/global_pragma/Plugin.hs @@ -0,0 +1,17 @@ +{-# GLOBALOPTIONS -package mtl #-} + +module M ( resource ) where + +import API +import System.IO.Unsafe +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/testsuite/makewith/global_pragma/api/API.hs b/testsuite/makewith/global_pragma/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/global_pragma/prog/Main.hs b/testsuite/makewith/global_pragma/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/global_pragma/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/makewith/global_pragma/prog/expected b/testsuite/makewith/global_pragma/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/global_pragma/prog/expected @@ -0,0 +1,1 @@ +hello diff --git a/testsuite/makewith/io/Makefile b/testsuite/makewith/io/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/io/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/io + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/makewith/io/README b/testsuite/makewith/io/README new file mode 100644 --- /dev/null +++ b/testsuite/makewith/io/README @@ -0,0 +1,2 @@ +An example using IO monad fields in the .conf file. + diff --git a/testsuite/makewith/io/TestIO.conf.in b/testsuite/makewith/io/TestIO.conf.in new file mode 100644 --- /dev/null +++ b/testsuite/makewith/io/TestIO.conf.in @@ -0,0 +1,22 @@ +{-# 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.Process + +resource = testio { field = date } + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do +#if !defined(CYGWIN) || !defined(__MINGW32__) + (_,out,_,_) <- catch (runInteractiveCommand "/bin/date") (\_->error "popen failed") +#else + (_,out,_,_) <- catch (runInteractiveCommand "@PREFIX@/../../bin/date") (\_->error "popen failed") +#endif + hGetLine out diff --git a/testsuite/makewith/io/TestIO.stub b/testsuite/makewith/io/TestIO.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/io/api/API.hs b/testsuite/makewith/io/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/io/prog/Main.hs b/testsuite/makewith/io/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/io/prog/Main.hs @@ -0,0 +1,21 @@ + +import System.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/testsuite/makewith/io/prog/expected b/testsuite/makewith/io/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/io/prog/expected @@ -0,0 +1,6 @@ +merge failed: + +parse error in ../TestIO.conf +line: 17, col: 1 + +a.out: failed diff --git a/testsuite/makewith/merge00/Bar.hs b/testsuite/makewith/merge00/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/merge00/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/testsuite/makewith/merge00/Foo.hs b/testsuite/makewith/merge00/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/merge00/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/testsuite/makewith/merge00/Main.hs b/testsuite/makewith/merge00/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/merge00/Main.hs @@ -0,0 +1,38 @@ + +import System.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/testsuite/makewith/merge00/Makefile b/testsuite/makewith/merge00/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/merge00/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/merge00 + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/makewith/merge00/expected b/testsuite/makewith/merge00/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/merge00/expected @@ -0,0 +1,2 @@ +True +2989 diff --git a/testsuite/makewith/mergeto0/Bar.hs b/testsuite/makewith/mergeto0/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/mergeto0/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/testsuite/makewith/mergeto0/Foo.hs b/testsuite/makewith/mergeto0/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/mergeto0/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/testsuite/makewith/mergeto0/Main.hs b/testsuite/makewith/mergeto0/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/mergeto0/Main.hs @@ -0,0 +1,37 @@ + +import System.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/testsuite/makewith/mergeto0/Makefile b/testsuite/makewith/mergeto0/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/mergeto0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/mergeto0 + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/makewith/mergeto0/expected b/testsuite/makewith/mergeto0/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/mergeto0/expected @@ -0,0 +1,3 @@ +True +True +2989 diff --git a/testsuite/makewith/module_name/Bar.hs b/testsuite/makewith/module_name/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/module_name/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/testsuite/makewith/module_name/Foo.hs b/testsuite/makewith/module_name/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/module_name/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/testsuite/makewith/module_name/Main.hs b/testsuite/makewith/module_name/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/module_name/Main.hs @@ -0,0 +1,33 @@ + +import System.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/testsuite/makewith/module_name/Makefile b/testsuite/makewith/module_name/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/module_name/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/module_name + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/makewith/module_name/expected b/testsuite/makewith/module_name/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/module_name/expected @@ -0,0 +1,5 @@ +ReComp +NotReq +NotReq +True +1 diff --git a/testsuite/makewith/multi_make/Bar.hs b/testsuite/makewith/multi_make/Bar.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/Bar.hs @@ -0,0 +1,4 @@ +module Bar where + +resource :: Int +resource = 2 diff --git a/testsuite/makewith/multi_make/Foo.hs b/testsuite/makewith/multi_make/Foo.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/testsuite/makewith/multi_make/Main.hs b/testsuite/makewith/multi_make/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/Main.hs @@ -0,0 +1,37 @@ + +import System.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/testsuite/makewith/multi_make/Makefile b/testsuite/makewith/multi_make/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/multi_make + +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/makewith/multi_make/Stub.hs b/testsuite/makewith/multi_make/Stub.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/Stub.hs @@ -0,0 +1,4 @@ +module Stub where + +resource :: Int + diff --git a/testsuite/makewith/multi_make/expected b/testsuite/makewith/multi_make/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/multi_make/expected @@ -0,0 +1,6 @@ +ReComp +ReComp +NotReq +NotReq +True +True diff --git a/testsuite/makewith/should_fail_0/Makefile b/testsuite/makewith/should_fail_0/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/should_fail_0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/should_fail_0 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/makewith/should_fail_0/Plugin.in b/testsuite/makewith/should_fail_0/Plugin.in new file mode 100644 --- /dev/null +++ b/testsuite/makewith/should_fail_0/Plugin.in @@ -0,0 +1,3 @@ +module Plugin where + +resource = 0xBAD :: Int diff --git a/testsuite/makewith/should_fail_0/Plugin.stub b/testsuite/makewith/should_fail_0/Plugin.stub new file mode 100644 --- /dev/null +++ b/testsuite/makewith/should_fail_0/Plugin.stub @@ -0,0 +1,6 @@ +module Plugin ( resource ) where + +import API + +resource :: Interface +resource = plugin diff --git a/testsuite/makewith/should_fail_0/api/API.hs b/testsuite/makewith/should_fail_0/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/should_fail_0/prog/Main.hs b/testsuite/makewith/should_fail_0/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/should_fail_0/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/makewith/should_fail_0/prog/expected b/testsuite/makewith/should_fail_0/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/should_fail_0/prog/expected @@ -0,0 +1,1 @@ +make failed diff --git a/testsuite/makewith/tiny/Makefile b/testsuite/makewith/tiny/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/tiny/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/tiny + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/makewith/tiny/Tiny.conf b/testsuite/makewith/tiny/Tiny.conf new file mode 100644 --- /dev/null +++ b/testsuite/makewith/tiny/Tiny.conf @@ -0,0 +1,8 @@ +resource = tiny { + + field = "hello strange world" + +} + + + diff --git a/testsuite/makewith/tiny/Tiny.stub b/testsuite/makewith/tiny/Tiny.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/tiny/api/API.hs b/testsuite/makewith/tiny/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/tiny/prog/Main.hs b/testsuite/makewith/tiny/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/tiny/prog/Main.hs @@ -0,0 +1,21 @@ + +import System.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/testsuite/makewith/tiny/prog/expected b/testsuite/makewith/tiny/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/tiny/prog/expected @@ -0,0 +1,1 @@ +hello strange world diff --git a/testsuite/makewith/unsafeio/Makefile b/testsuite/makewith/unsafeio/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/makewith/unsafeio/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/unsafeio + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/makewith/unsafeio/README b/testsuite/makewith/unsafeio/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/unsafeio/Unsafe.conf.in b/testsuite/makewith/unsafeio/Unsafe.conf.in new file mode 100644 --- /dev/null +++ b/testsuite/makewith/unsafeio/Unsafe.conf.in @@ -0,0 +1,21 @@ +{-# GLOBALOPTIONS -package mtl #-} +-- 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 +#if !defined(CYGWIN) || !defined(__MINGW32__) + (_,outh,_,proc) <- runInteractiveProcess "date" [] Nothing Nothing +#else + (_,outh,_,proc) <- runInteractiveProcess "@PREFIX@/../../bin/date" [] Nothing Nothing +#endif + waitForProcess proc + s <- hGetContents outh + return s + diff --git a/testsuite/makewith/unsafeio/Unsafe.stub b/testsuite/makewith/unsafeio/Unsafe.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/unsafeio/api/API.hs b/testsuite/makewith/unsafeio/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/unsafeio/prog/Main.hs b/testsuite/makewith/unsafeio/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/makewith/unsafeio/prog/Main.hs @@ -0,0 +1,20 @@ +import System.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/testsuite/makewith/unsafeio/prog/README b/testsuite/makewith/unsafeio/prog/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/makewith/unsafeio/prog/expected b/testsuite/makewith/unsafeio/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/makewith/unsafeio/prog/expected @@ -0,0 +1,6 @@ +merge failed: + +parse error in ../Unsafe.conf +line: 13, col: 1 + +a.out: failed diff --git a/testsuite/misc/mkstemps/Main.hs b/testsuite/misc/mkstemps/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/misc/mkstemps/Main.hs @@ -0,0 +1,69 @@ + +import System.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/testsuite/misc/mkstemps/Makefile b/testsuite/misc/mkstemps/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/misc/mkstemps/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/misc/mkstemps/expected b/testsuite/misc/mkstemps/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/multi/3plugins/Makefile b/testsuite/multi/3plugins/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/multi/3plugins/Plugin1.hs b/testsuite/multi/3plugins/Plugin1.hs new file mode 100644 --- /dev/null +++ b/testsuite/multi/3plugins/Plugin1.hs @@ -0,0 +1,8 @@ +module Plugin1 where + +import API +import Data.Char + +resource = plugin { + valueOf = map toUpper +} diff --git a/testsuite/multi/3plugins/Plugin2.hs b/testsuite/multi/3plugins/Plugin2.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/multi/3plugins/Plugin3.hs b/testsuite/multi/3plugins/Plugin3.hs new file mode 100644 --- /dev/null +++ b/testsuite/multi/3plugins/Plugin3.hs @@ -0,0 +1,7 @@ +module Plugin3 where + +import API + +resource = plugin { + valueOf = reverse +} diff --git a/testsuite/multi/3plugins/api/API.hs b/testsuite/multi/3plugins/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/multi/3plugins/prog/Main.hs b/testsuite/multi/3plugins/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/multi/3plugins/prog/Main.hs @@ -0,0 +1,13 @@ +import System.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/testsuite/multi/3plugins/prog/expected b/testsuite/multi/3plugins/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/ArithmeticExpressionParser.hs b/testsuite/objc/expression_parser/ArithmeticExpressionParser.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/English.lproj/Credits.rtf b/testsuite/objc/expression_parser/English.lproj/Credits.rtf new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/English.lproj/InfoPlist.strings b/testsuite/objc/expression_parser/English.lproj/InfoPlist.strings new file mode 100644 Binary files /dev/null and b/testsuite/objc/expression_parser/English.lproj/InfoPlist.strings differ diff --git a/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib b/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib new file mode 100644 --- /dev/null +++ b/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib @@ -0,0 +1,4 @@ +{ + IBClasses = ({CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }); + IBVersion = 1; +} diff --git a/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/info.nib b/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/info.nib new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib b/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib new file mode 100644 Binary files /dev/null and b/testsuite/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib differ diff --git a/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib new file mode 100644 --- /dev/null +++ b/testsuite/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; +} diff --git a/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/info.nib b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/info.nib new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib new file mode 100644 Binary files /dev/null and b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib differ diff --git a/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib new file mode 100644 Binary files /dev/null and b/testsuite/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib differ diff --git a/testsuite/objc/expression_parser/Info.plist b/testsuite/objc/expression_parser/Info.plist new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/KeyValueParser.hs b/testsuite/objc/expression_parser/KeyValueParser.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/Makefile b/testsuite/objc/expression_parser/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/MyDocument.h b/testsuite/objc/expression_parser/MyDocument.h new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/MyDocument.m b/testsuite/objc/expression_parser/MyDocument.m new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/PluginEvalAux.hs b/testsuite/objc/expression_parser/PluginEvalAux.hs new file mode 100644 --- /dev/null +++ b/testsuite/objc/expression_parser/PluginEvalAux.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -fglasgow-exts -fffi #-} + +module PluginEvalAux where + +import System.Plugins.Make +import System.Plugins.Load +import System.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/testsuite/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj b/testsuite/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/PluginExpressionParser_Prefix.pch b/testsuite/objc/expression_parser/PluginExpressionParser_Prefix.pch new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/README b/testsuite/objc/expression_parser/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/RunHaskell.h b/testsuite/objc/expression_parser/RunHaskell.h new file mode 100644 --- /dev/null +++ b/testsuite/objc/expression_parser/RunHaskell.h @@ -0,0 +1,4 @@ +#include "HsFFI.h" + +extern HsPtr evalhaskell_CString(HsPtr a1, HsPtr a2); + diff --git a/testsuite/objc/expression_parser/dont_test b/testsuite/objc/expression_parser/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/objc/expression_parser/dont_test diff --git a/testsuite/objc/expression_parser/main.m b/testsuite/objc/expression_parser/main.m new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/objc/expression_parser/version.plist b/testsuite/objc/expression_parser/version.plist new file mode 100644 --- /dev/null +++ b/testsuite/objc/expression_parser/version.plist @@ -0,0 +1,16 @@ + + + + + BuildVersion + 17 + CFBundleShortVersionString + 0.1 + CFBundleVersion + 0.1 + ProjectName + NibPBTemplates + SourceVersion + 1150000 + + diff --git a/testsuite/pdynload/badint/Makefile b/testsuite/pdynload/badint/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/badint/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/badint + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/badint/Plugin.hs b/testsuite/pdynload/badint/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/badint/Plugin.hs @@ -0,0 +1,4 @@ +module Plugin where + +resource :: Num t => t +resource = 0xBAD diff --git a/testsuite/pdynload/badint/api/API.hs b/testsuite/pdynload/badint/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/badint/prog/Main.hs b/testsuite/pdynload/badint/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/badint/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/pdynload/badint/prog/expected b/testsuite/pdynload/badint/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/badint/prog/expected @@ -0,0 +1,1 @@ +wrong types diff --git a/testsuite/pdynload/bayley1/Load.hs b/testsuite/pdynload/bayley1/Load.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/Load.hs @@ -0,0 +1,42 @@ +module Load where + +import API +import System.Plugins + +-- +-- load doesn't seem to behave nicely when using dirname on hier names +-- +-- make, and maybe other places, use dirname to work out various names +-- from paths, which is invalid when hier names are used.. +-- + +testload = do + + s <- make "../Plugin1.hs" ["-i../api"] + o1 <- case s of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> fail "o1" + + s <- make "../Sub/Plugin2.hs" ["-i../api","-hidir.."] -- ! + o2 <- case s of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> fail "o2" + + fc <- pdynload o1 ["..","../api"] [] "API.PluginAPI" "action" + + case fc of + LoadFailure msg -> mapM_ putStrLn msg + LoadSuccess modul proc -> do + let ac :: API.PluginAPI; ac = proc + let s = proc 42 + print s + + -- will reqeust 'Plugin2', but module is actually 'Sub.Plugin2' + print o2 + fc <- pdynload (o2) ["..","../api"] [] "API.PluginAPI" "action" + case fc of + LoadFailure msg -> mapM_ putStrLn msg + LoadSuccess modul proc -> do + let ac :: API.PluginAPI; ac = proc + let s = proc 42 + print s diff --git a/testsuite/pdynload/bayley1/Makefile b/testsuite/pdynload/bayley1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/bayley1 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/bayley1/Plugin1.hs b/testsuite/pdynload/bayley1/Plugin1.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/Plugin1.hs @@ -0,0 +1,6 @@ +module Plugin1 where + +import qualified API +action :: API.PluginAPI +action i = show i + diff --git a/testsuite/pdynload/bayley1/Sub/Plugin2.hs b/testsuite/pdynload/bayley1/Sub/Plugin2.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/Sub/Plugin2.hs @@ -0,0 +1,6 @@ +module Sub.Plugin2 where + +import qualified API +action :: API.PluginAPI +action i = show i + diff --git a/testsuite/pdynload/bayley1/api/API.hs b/testsuite/pdynload/bayley1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/api/API.hs @@ -0,0 +1,6 @@ +module API where + +type PluginAPI = Int -> String +action :: PluginAPI +action i = show i + diff --git a/testsuite/pdynload/bayley1/prog/Main.hs b/testsuite/pdynload/bayley1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/bayley1/prog/Main.hs @@ -0,0 +1,4 @@ +module Main where +import Load +main = testload + diff --git a/testsuite/pdynload/null/Makefile b/testsuite/pdynload/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/null/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/null +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/null/Plugin.hs b/testsuite/pdynload/null/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/null/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = D 1 diff --git a/testsuite/pdynload/null/api/API.hs b/testsuite/pdynload/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/null/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/testsuite/pdynload/null/prog/Main.hs b/testsuite/pdynload/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.Plugins +-- import System.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/testsuite/pdynload/null/prog/expected b/testsuite/pdynload/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/null/prog/expected @@ -0,0 +1,1 @@ +done. diff --git a/testsuite/pdynload/numclass/Makefile b/testsuite/pdynload/numclass/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/numclass/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/numclass +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/numclass/Plugin.hs b/testsuite/pdynload/numclass/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/numclass/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +-- import API + +resource = "error" diff --git a/testsuite/pdynload/numclass/api/API.hs b/testsuite/pdynload/numclass/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/numclass/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/testsuite/pdynload/numclass/prog/Main.hs b/testsuite/pdynload/numclass/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/numclass/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/pdynload/numclass/prog/expected b/testsuite/pdynload/numclass/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/numclass/prog/expected @@ -0,0 +1,1 @@ +wrong types diff --git a/testsuite/pdynload/poly/Makefile b/testsuite/pdynload/poly/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/poly + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/poly/Plugin.hs b/testsuite/pdynload/poly/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/poly/api/API.hs b/testsuite/pdynload/poly/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/poly/prog/Main.hs b/testsuite/pdynload/poly/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/poly/prog/expected b/testsuite/pdynload/poly/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly/prog/expected @@ -0,0 +1,1 @@ +loaded .. yay! diff --git a/testsuite/pdynload/poly1/Makefile b/testsuite/pdynload/poly1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly1/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/poly1 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/poly1/Plugin.hs b/testsuite/pdynload/poly1/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) } diff --git a/testsuite/pdynload/poly1/api/API.hs b/testsuite/pdynload/poly1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/poly1/prog/Main.hs b/testsuite/pdynload/poly1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly1/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/pdynload/poly1/prog/expected b/testsuite/pdynload/poly1/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/poly1/prog/expected @@ -0,0 +1,1 @@ +3 diff --git a/testsuite/pdynload/should_fail0/Makefile b/testsuite/pdynload/should_fail0/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail0/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/should_fail0 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/should_fail0/Plugin.hs b/testsuite/pdynload/should_fail0/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/should_fail0/api/API.hs b/testsuite/pdynload/should_fail0/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/should_fail0/prog/Main.hs b/testsuite/pdynload/should_fail0/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail0/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/pdynload/should_fail0/prog/expected b/testsuite/pdynload/should_fail0/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail0/prog/expected @@ -0,0 +1,1 @@ +wrong types diff --git a/testsuite/pdynload/should_fail1/Makefile b/testsuite/pdynload/should_fail1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/should_fail1/Plugin.hs b/testsuite/pdynload/should_fail1/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +data I = I Int + +resource = I 1 diff --git a/testsuite/pdynload/should_fail1/api/API.hs b/testsuite/pdynload/should_fail1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/should_fail1/prog/Main.hs b/testsuite/pdynload/should_fail1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail1/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/should_fail1/prog/expected b/testsuite/pdynload/should_fail1/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/should_fail1/prog/expected @@ -0,0 +1,1 @@ +wrong types diff --git a/testsuite/pdynload/small/Makefile b/testsuite/pdynload/small/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/small/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/small +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/small/Plugin.hs b/testsuite/pdynload/small/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/small/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = "good" } diff --git a/testsuite/pdynload/small/api/API.hs b/testsuite/pdynload/small/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/small/prog/Main.hs b/testsuite/pdynload/small/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/small/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/pdynload/small/prog/expected b/testsuite/pdynload/small/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/small/prog/expected @@ -0,0 +1,1 @@ +loaded .. yay! diff --git a/testsuite/pdynload/spj1/Makefile b/testsuite/pdynload/spj1/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj1/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/spj1/Plugin.hs b/testsuite/pdynload/spj1/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj1/api/API.hs b/testsuite/pdynload/spj1/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj1/dont_test b/testsuite/pdynload/spj1/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj1/dont_test diff --git a/testsuite/pdynload/spj1/prog/Main.hs b/testsuite/pdynload/spj1/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj1/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/spj1/prog/expected b/testsuite/pdynload/spj1/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj1/prog/expected diff --git a/testsuite/pdynload/spj2/Makefile b/testsuite/pdynload/spj2/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj2/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/spj2/Plugin.hs b/testsuite/pdynload/spj2/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj2/api/API.hs b/testsuite/pdynload/spj2/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj2/api/API.hs @@ -0,0 +1,6 @@ + +module API where + +-- simple type +type Interface = Int + diff --git a/testsuite/pdynload/spj2/prog/Main.hs b/testsuite/pdynload/spj2/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj2/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/spj2/prog/expected b/testsuite/pdynload/spj2/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj2/prog/expected @@ -0,0 +1,1 @@ +7 diff --git a/testsuite/pdynload/spj3/Makefile b/testsuite/pdynload/spj3/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj3/Makefile @@ -0,0 +1,3 @@ +TEST= pdynload/spj3 +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/spj3/Plugin.hs b/testsuite/pdynload/spj3/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj3/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) :: Int -> Int -> Int } diff --git a/testsuite/pdynload/spj3/api/API.hs b/testsuite/pdynload/spj3/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj3/prog/Main.hs b/testsuite/pdynload/spj3/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj3/prog/Main.hs @@ -0,0 +1,18 @@ + +import System.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/testsuite/pdynload/spj3/prog/expected b/testsuite/pdynload/spj3/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj3/prog/expected.604 b/testsuite/pdynload/spj3/prog/expected.604 new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj3/prog/expected.605 b/testsuite/pdynload/spj3/prog/expected.605 new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj3/prog/expected.605 @@ -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/testsuite/pdynload/spj4/Makefile b/testsuite/pdynload/spj4/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj4/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj4 + +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/spj4/Plugin.hs b/testsuite/pdynload/spj4/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/spj4/api/API.hs b/testsuite/pdynload/spj4/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj4/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +newtype Interface = Interface { field :: Int } + diff --git a/testsuite/pdynload/spj4/prog/Main.hs b/testsuite/pdynload/spj4/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj4/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/spj4/prog/expected b/testsuite/pdynload/spj4/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/spj4/prog/expected @@ -0,0 +1,1 @@ +7 diff --git a/testsuite/pdynload/typealias/Makefile b/testsuite/pdynload/typealias/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/typealias/Plugin.hs b/testsuite/pdynload/typealias/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/typealias/Plugin.hs @@ -0,0 +1,3 @@ +module Plugin where + +resource = 1 :: Int diff --git a/testsuite/pdynload/typealias/api/API.hs b/testsuite/pdynload/typealias/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/typealias/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +type Interface = Int + +rsrc :: Interface +rsrc = 1 + diff --git a/testsuite/pdynload/typealias/prog/Main.hs b/testsuite/pdynload/typealias/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/typealias/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/pdynload/typealias/prog/expected b/testsuite/pdynload/typealias/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/typealias/prog/expected @@ -0,0 +1,1 @@ +loaded .. yay! diff --git a/testsuite/pdynload/univquant/Makefile b/testsuite/pdynload/univquant/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/univquant/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/univquant +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/pdynload/univquant/Plugin.hs b/testsuite/pdynload/univquant/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/univquant/api/API.hs b/testsuite/pdynload/univquant/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pdynload/univquant/prog/Main.hs b/testsuite/pdynload/univquant/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/univquant/prog/Main.hs @@ -0,0 +1,17 @@ + +import System.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/testsuite/pdynload/univquant/prog/expected b/testsuite/pdynload/univquant/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/pdynload/univquant/prog/expected @@ -0,0 +1,1 @@ +loaded .. yay! diff --git a/testsuite/pkgconf/null/Makefile b/testsuite/pkgconf/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pkgconf/null/Null.hs b/testsuite/pkgconf/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/pkgconf/null/Null.hs @@ -0,0 +1,6 @@ +module Null ( resource ) where + +import API + +resource = plugin { a = 7 } + diff --git a/testsuite/pkgconf/null/api/API.hs b/testsuite/pkgconf/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pkgconf/null/api/package.conf.in b/testsuite/pkgconf/null/api/package.conf.in new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/pkgconf/null/dont_test b/testsuite/pkgconf/null/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/pkgconf/null/dont_test diff --git a/testsuite/pkgconf/null/prog/Main.hs b/testsuite/pkgconf/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/pkgconf/null/prog/Main.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import System.Plugins +import API + +main = do + let includes = TOP ++ "/testsuite/load/null/api" + (_,v) <- load "../Null.o" ["."] ["../api/package.conf"] "resource" + putStrLn ( show (a v) ) + diff --git a/testsuite/plugs/plugs/Main.hs b/testsuite/plugs/plugs/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/plugs/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 System.Eval.Haskell +import System.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 (return ()) + 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/testsuite/plugs/plugs/Makefile b/testsuite/plugs/plugs/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/plugs/plugs/Makefile @@ -0,0 +1,28 @@ +GHCFLAGS= -O +PKGFLAGS+= -package plugins -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/testsuite/plugs/plugs/expected b/testsuite/plugs/plugs/expected new file mode 100644 --- /dev/null +++ b/testsuite/plugs/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/testsuite/plugs/plugs/test.in b/testsuite/plugs/plugs/test.in new file mode 100644 --- /dev/null +++ b/testsuite/plugs/plugs/test.in @@ -0,0 +1,2 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 +:quit diff --git a/testsuite/plugs/runplugs/Main.hs b/testsuite/plugs/runplugs/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/plugs/runplugs/Main.hs @@ -0,0 +1,57 @@ +-- +-- 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) +-- + +-- +-- | Runplugs: use hs-plugins to run a Haskell expression under +-- controlled conditions. +-- +import System.Eval.Haskell (unsafeEval) + +import Data.Char (chr) +import Data.Maybe (isJust, fromJust) +import Control.Monad + +import System.Random +import System.Exit (exitWith, ExitCode(ExitSuccess)) +import System.IO (getContents, putStrLn) +import System.Posix.Resource (setResourceLimit, + Resource(ResourceCPUTime), + ResourceLimits(ResourceLimits), + ResourceLimit(ResourceLimit)) + +import qualified Control.Exception (catch) + +rlimit = ResourceLimit 3 + +context = prehier ++ datas ++ qualifieds ++ controls + +prehier = ["Char", "List", "Maybe", "Numeric", "Random" ] + +qualifieds = ["qualified Data.Map as M" + ,"qualified Data.Set as S" + ,"qualified Data.IntSet as I"] + +datas = map ("Data." ++) [ + "Bits", "Bool", "Char", "Dynamic", "Either", + "Graph", "Int", "Ix", "List", + "Maybe", "Ratio", "Tree", "Tuple", "Typeable", "Word" + ] + +controls = map ("Control." ++) ["Monad", "Monad.Reader", "Monad.Fix", "Arrow"] + +main = do + setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit) + s <- getLine + when (not . null $ s) $ do + x <- sequence (take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr)) + s <- unsafeEval ("let { "++x++ + " = \n# 1 \"\"\n"++s++ + "\n} in take 2048 (show "++x++ + ")") context + when (isJust s) $ Control.Exception.catch + (putStrLn $ fromJust s) + (\e -> putStrLn $ "Exception: " ++ show e ) + exitWith ExitSuccess + diff --git a/testsuite/plugs/runplugs/Makefile b/testsuite/plugs/runplugs/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/plugs/runplugs/Makefile @@ -0,0 +1,30 @@ +GHCFLAGS= -Onot $(GHC_EXTRA_OPTS) +PKGFLAGS= -package posix +PKGFLAGS+= -package plugins + +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/testsuite/plugs/runplugs/expected b/testsuite/plugs/runplugs/expected new file mode 100644 --- /dev/null +++ b/testsuite/plugs/runplugs/expected @@ -0,0 +1,1 @@ +453973694165307953197296969697410619233826 diff --git a/testsuite/plugs/runplugs/test.in b/testsuite/plugs/runplugs/test.in new file mode 100644 --- /dev/null +++ b/testsuite/plugs/runplugs/test.in @@ -0,0 +1,1 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 diff --git a/testsuite/reload/null/Makefile b/testsuite/reload/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/reload/null/Makefile @@ -0,0 +1,4 @@ +TEST= reload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/reload/null/Null.hs b/testsuite/reload/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/reload/null/api/API.hs b/testsuite/reload/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/reload/null/prog/Main.hs b/testsuite/reload/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/reload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import System.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/testsuite/reload/null/prog/expected b/testsuite/reload/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/reload/null/prog/expected @@ -0,0 +1,2 @@ +42 +42 diff --git a/testsuite/shell/shell/API.hs b/testsuite/shell/shell/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/shell/Main.hs b/testsuite/shell/shell/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/shell/shell/Main.hs @@ -0,0 +1,85 @@ +-- +-- a simple shell for loading plugins and evaluating their functions +-- + +import System.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/testsuite/shell/shell/Makefile b/testsuite/shell/shell/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/shell/shell/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/testsuite/shell/shell/Plugin.hs b/testsuite/shell/shell/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/shell/shell/Plugin.hs @@ -0,0 +1,5 @@ + +resource = plugin { + function = map toUpper +} + diff --git a/testsuite/shell/shell/Plugin.stub b/testsuite/shell/shell/Plugin.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/shell/README b/testsuite/shell/shell/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/shell/dont_test b/testsuite/shell/shell/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/shell/shell/dont_test diff --git a/testsuite/shell/simple/Main.hs b/testsuite/shell/simple/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/shell/simple/Main.hs @@ -0,0 +1,41 @@ +import System.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/testsuite/shell/simple/Makefile b/testsuite/shell/simple/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/shell/simple/Makefile @@ -0,0 +1,6 @@ +OBJS=StringProcessorAPI.o +TOP=../../.. +include ../../eval.mk + +#all: +# @echo test disabled diff --git a/testsuite/shell/simple/Plugin.hs b/testsuite/shell/simple/Plugin.hs new file mode 100644 --- /dev/null +++ b/testsuite/shell/simple/Plugin.hs @@ -0,0 +1,5 @@ +import Char + +resource = plugin { + stringProcessor = map toUpper +} diff --git a/testsuite/shell/simple/Plugin.stub b/testsuite/shell/simple/Plugin.stub new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/simple/README b/testsuite/shell/simple/README new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/simple/StringProcessorAPI.hs b/testsuite/shell/simple/StringProcessorAPI.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/shell/simple/dont_test b/testsuite/shell/simple/dont_test new file mode 100644 --- /dev/null +++ b/testsuite/shell/simple/dont_test diff --git a/testsuite/unload/null/Makefile b/testsuite/unload/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/unload/null/Makefile @@ -0,0 +1,4 @@ +TEST= unload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/unload/null/Null.hs b/testsuite/unload/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/unload/null/api/API.hs b/testsuite/unload/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/unload/null/prog/Main.hs b/testsuite/unload/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/unload/null/prog/Main.hs @@ -0,0 +1,11 @@ + +import System.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/testsuite/unload/null/prog/expected b/testsuite/unload/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/unload/null/prog/expected @@ -0,0 +1,1 @@ +42 diff --git a/testsuite/unload/sjwtrap/Makefile b/testsuite/unload/sjwtrap/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/unload/sjwtrap/Makefile @@ -0,0 +1,4 @@ +TEST= unload/sjwtrap +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/unload/sjwtrap/Null.hs b/testsuite/unload/sjwtrap/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/unload/sjwtrap/Null.hs @@ -0,0 +1,6 @@ +module Null where + +import qualified Prelude +import API + +resource = null diff --git a/testsuite/unload/sjwtrap/api/API.hs b/testsuite/unload/sjwtrap/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/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/testsuite/unload/sjwtrap/prog/Main.hs b/testsuite/unload/sjwtrap/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/unload/sjwtrap/prog/Main.hs @@ -0,0 +1,15 @@ + +import System.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/testsuite/unload/sjwtrap/prog/expected b/testsuite/unload/sjwtrap/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/unload/sjwtrap/prog/expected @@ -0,0 +1,1 @@ +42 diff --git a/testsuite/unloadAll/null/Dep.hs b/testsuite/unloadAll/null/Dep.hs new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/null/Dep.hs @@ -0,0 +1,7 @@ +module Dep ( resource ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null diff --git a/testsuite/unloadAll/null/Makefile b/testsuite/unloadAll/null/Makefile new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/null/Makefile @@ -0,0 +1,4 @@ +TEST= unloadAll/null +EXTRA_OBJS=Dep.o Null.o +TOP=../../.. +include ../../build.mk diff --git a/testsuite/unloadAll/null/Null.hs b/testsuite/unloadAll/null/Null.hs new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/null/Null.hs @@ -0,0 +1,12 @@ +module Null ( resource ) where + +import API +import Data.Dynamic +import Prelude hiding (null) +import qualified Dep + +resource = Dep.resource + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/testsuite/unloadAll/null/api/API.hs b/testsuite/unloadAll/null/api/API.hs new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/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/testsuite/unloadAll/null/prog/Main.hs b/testsuite/unloadAll/null/prog/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/null/prog/Main.hs @@ -0,0 +1,15 @@ + +import System.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" + t <- load_ "../Dep.o" ["../api"] "resource" + case m_v of + LoadFailure err -> error (unlines err) + LoadSuccess m v -> do putStrLn ( show (a v) ) ; unloadAll m -- unloads Null.o but not Dep.o since we're still using it. + case t of + LoadFailure err -> error (unlines err) + LoadSuccess m v -> do putStrLn ( show (a v) ) ; unloadAll m diff --git a/testsuite/unloadAll/null/prog/expected b/testsuite/unloadAll/null/prog/expected new file mode 100644 --- /dev/null +++ b/testsuite/unloadAll/null/prog/expected @@ -0,0 +1,2 @@ +42 +42